ExCel表格->AutoCAD表格(源码公布)

Gu_xl · 发表于 2013-6-9 13:24

本帖最后由 Gu_xl 于 2013-6-22 09:04 编辑

花了两天时间，仿照 KozMos XL2CAD 的程序同样写了一个Excel2CAD程序，控制对话框就直接照搬 KozMos XL2CAD的对话框，操作方式完全和他一样！
2013年6月22日公布全部源码

程序界面:

使用演示：

编译的VLX程序文件:
2013.06.11更新程序：
增加按Excel页面设置来分页输出表格功能！（包括页眉、页脚、表头等内容）
新程序界面：

2013.06.12日更新，修正了一些Bug, 增加了表格实体颜色随层或随块的选项。更新了界面如下:

请大家来下载使用，使用过程中发现问题，多提出宝贵意见，等程序完善后，我再放出全部源码，下面是主程序源码:

(defun c:x2c (/ *XLAPP* ACT_ANNOCOLOR ACT_BLAYER ACT_CELLCOLOR ACT_GETFILE ACT_GROUP ACT_KEEPTHEIGHT
ACT_MERGE ACT_NONE ACT_PAGESETUP ACT_PRINTAREA
ACT_TLAYER ACT_UBLOCK ACT_USED ACT_USER
BASEPOINT CELLS COL CURPT
DCLCODE DD DEFAULTHEIGHT DRAWPAGESETUP
DXF40 DXF420 DXF62 DXF7
DXF71 DXF71DATA ECODE ENDENT
FONT GET9JUSTPTS GETRANGETEXTSTYLE
GRIDSCALE HEIGHT HEIGHT1
HORIZONTALALIGNMENT HORLINE HPAGEBREAKS
INTERIORCOLOR INTERIORTRUECOLOR LAYERS
MERGEID MERGEP MKTMPDCL
OLDHEIGHT OLDROW P0 P1
P2 P3 PAGE PAGEMARGIN
PAGESETUP PRINTAREA PRINTTITLEROWS
RANGE RANGEFONT RIGHTTOPPT ROW
S1 SCALE SELECTION SHEET
SS STANDARDFONT STANDARDFONTSIZE
START_XL2X STARTPOINT TEXT TEXTFONT
TEXTPT TEXTVERFLAG TMP TO
TOTALHEIGHT TOTALPAGE TOTALWIDE USEDRANGE
VERLINES VERTICALALIGNMENT WIDTH
WIDTH1 WORKBOOK WORKBOOKS ACT_RANGE
ACT_THEIGHT BLAYER CAPTION CFONT
CHAR CHARFONT F
HORIZONTALALIGNMEN I II
INTERIORCOLOR1 KD SSTITLE
TLAYER TMPPT VERLINE TITLEROWS
TMP TMP1 *DRAWRANGE* *CELLCOLOR*
*ANNOCOLOR* *OPRATE* *MERGE* *THEIGHT*
*KEEPTHEIGHT* *PAGESETUP* *DEFAULTCOLOR* SSSolid
)
;;计算九宫格点
(defun Get9JustPts (LL UR / tmp BC BL BR MC ML MR TC TL TR)
(setq
LL (list (car LL) (cadr LL) 0.0)
UR (list (car UR) (cadr UR) 0.0)
BL LL
TR UR
MC (GXL-MIDPOINT BL TR)
TL (list (car BL) (cadr TR) 0.0)
TC (list (car MC) (cadr TR) 0.0)
MR (list (car TR) (cadr MC) 0.0)
BR (list (car TR) (cadr BL) 0.0)
BC (list (car MC) (cadr BL) 0.0)
ML (list (car BL) (cadr MC) 0.0)
)
(list TL TC TR ML MC MR BL BC BR)
)
;;创建临时对话框
(defun mkTmpDcl (dclname / tmpdcl f _GetSavePath)
(DEFUN _GETSAVEPATH (/ TMP)
(COND ((SETQ TMP (GETVAR (QUOTE ROAMABLEROOTPREFIX)))
(OR (EQ "\\" (SUBSTR TMP (STRLEN TMP)))
(SETQ TMP (STRCAT TMP "\\"))
)
(STRCAT TMP "Support")
)
((SETQ TMP (FINDFILE "ACAD.pat"))
(SETQ TMP (VL-FILENAME-DIRECTORY TMP))
(AND (EQ "\\" (SUBSTR TMP (STRLEN TMP)))
(SETQ TMP (SUBSTR TMP (1- (STRLEN TMP))))
)
TMP
)
)
)
(IF DCLNAME
(SETQ TMPDCL
(STRCAT (_GETSAVEPATH)
"\\"
(if (and
(> (strlen DCLNAME) 4)
(= ".dcl"
(substr (setq DCLNAME (STRCASE DCLNAME T))
(- (strlen DCLNAME) 3)
4
)
)
)
(substr DCLNAME 1 (- (strlen DCLNAME) 4))
DCLNAME
)
".dcl"
)
)
(SETQ TMPDCL (VL-FILENAME-MKTEMP "tmp" "" ".dcl"))
)
(if (not (findfile tmpdcl))
(progn
(setq f (open tmpdcl "w"))
(foreach str '("xl2cad:dialog {"
" label = \"Excel 转CAD表格【Gu_xl】\" ;"
" :boxed_radio_column {"
" key = \"Range\" ;"
" label = \"Excel数据范围\" ;"
" :radio_button {"
" key = \"Used\" ;"
" label = \"所有使用的单元格\" ;"
" }"
" :radio_button {"
" key = \"User\" ;"
" label = \"用户选定的单元格\" ;"
" }"
" :radio_button {"
" key = \"PrintArea\" ;"
" label = \"页面可打印区域\" ;"
" }"
" }"
":button {"
" alignment = left ;"
" fixed_height = true ;"
" fixed_width = true ;"
" key = \"getfile\" ;"
" label = \"选择Excel文件->\" ;"
" width = 20 ;"
"}"
" :boxed_column {"
" label = \"生成设定\" ;"
" :row {"
" :toggle {"
" key = \"CellColor\" ;"
" label = \"单元格背景颜色\" ;"
" }"
" :toggle {"
" key = \"AnnoColor\" ;"
" label = \"文本颜色\" ;"
" }"
" }"
" :row {"
" :toggle {"
" key = \"PageSetup\" ;"
" label = \"按页面设置输出\" ;"
" }"
" :toggle {"
" key = \"Merge\" ;"
" label = \"合并表格线\" ;"
" }"
" }"
" :row {"
" :toggle {"
" key = \"KeepTHeight\" ;"
" label = \"缺省文本高度\" ;"
" }"
" :edit_box {"
" key = \"THeight\" ;"
" label = \"\" ;"
" }"
" }"
" :boxed_radio_row {"
" key = \"Gather\" ;"
" label = \"实体集合\" ;"
" :radio_button {"
" key = \"None\" ;"
" label = \"无操作\" ;"
" }"
" :radio_button {"
" key = \"Group\" ;"
" label = \"无名组\" ;"
" }"
" :radio_button {"
" key = \"UBlock\" ;"
" label = \"无名块\" ;"
" }"
" }"
" :boxed_column {"
" label = \"实体图层\" ;"
" :popup_list {"
" edit_width = 15 ;"
" key = \"BLayer\" ;"
" label = \"单元格线:\" ;"
" }"
" :popup_list {"
" edit_width = 15 ;"
" key = \"TLayer\" ;"
" label = \"表格内容:\" ;"
" }"
" :row {"
" :radio_button {"
" key = \"ByLayer\" ;"
" label = \"颜色随层\" ;"
" }"
" :radio_button {"
" key = \"ByBlock\" ;"
" label = \"颜色随块\" ;"
" }"
" }"
" }"
" }"
" ok_cancel_help;"
" errtile;"
"}"
)
(write-line str f)
)
(close f)
)
)
tmpdcl
)
;;
(defun start_xl2x ()
(setq *DrawRange* (getenv "Excel2CAD\\DrawRange"))
(if (null *DrawRange*)
(progn
(setq *DrawRange* "Used")
(setEnv "Excel2CAD\\DrawRange" *DrawRange*)
)
)
(set_tile *DrawRange* "1")
(GXL-DCL-ADDLIST "BLayer" Layers (VL-POSITION "0" Layers))
(setq BLayer (nth 0 layers))
(GXL-DCL-ADDLIST "TLayer" Layers (VL-POSITION "0" Layers))
(setq TLayer (nth 0 layers))
(setq *CellColor* (= "1" (getenv "Excel2CAD\\CellColor")))
(if *CellColor*
(set_tile "CellColor" "1") ;_ 背景颜色
(progn
(set_tile "CellColor" "0") ;_ 背景颜色
(setEnv "Excel2CAD\\CellColor" "0")
)
)
(setq *AnnoColor* (= "1" (getenv "Excel2CAD\\AnnoColor")))
(if *AnnoColor*
(set_tile "AnnoColor" "1") ;_ 文本颜色
(progn
(set_tile "AnnoColor" "0") ;_ 文本颜色
(setEnv "Excel2CAD\\AnnoColor" "0")
)
)
(setq *Oprate* (getenv "Excel2CAD\\Oprate"))
(if *Oprate*
(setq *Oprate* (atoi *Oprate*))
(setq *Oprate* 0)
)
(setenv "Excel2CAD\\Oprate" (itoa *Oprate*))
(cond
((or (null *Oprate*) (= 0 *Oprate*))
(setq *Oprate* 0)
(set_tile "None" "1")
)
((= 1 *Oprate*)
(set_tile "Group" "1")
)
((= 2 *Oprate*)
(set_tile "UBlock" "1")
)
)
(setq *Merge* (= "1" (getenv "Excel2CAD\\Merge")))
(if *Merge*
(set_tile "Merge" "1")
(progn
(set_tile "Merge" "0")
(Setenv "Excel2CAD\\Merge" "0")
)
)
(setq *THeight* (getenv "Excel2CAD\\THeight"))
(if (null *THeight*)
(progn
(setq *THeight* 300)
(Setenv "Excel2CAD\\THeight" "300")
)
(setq *THeight* (atof *THeight*))
)
(set_tile "THeight" (rtos *THeight* 2))
(setq *KeepTHeight* (= "1" (getenv "Excel2CAD\\KeepTHeight")))
(if *KeepTHeight*
(progn
(mode_tile "THeight" 0)
(set_tile "KeepTHeight" "1")
)
(progn
(mode_tile "THeight" 1)
(set_tile "KeepTHeight" "0")
(Setenv "Excel2CAD\\KeepTHeight" "0")
)
)
(setq *pageSetUp* (= "1" (getenv "Excel2CAD\\pageSetUp")))
(if *pageSetUp*
(set_tile "PageSetup" "1")
(progn
(set_tile "PageSetup" "0")
(Setenv "Excel2CAD\\PageSetup" "0")
)
)
(setq *defaultColor* (getenv "Excel2CAD\\defaultColor"))
(if (null *defaultColor*)
(progn
(setq *defaultColor* 0)
(Setenv "Excel2CAD\\defaultColor" "0")
)
(setq *defaultColor* (atoi *defaultColor*))
)
(cond
((= 0 *defaultColor*) (set_tile "ByBlock" "1"))
(t (set_tile "ByLayer" "1")
(setq *defaultColor* 256)
)
)
;;控件控制动作
(action_tile "getfile" "(act_getfile)")
(action_tile "Used" "(act_Used $key $value $reason)")
(action_tile "PrintArea" "(act_PrintArea $key $value)")
(action_tile "User" "(act_User $key $value $reason)")
(action_tile "CellColor" "(act_CellColor $key $value $reason)")
(action_tile "AnnoColor" "(act_AnnoColor $key $value $reason)")
(action_tile "PageSetup" "(act_PageSetup $key $value)")
(action_tile "Merge" "(act_Merge $key $value $reason)")
(action_tile "KeepTHeight" "(act_KeepTHeight $value)")
(action_tile "THeight" "(setq *THeight* (gxl-chkrealp $value $key 6)) (if *THeight* (Setenv \"Excel2CAD\\\\THeight\" (rtos *THeight* 2)))")
(action_tile "Gather" "(act_Gather $key $value $reason)")
(action_tile "None" "(act_None $key $value $reason)")
(action_tile "Group" "(act_Group $key $value $reason)")
(action_tile "UBlock" "(act_UBlock $key $value $reason)")
(action_tile "BLayer" "(act_BLayer $key $value $reason)")
(action_tile "TLayer" "(act_TLayer $key $value $reason)")
(action_tile "ByBlock" "(setq *defaultColor* 0) (Setenv \"Excel2CAD\\\\defaultColor\" \"0\")")
(action_tile "ByLayer" "(setq *defaultColor* 256) (Setenv \"Excel2CAD\\\\defaultColor\" \"256\")")
(action_tile "help" "(alert \"***Excel To AutoCAD*** \n\n版权所有:Gu_xl \n\n联系方式:Gu_xl@sohu.com\n\n\")")
)
;;act_getfile动作
(defun act_getfile (/ filename)
(setq filename (getfiled "" "" "xls;xlsx" 4))
(if filename (setq *xlapp* (vlxls-app-open filename t)))
)
;;控件 Used 动作
(defun act_Used (key val reason)
(setq *DrawRange* key)
(setEnv "Excel2CAD\\DrawRange" key)
)
;;控件 User 动作
(defun act_User (key val reason)
(setq *DrawRange* key)
(setEnv "Excel2CAD\\DrawRange" key)
)
(defun act_PrintArea (key val)
(setq *DrawRange* key)
(setEnv "Excel2CAD\\DrawRange" key)
)
;;控件 CellColor 动作
(defun act_CellColor (key val reason)
(setq *CellColor* (= "1" val))
(setEnv "Excel2CAD\\CellColor" val)
)
;;控件 AnnoColor 动作
(defun act_AnnoColor (key val reason)
(setq *AnnoColor* (= "1" val))
(setEnv "Excel2CAD\\AnnoColor" val)
)
;;按页面设置输出
(defun act_PageSetup (key val)
(setq *PageSetUp* (= "1" val))
(setEnv "Excel2CAD\\PageSetup" val)
)
;;控件 Merge 动作
(defun act_Merge (key val reason)
(setq *Merge* (= "1" val))
(setEnv "Excel2CAD\\Merge" val)
)
;;控件 None 动作
(defun act_None (key val reason)
(setq *Oprate* 0)
(set_tile "None" "1")
(setEnv "Excel2CAD\\Oprate" "0")
)
;;控件 Group 动作
(defun act_Group (key val reason)
(setq *Oprate* 1)
(set_tile "Group" "1")
(setEnv "Excel2CAD\\Oprate" "1")
)
;;控件 UBlock 动作
(defun act_UBlock (key val reason)
(setq *Oprate* 2)
(set_tile "UBlock" "1")
(setEnv "Excel2CAD\\Oprate" "2")
)
;;缺省文本高度
(defun act_KeepTHeight (val)
(setq *KeepTHeight* (= "1" val))
(setEnv "Excel2CAD\\KeepTHeight" val)
(if *KeepTHeight*
(mode_tile "THeight" 0)
(mode_tile "THeight" 1)
)
)
;;控件 BLayer 动作
(defun act_BLayer (key val reason)
(setq BLayer (nth (read val) layers))
)
;;控件 TLayer 动作
(defun act_TLayer (key val reason)
(setq TLayer (nth (read val) layers))
)
;;绘制顶端标题
(defun PrintTitleRows (Range / R PRINTAREA
CELLS COL ROW
MERGEP WIDTH HEIGHT
TEXT FONT HORIZONTALALIGNMENT
VERTICALALIGNMENT DXF71
DXF62 DXF420 RANGEFONT
DXF7 TEXTFONT DXF40
TEXTVERFLAG TMP OLDROW
P0
RIGHTTOPPT OLDHEIGHT MERGEID
WIDTH1 HEIGHT1 P1
P2 P3 HORLINE
VERLINES INTERIORCOLOR
INTERIORTRUECOLOR TEXTPT
Columns
)
(setq r (VLXLS-GET-PROPERTY
*XLAPP*
"ActiveSheet.PageSetup.PrintTitleRows"
)
)
(if (/= "" r)
(progn
(progn
(setq r (GXL-STRPARSE r ":"))
(vlax-for a (VLXLS-GET-PROPERTY range "Columns")
(setq
Columns (cons (VLXLS-GET-PROPERTY a "Column") Columns)
)
)
(setq Columns (reverse Columns))
(setq r (strcat (chr (+ 64 (car Columns))) (car r) ":" (chr (+ 64 (last Columns))) (last r)))
(setq range (vlax-get-property *XLAPP* 'range r)
cells (vlax-get-property range 'cells)
)
;;逐个绘制表头，未完成
(vlax-for cell cells
(gxl-Sys-Progress to -1)
(setq col (vlax-get-property cell 'column)
row (vlax-get-property cell 'row)
range (msxlp-get-range
*xlApp*
(VLXLS-RANGEID (list col row))
)
Mergep (equal :vlax-true
(vlax-variant-value
(vlax-get-property cell 'MergeCells)
)
)
width (* defaultHeight
GridScale
(vlax-variant-value
(vlax-get-property cell 'width)
)
)
height (* defaultHeight
GridScale
(vlax-variant-value
(vlax-get-property cell 'height)
)
)
text (vlax-variant-value (vlax-get-property cell 'text))
)
(if (and (/= text "")
(not (equal width 0 0.01))
)
(progn
(setq
font (vlax-get-property range 'font)
HorizontalAlignment
(vlax-variant-value
(vlax-get-property
Cell
'HorizontalAlignment
)
)
HorizontalAlignment
(cond ((= HorizontalAlignment -4152) 2) ;_ 右
((= HorizontalAlignment -4108) 1) ;_ 中
(t 0) ;_ 左
)
VerticalAlignment
(vlax-variant-value
(vlax-get-property
Cell
'VerticalAlignment
)
)
VerticalAlignment
(cond ((= VerticalAlignment -4160) 0) ;_ 上
((= VerticalAlignment -4108) 1) ;_ 中
(t 2) ;_ 下
)
DXF71 (nth VerticalAlignment
(nth HorizontalAlignment dxf71data)
)
DXF62 (vlxls-color-eci->aci
(vlax-variant-value
(vlax-get-property Font 'colorIndex)
)
)
DXF420 (vlxls-color-eci->truecolor
(vlax-variant-value
(vlax-get-property Font 'colorIndex)
)
)
)
;;计算Range的字体 RangeFont i ii char cfont charFont caption f TextVerFlag
(setq RangeFont
(mapcar
'(lambda (x) (cons x (VLXLS-GET-PROPERTY font x)))
'("NAME" "SIZE"
"COLORINDEX" "BOLD"
"ITALIC" "SUBSCRIPT"
"SUPERSCRIPT" "UNDERLINE"
)
)
)
(setq DXF7 (cdr (assoc "NAME" RangeFont)))
(if (null dxf7)
(setq DXF7 StandardFont)
)
;;字体
(setq textFont (strcat "{\\f" DXF7 "|b0|i0|c134|p0;"))
(setq Dxf40 (cdr (assoc "SIZE" RangeFont)))
(if (null DXF40)
(setq DXF40 StandardFontSize)
)
;;字大小
(setq textFont (strcat textFont
"\\H"
(rtos DXF40 2 1)
"x;"
)
)
;;加粗
(if (equal :vlax-true (cdr (assoc "BOLD" RangeFont)))
(setq textfont (strcat textFont "\\W1.2;"))
)
;;倾斜
(if
(equal :vlax-true (cdr (assoc "ITALIC" RangeFont)))
(setq textfont (strcat textFont "\\Q18;"))
)
;;下划线
(if (= 2 (cdr (assoc "UNDERLINE" RangeFont)))
(setq textfont (strcat textFont "\\L"))
)
;;上标 "SUPERSCRIPT"
;;下标 "SUBSCRIPT"
;;文字是否竖向
(setq TextVerFlag
(= (GXL-CATCHAPPLY
VLXLS-GET-PROPERTY
(list range "Orientation")
)
-4166
)
)
(if TextVerFlag
(progn
(setq text (gxl-str->singleonly text))
(setq tmp (car text)
text (cdr text)
)
(foreach a text (setq tmp (strcat tmp "\\P" a)))
(setq text tmp)
)
)
;;逐字取样式
;;(setq textFont (strcat textFont (GetRangeTextStyle RANGE RANGEFONT text) "}"))
(setq text (strcat textFont text "}"))
)
)
(cond ((null OldRow) (setq OldRow Row))
((/= OldRow Row) ;_ 换行
(if *pageSetUp*
(progn
(if nil ;(member row HPageBreaks) ;_ 换页
(progn
(setq OldRow Row
StartPoint
(polar StartPoint
(* 1.5 pi)
oldheight
)
)
(if *Merge*
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10
StartPoint
)
(cons
11
(setq p0
(polar
StartPoint
0
(* defaultHeight
GridScale
Totalwide
)
)
)
)
'(210 0.0 0.0 1.0)
)
)
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 RightTopPt)
(cons 11 p0)
'(210 0.0 0.0 1.0)
)
)
)
)
(setq StartPoint (polar StartPoint
(* 1.5 pi)
PageMargin
)
Curpt StartPoint
RightTopPt (polar StartPoint
0
(* defaultHeight
GridScale
Totalwide
)
)
) ;_ 移动页间距
)
(setq OldRow Row
StartPoint (polar StartPoint
(* 1.5 pi)
oldheight
)
Curpt StartPoint
)
)
)
(setq OldRow Row
StartPoint (polar StartPoint (* 1.5 pi) oldheight)
Curpt StartPoint
)
)
)
)
(setq oldheight height)
(if (not (equal width 0 0.01))
(progn
(if Mergep
(progn
(setq mergeId (mapcar 'vlxls-rangeid
(vlxls-cellid
(vlxls-range-getid range)
)
)
width1 (* defaultHeight
GridScale
(VLXLS-GET-PROPERTY
range
"MergeArea.width"
)
)
height1 (* defaultHeight
GridScale
(VLXLS-GET-PROPERTY
range
"MergeArea.height"
)
)
)
)
(setq width1 width
height1 height
)
)
(if
(or (not Mergep)
(and Mergep (equal (car mergeId) (list col row)))
)
(progn
(setq p0 (polar Curpt (* 1.5 pi) height1)
p1 Curpt
p2 (polar Curpt 0 width1)
p3 (polar p2 (* 1.5 pi) height1)
) ;_ 框的四个角点左下、左上、右上、右下
(if *Merge*
(progn
(if Horline
(progn
(if (equal p1 (gxl-dxf HorLine 11) 1e-3)
(gxl-ch_ent HorLine 11 p2) ;_ 更新水平直线末端点
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p2)
'(210 0.0 0.0 1.0)
)
)
(setq Horline (entlast))
)
)
)
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p2)
'(210 0.0 0.0 1.0)
)
)
(setq Horline (entlast))
)
)
(if VerLines
(progn
(if (not
(vl-some
(Function
(lambda (Line)
(if (equal p1
(gxl-dxf Line 11)
1e-3
)
(gxl-ch_ent Line 11 p0) ;_ 更新垂直直线末端点
)
)
)
VerLines
)
)
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p0)
'(210 0.0 0.0 1.0)
)
)
(setq
VerLines (cons (entlast) VerLines)
)
)
)
)
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p0)
'(210 0.0 0.0 1.0)
)
)
(setq VerLines (cons (entlast) VerLines))
)
)
)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 BLayer)
(cons 62 *defaultColor*)
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(43 . 0.0)
'(38 . 0.0)
'(39 . 0.0)
(cons 10 p0)
(cons 10 p1)
(cons 10 p2)
(cons 10 p3)
'(210 0.0 0.0 1.0)
)
)
)
(if *CellColor* ;_ 绘制背景颜色
(progn
(if (/= -4142
(setq Interiorcolor
(VLXLS-GET-PROPERTY
range
"Interior.ColorIndex"
)
)
)
(progn
(setq Interiorcolor (VLXLS-COLOR-ECI->ACI
Interiorcolor
)
Interiortruecolor (VLXLS-COLOR-ECI->TRUECOLOR
Interiorcolor
)
)
(entmake
(vl-remove
nil
(list
'(0 . "SOLID")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 BLayer)
(cons 62 Interiorcolor)
;|(if (not (or (= 256 Interiorcolor)
(= 0 Interiortruecolor)
)
)
(cons 420 Interiortruecolor)
)|;
'(100 . "AcDbTrace")
(cons 10 p0)
(cons 11 p1)
(cons 12 p3)
(cons 13 p2)
'(210 0.0 0.0 1.0)
)
)
)
;(setq SSSolid (cons (entlast) SSSolid))
)
)
)
)
(if (/= "" text)
(progn
(setq textpt
(nth (1- DXF71) (Get9JustPts p0 p2))
)
(cond ((= 0 HorizontalAlignment) ;_ 左对齐
(setq
textpt (polar textpt 0 (* height 0.1))
)
)
((= 2 HorizontalAlignment) ;_ 右对齐
(setq
textpt (polar textpt pi (* height 0.1))
)
)
)
(cond
((= 0 VerticalAlignment) ;_ 上对齐
(setq textpt (polar textpt
(* 1.5 pi)
(* height 0.1)
)
)
)
((= 2 VerticalAlignment) ;_ 下对齐
(setq textpt (polar textpt
(* 0.5 pi)
(* height 0.1)
)
)
)
)
(entmake
(vl-remove
nil
(list
(cons 0 "MTEXT")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 TLayer)
(if *AnnoColor*
(cons 62 dxf62)
(cons 62 *defaultColor*)
)
'(100 . "AcDbMText")
(cons 10 textpt)
(cons 40 defaultHeight)
(cons 41 width1)
;(cons 50 0)
;;'(46 . 0.0)
(cons 71 DXF71)
(cons 72 5)
(cons 1 text)
(cons 7 "Standard")
'(210 0.0 0.0 1.0)
'(11 1.0 0.0 0.0)
'(50 . 0.0)
'(73 . 1)
)
)
)
)
)
)
)
(setq Curpt (polar Curpt 0 width))
)
)
) ;_ vlax-for
)
(setq startpoint (polar startpoint (* 1.5 pi) oldheight) curpt startpoint)
)
)
)
;;Range的text逐字取样式
(defun GetRangeTextStyle (RANGE RANGEFONT text / I
II CHAR CFONT CAPTION
CHARFONT F TEXTFONT
)
(if (equal :vlax-false (vlxls-get-property range "HasFormula"))
(progn
(setq i 0
ii (GXL-CATCHAPPLY
vlax-get-property
(list (vlax-get-property range 'characters) 'count)
)
)
(if ii
(repeat ii
(setq char (vlax-get-property
range
'characters
(setq i (1+ i))
1
)
cfont (vlax-get-property char 'font)
caption (VLXLS-GET-PROPERTY char "caption")
)
(setq charFont
(mapcar
'(lambda (x) (cons x (VLXLS-GET-PROPERTY cfont x)))
'("NAME" "SIZE" "COLORINDEX"
"BOLD" "ITALIC" "SUBSCRIPT"
"SUPERSCRIPT" "UNDERLINE"
)
)
)
(if (and (setq f (cdr (assoc "NAME" charFont)))
(/= f (cdr (assoc "NAME" RangeFont)))
)
(setq textfont (strcat "\\f" f "|b0|i0|c134|p0;"))
) ;_ 字体
(if (and (setq f (cdr (assoc "SIZE" charFont)))
(equal f (cdr (assoc "SIZE" RangeFont)) 0.01)
)
(setq textfont (strcat textFont "\\H" (rtos f 2 1) "x;"))
) ;_ 大小
(if (and (setq f (cdr (assoc "COLORINDEX" charFont)))
(equal f (cdr (assoc "COLORINDEX" RangeFont)) 0.01)
)
(setq textfont (strcat textFont "\\C" (itoa (vlxls-color-eci->aci f)) ";"))
) ;_ 颜色
;;加粗
(if (not (equal (setq f (cdr (assoc "BOLD" charFont)))
(cdr (assoc "BOLD" RangeFont))
)
)
(if (equal :vlax-true f)
(setq textfont (strcat textFont "\\W1.2;"))
(setq textfont (strcat textFont "\\W0.83;"))
)
)
;;倾斜
(if
(not (equal (setq f (cdr (assoc "ITALIC" charFont)))
(cdr (assoc "ITALIC" RangeFont))
)
)
(if (equal :vlax-true f)
(setq textfont (strcat textFont "\\Q18;"))
(setq textfont (strcat textFont "\\Q0;"))
)
)
;;上标
(if (equal :vlax-true (cdr (assoc "SUPERSCRIPT" RangeFont)))
(setq textFont (strcat textFont "\\H0.33x;\\A2;"))
)
;;下标
(if (equal :vlax-true (cdr (assoc "SUPERSCRIPT" RangeFont)))
(setq textFont (strcat textFont "\\H0.33x;\\A0;"))
)
;;下划线
(if
(not (equal (setq f (cdr (assoc "UNDERLINE" charFont)))
(cdr (assoc "UNDERLINE" RangeFont))
)
)
(if (= 2 f)
(setq textfont (strcat textFont "\\L"))
(setq textfont (strcat textFont "\\l"))
)
)
(setq textFont (strcat textFont caption))
(if (and TextVerFlag (/= i ii)) (setq textFont (strcat textFont "\\P")))
)
(setq textfont (strcat textfont text))
)
)
(setq textfont (strcat textfont text))
)
)
;;绘制页眉页脚 PageSetUp vla对象 pt 表格基点 Flag = t 页眉 = nil 页脚
(defun DrawPageSetUp (PAGESETUP PT FLAG /
GETFONTSTR LEFTHEADER CENTERHEADER
RIGHTHEADER D TEXTPT
LeftFooter CenterFooter RightFooter
)
; PageSetup:特性值:
; AlignMarginsHeaderFooter = 0
; Application (RO) = #<VLA-OBJECT _Application 0cdd3e9c>
; BlackAndWhite = 0
; BottomMargin = 70.8661
; CenterFooter = "&\"幼圆,加粗\"&16页脚中&N第&P页"
; CenterFooterPicture (RO) = #<VLA-OBJECT Graphic 1821ca84>
; CenterHeader = "页眉中"
; CenterHeaderPicture (RO) = #<VLA-OBJECT Graphic 1821d5c4>
; CenterHorizontally = 0
; CenterVertically = 0
; Creator (RO) = 1480803660
; DifferentFirstPageHeaderFooter = 0
; Draft = 0
; EvenPage (RO) = #<VLA-OBJECT Page 1821c454>
; FirstPage (RO) = #<VLA-OBJECT Page 1821ddec>
; FirstPageNumber = -4105
; FitToPagesTall = 1
; FitToPagesWide = 1
; FooterMargin = 36.8504
; HeaderMargin = 36.8504
; LeftFooter = "&\"楷体,常规\"&14页&\"楷体,加粗倾斜\"脚&\"楷体,常规\"左"
; LeftFooterPicture (RO) = #<VLA-OBJECT Graphic 1821df54>
; LeftHeader = "页眉左"
; LeftHeaderPicture (RO) = #<VLA-OBJECT Graphic 1821c724>
; LeftMargin = 53.8583
; OddAndEvenPagesHeaderFooter = 0
; Order = 1.0
; Orientation = 1.0
; Pages (RO) = #<VLA-OBJECT Pages 1821c0ac>
; PaperSize = 9.0
; Parent (RO) = #<VLA-OBJECT _Worksheet 1821dad4>
; PrintArea = "$A$1:$N$105"
; PrintComments = -4142
; PrintErrors = 0
; PrintGridlines = 0
; PrintHeadings = 0
; PrintNotes = 0
; PrintQuality = ...不显示带索引的内容...
; PrintTitleColumns = ""
; PrintTitleRows = "$1:$3"
; RightFooter = "&\"楷体,加粗\"&KFF0000页脚右"
; RightFooterPicture (RO) = #<VLA-OBJECT Graphic 1821dccc>
; RightHeader = "页眉右"
; RightHeaderPicture (RO) = #<VLA-OBJECT Graphic 1821c8d4>
; RightMargin = 53.8583
; ScaleWithDocHeaderFooter = -1
; TopMargin = 70.8661
; Zoom = 100
(defun GetFontstr (str / size fontname fontstr color)
;;用正则表达式删除格式文字
;;"&\"幼圆,加粗\"&16页脚&\"楷体,加粗倾斜\"&12&KFFFF00中共&\"幼圆,加粗\"&16&K000000&N页第&P页"
(setq fontname
(gxl-RegExSearch
str
"\&\\\".+?\""
"im"
)
)
(if fontname
(progn
(setq fontname (caddar fontname))
(setq fontname
(gxl-RegExRePlace
fontname
""
"&\\\"|\\\""
"mg"
)
)
(setq fontname (GXL-STRPARSE fontname ","))
(setq fontstr (strcat "{\\f" (car fontname) "|b0|i0|c134|p0;"))
(if (cadr fontname)
(progn
(if (WCMATCH (cadr fontname) "*加粗*")
(setq fontstr (strcat fontstr "\\W1.2;"))
)
(if (WCMATCH (cadr fontname) "*倾斜*")
(setq fontstr (strcat fontstr "\\Q18;"))
)
)
)
)
(setq fontstr (strcat "{\\f" standardFont "|b0|i0|c134|p0;" "\\H" (rtos StandardFontSize 2 1) "x;"))
)
(setq size
(gxl-RegExSearch
str
"&\\d{1,2}"
"im"
)
)
(if size
(progn
(setq size (caddar size))
(setq size
(gxl-RegExRePlace
size
""
"&"
"mg"
)
)
(setq fontstr (strcat fontstr "\\H" size "x;"))
)
)
(if *AnnoColor*
(progn
(setq color
(gxl-RegExSearch
str
"\&K[A-Za-z0-9]{6}"
"im"
)
)
(if color
(progn
(setq color (strcat "#" (substr (caddar color) 3)))
(setq color (gxl-Hex->ACI color))
(setq fontstr (strcat fontstr "\\C" (itoa color) ";"))
)
)
)
(setq fontstr (strcat fontstr "\\C" (itoa *defaultColor*) ";"))
)
(setq str
(gxl-RegExRePlace
str
""
"&\\d{1,2}|\&\\\".+?\"|\&K[A-Za-z0-9]{6}"
"mg"
)
)
(setq str
(gxl-RegExRePlace
str
(itoa TotalPage)
"&N"
"mg"
)
)
(setq str
(gxl-RegExRePlace
str
(itoa Page)
"&P"
"mg"
)
)
;(strcat "{\\f" standardFont "|b0|i0|c134|p0;" "\\H" (rtos StandardFontSize 2 1) "x;" str"}")
(strcat fontstr str "}")
)
(cond
(flag ;_ 页眉
(setq LeftHeader (vlax-get-property PageSetUp 'LeftHeader)
CenterHeader (vlax-get-property PageSetUp 'CenterHeader)
RightHeader (vlax-get-property PageSetUp 'RightHeader)
)
(if (/= "" LeftHeader)
(progn
(setq d (* defaultHeight GridScale (vlax-get-property PageSetUp 'HeaderMargin)))
(setq textpt (polar pt (* pi 0.5) d))
(setq LeftHeader (GetFontstr LeftHeader))
(entmake
(vl-remove
nil
(list
(cons 0 "MTEXT")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 TLayer)
(cons 62 *defaultColor*)
'(100 . "AcDbMText")
(cons 10 textpt)
(cons 40 defaultHeight)
(cons 41 (* 0.333 totalwide GridScale defaultHeight))
(cons 71 4)
(cons 72 5)
(cons 1 LeftHeader)
(cons 7 "Standard")
'(210 0.0 0.0 1.0)
'(11 1.0 0.0 0.0)
'(50 . 0.0)
'(73 . 1)
)
)
)
)
)
(if (/= "" CenterHeader)
(progn
(setq d (* defaultHeight GridScale (vlax-get-property PageSetUp 'HeaderMargin)))
(setq textpt (polar (polar pt (* pi 0.5) d) 0 (* 0.5 totalwide GridScale defaultHeight)))
(setq CenterHeader (GetFontstr CenterHeader))
(entmake
(vl-remove
nil
(list
(cons 0 "MTEXT")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 TLayer)
(cons 62 *defaultColor*)
'(100 . "AcDbMText")
(cons 10 textpt)
(cons 40 defaultHeight)
(cons 41 (* 0.333 totalwide GridScale defaultHeight))
(cons 71 5)
(cons 72 5)
(cons 1 CenterHeader)
(cons 7 "Standard")
'(210 0.0 0.0 1.0)
'(11 1.0 0.0 0.0)
'(50 . 0.0)
'(73 . 1)
)
)
)
)
)
(if (/= "" RightHeader)
(progn
(setq d (* defaultHeight GridScale (vlax-get-property PageSetUp 'HeaderMargin)))
(setq textpt (polar (polar pt (* pi 0.5) d) 0 (* totalwide GridScale defaultHeight)))
(setq RightHeader (GetFontstr RightHeader))
(entmake
(vl-remove
nil
(list
(cons 0 "MTEXT")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 TLayer)
(cons 62 *defaultColor*)
'(100 . "AcDbMText")
(cons 10 textpt)
(cons 40 defaultHeight)
(cons 41 (* 0.333 totalwide GridScale defaultHeight))
(cons 71 6)
(cons 72 5)
(cons 1 RightHeader)
(cons 7 "Standard")
'(210 0.0 0.0 1.0)
'(11 1.0 0.0 0.0)
'(50 . 0.0)
'(73 . 1)
)
)
)
)
)
)
(t ;_ 页脚
(setq LeftFooter (vlax-get-property PageSetUp 'LeftFooter)
CenterFooter (vlax-get-property PageSetUp 'CenterFooter)
RightFooter (vlax-get-property PageSetUp 'RightFooter)
d (* defaultHeight GridScale (vlax-get-property PageSetUp 'FooterMargin))
)
(if (/= "" LeftFooter)
(progn
(setq textpt (polar pt (* pi 1.5) d))
(setq LeftFooter (GetFontstr LeftFooter))
(entmake
(vl-remove
nil
(list
(cons 0 "MTEXT")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 TLayer)
(cons 62 *defaultColor*)
'(100 . "AcDbMText")
(cons 10 textpt)
(cons 40 defaultHeight)
(cons 41 (* 0.333 totalwide GridScale defaultHeight))
(cons 71 4)
(cons 72 5)
(cons 1 LeftFooter)
(cons 7 "Standard")
'(210 0.0 0.0 1.0)
'(11 1.0 0.0 0.0)
'(50 . 0.0)
'(73 . 1)
)
)
)
)
)
(if (/= "" CenterFooter)
(progn
(setq textpt (polar (polar pt (* pi 1.5) d) 0 (* 0.5 totalwide GridScale defaultHeight)))
(setq CenterFooter (GetFontstr CenterFooter))
(entmake
(vl-remove
nil
(list
(cons 0 "MTEXT")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 TLayer)
(cons 62 *defaultColor*)
'(100 . "AcDbMText")
(cons 10 textpt)
(cons 40 defaultHeight)
(cons 41 (* 0.333 totalwide GridScale defaultHeight))
(cons 71 5)
(cons 72 5)
(cons 1 CenterFooter)
(cons 7 "Standard")
'(210 0.0 0.0 1.0)
'(11 1.0 0.0 0.0)
'(50 . 0.0)
'(73 . 1)
)
)
)
)
)
(if (/= "" RightFooter)
(progn
(setq textpt (polar (polar pt (* pi 1.5) d) 0 (* totalwide GridScale defaultHeight)))
(setq RightFooter (GetFontstr RightFooter))
(entmake
(vl-remove
nil
(list
(cons 0 "MTEXT")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 TLayer)
(cons 62 *defaultColor*)
'(100 . "AcDbMText")
(cons 10 textpt)
(cons 40 defaultHeight)
(cons 41 (* 0.333 totalwide GridScale defaultHeight))
(cons 71 6)
(cons 72 5)
(cons 1 RightFooter)
(cons 7 "Standard")
'(210 0.0 0.0 1.0)
'(11 1.0 0.0 0.0)
'(50 . 0.0)
'(73 . 1)
)
)
)
)
)
)
)
)
;;主程序开始
(setierr)
(setq Layers (gxl-table "layer"))
;;对话框开始
;;
;;(vl-file-delete (findfile "xl2cad.dcl"))
(setq dclcode (load_dialog (mkTmpDcl "xl2cad")))
(new_dialog "xl2cad" dclcode)
(start_xl2x)
(setq ecode (start_dialog))
(cond
((= 1 ecode)
(if *CellColor* (setvar "REGENMODE" 0))
(vlxls-app-init)
(or *xlapp*
(if (VL-CATCH-ALL-ERROR-P
(setq *xlApp* (VL-CATCH-ALL-APPLY
'vlax-get-or-create-object
'("Excel.Application")
)
)
)
(exit)
)
)
(if (equal :vlax-false (vlax-get-property *XLAPP* 'visible))
(vla-put-visible *xlApp* 1)
)
(if (= "User" *DrawRange*)
(vlax-put-property *XLAPP* 'Visible 1)
)
(setq workbooks (vlax-get-property *xlApp* 'workbooks))
(if (= 0 (vla-get-Count workbooks))
(setq workbook (vlax-invoke workbooks 'add))
(setq workbook (vlax-get-property *xlApp* 'activeworkbook))
)
(setq sheet (vlax-get-property *xlApp* 'activesheet))
(setq UsedRange (vlax-get-property sheet 'UsedRange)
col (vlax-get-property
(vlax-get-property UsedRange 'columns)
'count
)
row (vlax-get-property
(vlax-get-property UsedRange 'rows)
'count
)
)
(cond
((= "Used" *DrawRange*)
(setq Cells (vlax-get-property UsedRange 'Cells))
;(setq PrintArea (VLXLS-GET-PROPERTY *xlApp* "Activesheet.PageSetup.PrintArea"))
)
((= "User" *DrawRange*)
(alert "请在表格中选择数据后按确定键！")
(setq Selection (vlax-get-property *xlApp* 'Selection)
Cells (vlax-get-property Selection 'Cells)
)
;(setq PrintArea (VLXLS-GET-PROPERTY *xlApp* "Activesheet.PageSetup.PrintArea"))
)
((= "PrintArea" *DrawRange*)
(setq PrintArea (VLXLS-GET-PROPERTY *xlApp* "Activesheet.PageSetup.PrintArea"))
(if (/= "" PrintArea)
(setq Cells (vlax-get-property
(vlax-get-property *xlApp* 'range PrintArea)
'Cells
)
)
(progn
(alert "当前活动表格没有可打印的页面！\n\n请重新设置页面！程序将退出！")
(exit)
)
)
)
)
(if (= 1 (vlax-get-property cells 'count))
(progn
(alert "Excel表格只有一行一列，程序将退出！")
(exit)
)
)
(if *pageSetUp*
(progn
(setq HPageBreaks nil)
(GXL-CATCHAPPLY
(lambda ()
(vlax-for a (VLXLS-GET-PROPERTY
*xlapp*
"activesheet.HPageBreaks"
)
(setq HPageBreaks
(cons (VLXLS-GET-PROPERTY a "Location.row")
HPageBreaks
)
)
)
)
nil
)
(setq HPageBreaks (reverse HPageBreaks)) ;_ 储存分页的Row位置
)
)
(initget 7)
(setq StartPoint (getpoint "\n放置位置:"))
(setq StartPoint (trans StartPoint 1 0)
BasePoint StartPoint)
(setq curpt StartPoint
OldRow nil
to (vlax-get-property cells 'count)
)
;|71
附着点：
1 = 左上；2 = 中上；3 = 右上
4 = 左中；5 = 正中；6 = 右中
7 = 左下；8 = 中下；9 = 右下
|;
(setq dxf71data '((1 4 7) (2 5 8) (3 6 9)))
(GXL-SYS-PROGRESS-INIT "" to)
(setq StandardFont (vlax-get-property *xlApp* 'StandardFont))
(setq StandardFontSize (vlax-get-property *XLAPP* 'StandardFontSize))
(setq defaultHeight (/ *THeight* StandardFontSize)) ;_ 默认高度
(setq GridScale 1.941747572815534)
(setq totalwide (vlax-variant-value (vlax-get-property cells 'Width))
totalheight (vlax-variant-value (vlax-get-property cells 'height))
)
(setq pagesetup (VLXLS-GET-PROPERTY *xlapp* "activesheet.pagesetup"))
(if (not *KeepTHeight*)
(progn
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(67 . 0)
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(43 . 0.0)
'(38 . 0.0)
'(39 . 0.0)
(cons 10 StartPoint)
(cons 10
(setq p0 (polar StartPoint
0
(* totalwide GridScale defaultHeight)
)
)
)
(cons 10
(polar p0
(* 1.5 pi)
(* totalheight GridScale defaultHeight)
)
)
(cons 10
(polar StartPoint
(* 1.5 pi)
(* totalheight GridScale defaultHeight)
)
)
'(210 0.0 0.0 1.0)
)
)
(setq endent (entlast))
(setvar 'ORTHOMODE 1)
(initget 6)
(setq p0 (getdist (trans StartPoint 0 1) (strcat "\n输入表格宽度<" (rtos (* totalwide GridScale defaultHeight) 2 2) ">:")))
(if (null p0) (setq p0 (* totalwide GridScale defaultHeight)))
(entdel endent)
(setq scale (/ p0 (* totalwide GridScale defaultHeight)))
(setq defaultHeight (* defaultHeight scale))
)
)
(setq endent (entlast) )
(setq page 1 TotalPage (1+ (length HPageBreaks)))
(if *pageSetUp*
(progn
(setq PageMargin ;_ 计算页间距
(* defaultHeight
GridScale
(+
(VLXLS-GET-PROPERTY
*xlapp*
"activesheet.pagesetup.BottomMargin"
)
(VLXLS-GET-PROPERTY
*xlapp*
"activesheet.pagesetup.FooterMargin"
)
(VLXLS-GET-PROPERTY
*xlapp*
"activesheet.pagesetup.TopMargin"
)
(VLXLS-GET-PROPERTY
*xlapp*
"activesheet.pagesetup.HeaderMargin"
)
)
)
)
(setq RightTopPt ;_ 每页右上角点
(polar StartPoint
0
(* defaultHeight GridScale Totalwide)
)
)
;;输出页眉
(if *pageSetUp* (DrawPageSetUp pagesetup StartPoint t))
)
)
;;输出表头
(if *pageSetUp* (PrintTitleRows cells))
(if (setq TitleRows ;_ 存储表头的行数
(VLXLS-GET-PROPERTY
*XLAPP*
"ActiveSheet.PageSetup.PrintTitleRows"
)
)
(progn
(setq TitleRows
(mapcar
'atoi
(vl-remove ""
(GXL-STRPARSEBYLST TitleRows '(":" "$"))
)
)
tmp (car TitleRows)
tmp1 (cadr TitleRows)
TitleRows nil
)
(if tmp1
(while (<= tmp tmp1)
(setq TitleRows (cons tmp TitleRows)
tmp (1+ tmp)
)
)
(setq TitleRows (list tmp))
)
(setq TitleRows (reverse TitleRows))
)
)
;;逐行逐列绘制表格
(vlax-for cell cells
(gxl-Sys-Progress to -1)
(setq col (vlax-get-property cell 'column)
row (vlax-get-property cell 'row)
range (msxlp-get-range *xlApp* (VLXLS-RANGEID (list col row)))
Mergep (equal :vlax-true (vlax-variant-value (vlax-get-property cell 'MergeCells)))
width (* defaultHeight GridScale (vlax-variant-value (vlax-get-property cell 'width)))
height (* defaultHeight GridScale (vlax-variant-value (vlax-get-property cell 'height)))
text (vlax-variant-value (vlax-get-property cell 'text))
)
(cond
((and *pageSetUp* (member row TitleRows))) ;_ 忽略打印表头位置的表格
(t
(if (and (/= text "")
(not (equal width 0 0.01))
)
(progn
(setq
font (vlax-get-property range 'font)
HorizontalAlignment
(vlax-variant-value
(vlax-get-property
Cell
'HorizontalAlignment
)
)
HorizontalAlignment
(cond ((= HorizontalAlignment -4152) 2) ;_ 右
((= HorizontalAlignment -4108) 1) ;_ 中
(t 0) ;_ 左
)
VerticalAlignment
(vlax-variant-value
(vlax-get-property
Cell
'VerticalAlignment
)
)
VerticalAlignment
(cond ((= VerticalAlignment -4160) 0) ;_ 上
((= VerticalAlignment -4108) 1) ;_ 中
(t 2) ;_ 下
)
DXF71 (nth VerticalAlignment
(nth HorizontalAlignment dxf71data)
)
DXF62 (vlxls-color-eci->aci
(vlax-variant-value
(vlax-get-property Font 'colorIndex)
)
)
DXF420 (vlxls-color-eci->truecolor
(vlax-variant-value
(vlax-get-property Font 'colorIndex)
)
)
)
;;计算Range的字体 RangeFont i ii char cfont charFont caption f TextVerFlag
(setq RangeFont
(mapcar
'(lambda (x) (cons x (VLXLS-GET-PROPERTY font x)))
'("NAME" "SIZE" "COLORINDEX"
"BOLD" "ITALIC" "SUBSCRIPT"
"SUPERSCRIPT" "UNDERLINE"
)
)
)
(setq DXF7 (cdr (assoc "NAME" RangeFont)))
(if (null dxf7) (setq DXF7 StandardFont))
;;字体
(setq textFont (strcat "{\\f" DXF7 "|b0|i0|c134|p0;"))
(setq Dxf40 (cdr (assoc "SIZE" RangeFont)))
(if (null DXF40) (setq DXF40 StandardFontSize))
;;字大小
(setq textFont (strcat textFont "\\H" (rtos DXF40 2 1) "x;"))
;;加粗
(if (equal :vlax-true (cdr (assoc "BOLD" RangeFont)))
(setq textfont (strcat textFont "\\W1.2;"))
)
;;倾斜
(if (equal :vlax-true (cdr (assoc "ITALIC" RangeFont)))
(setq textfont (strcat textFont "\\Q18;"))
)
;;下划线
(if (= 2 (cdr (assoc "UNDERLINE" RangeFont)))
(setq textfont (strcat textFont "\\L"))
)
;;上标 "SUPERSCRIPT"
;;下标 "SUBSCRIPT"
;;文字是否竖向
(setq TextVerFlag
(= (GXL-CATCHAPPLY
VLXLS-GET-PROPERTY
(list range "Orientation")
)
-4166
)
)
(if TextVerFlag
(progn
(setq text (gxl-str->singleonly text))
(setq tmp (car text)
text (cdr text)
)
(foreach a text (setq tmp (strcat tmp "\\P" a)))
(setq text tmp)
)
)
;;逐字取样式
;;(setq textFont (strcat textFont (GetRangeTextStyle RANGE RANGEFONT text) "}"))
(setq text (strcat textFont text "}"))
)
)
(cond ((null OldRow) (setq OldRow Row))
((/= OldRow Row) ;_ 换行
(if *pageSetUp*
(progn
(if (member row HPageBreaks) ;_ 换页
(progn
(setq OldRow Row
StartPoint (polar StartPoint
(* 1.5 pi)
oldheight
)
)
(if *Merge*
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10
StartPoint
)
(cons
11
(setq p0
(polar
StartPoint
0
(* defaultHeight GridScale Totalwide)
)
)
)
'(210 0.0 0.0 1.0)
)
)
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 RightTopPt)
(cons 11 p0)
'(210 0.0 0.0 1.0)
)
)
)
)
;;输出页脚代吗
(if *pageSetUp* (DrawPageSetUp pagesetup StartPoint nil))
;;分组或分块
(cond
((= 1 *Oprate*)
(setq ss (GXL-SEL-ENTNEXTALL endent))
(if *CellColor*
(progn
(command "_select" ss "")
(setq s1 (ssget "_p" '((0 . "solid"))))
(if s1
(gxl-MovetoBottom s1)
)
)
)
(gxl-AX:AddUnNameGroup ss)
(setq endent (entlast))
)
((= 2 *Oprate*)
(setq ss (GXL-SEL-ENTNEXTALL endent))
(if *CellColor*
(progn
(command "_select" ss "")
(setq s1 (ssget "_p" '((0 . "solid"))))
(if s1
(gxl-MovetoBottom s1)
)
)
)
(gxl-BLK-UnBlockBase ss 4)
(setq endent (entlast))
)
)
(setq StartPoint (polar StartPoint (* 1.5 pi) PageMargin)
Curpt StartPoint
RightTopPt (polar StartPoint 0 (* defaultHeight GridScale Totalwide))
) ;_ 移动页间距
(setq page (1+ page))
;;输出页眉代吗
(if *pageSetUp* (DrawPageSetUp pagesetup StartPoint t))
;;输出表头
(if *pageSetUp* (PrintTitleRows cells))
)
(setq OldRow Row
StartPoint (polar StartPoint (* 1.5 pi) oldheight)
Curpt StartPoint
)
)
)
(setq OldRow Row
StartPoint (polar StartPoint (* 1.5 pi) oldheight)
Curpt StartPoint
)
)
)
)
(setq oldheight height)
(if (not (equal width 0 0.01))
(progn
(if Mergep
(progn
(setq mergeId (mapcar 'vlxls-rangeid
(vlxls-cellid (vlxls-range-getid range))
)
width1 (* defaultHeight GridScale (VLXLS-GET-PROPERTY range "MergeArea.width"))
height1 (* defaultHeight GridScale (VLXLS-GET-PROPERTY range "MergeArea.height"))
)
)
(setq width1 width height1 height)
)
(if (or (not Mergep)
(and Mergep (equal (car mergeId) (list col row)))
)
(progn
(setq p0 (polar Curpt (* 1.5 pi) height1)
p1 Curpt
p2 (polar Curpt 0 width1)
p3 (polar p2 (* 1.5 pi) height1)
) ;_ 框的四个角点左下、左上、右上、右下
(if *Merge*
(progn
(if Horline
(progn
(if (equal p1 (gxl-dxf HorLine 11) 1e-3)
(gxl-ch_ent HorLine 11 p2) ;_ 更新水平直线末端点
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p2)
'(210 0.0 0.0 1.0)
)
)
(setq Horline (entlast))
)
)
)
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p2)
'(210 0.0 0.0 1.0)
)
)
(setq Horline (entlast))
)
)
(if VerLines
(progn
(if (not
(vl-some
(Function
(lambda (Line)
(if (equal p1 (gxl-dxf Line 11) 1e-3)
(gxl-ch_ent Line 11 p0) ;_ 更新垂直直线末端点
)
)
)
VerLines
)
)
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p0)
'(210 0.0 0.0 1.0)
)
)
(setq VerLines (cons (entlast) VerLines))
)
)
)
(progn
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 p1)
(cons 11 p0)
'(210 0.0 0.0 1.0)
)
)
(setq VerLines (cons (entlast) VerLines))
)
)
)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 BLayer)
(cons 62 *defaultColor*)
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
'(43 . 0.0)
'(38 . 0.0)
'(39 . 0.0)
(cons 10 p0)
(cons 10 p1)
(cons 10 p2)
(cons 10 p3)
'(210 0.0 0.0 1.0)
)
)
)
(if *CellColor* ;_ 绘制背景颜色
(progn
(if (/= -4142
(setq Interiorcolor
(VLXLS-GET-PROPERTY
range
"Interior.ColorIndex"
)
)
)
(progn
(setq Interiorcolor (VLXLS-COLOR-ECI->ACI Interiorcolor)
Interiortruecolor (VLXLS-COLOR-ECI->TRUECOLOR
Interiorcolor
)
)
(entmake
(vl-remove
nil
(list
'(0 . "SOLID")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 BLayer)
(cons 62 Interiorcolor)
;|(if (not (or (= 256 Interiorcolor)
(= 0 Interiortruecolor)
)
)
(cons 420 Interiortruecolor)
)|;
'(100 . "AcDbTrace")
(cons 10 p0)
(cons 11 p1)
(cons 12 p3)
(cons 13 p2)
'(210 0.0 0.0 1.0)
)
)
)
)
)
)
)
(if (/= "" text)
(progn
(setq textpt (nth (1- DXF71) (Get9JustPts p0 p2)))
(cond ((= 0 HorizontalAlignment) ;_ 左对齐
(setq textpt (polar textpt 0 (* height 0.1)))
)
((= 2 HorizontalAlignment) ;_ 右对齐
(setq textpt (polar textpt pi (* height 0.1)))
)
)
(cond
((= 0 VerticalAlignment) ;_ 上对齐
(setq textpt (polar textpt (* 1.5 pi) (* height 0.1)))
)
((= 2 VerticalAlignment) ;_ 下对齐
(setq textpt (polar textpt (* 0.5 pi) (* height 0.1)))
)
)
(entmake
(vl-remove
nil
(list
(cons 0 "MTEXT")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 TLayer)
(if *AnnoColor*
(cons 62 dxf62)
(cons 62 *defaultColor*)
)
;|(if (and *AnnoColor*
(not (or (= 256 dxf62) (= 0 dxf420)))
)
(cons 420 dxf420)
)|;
'(100 . "AcDbMText")
(cons 10 textpt)
(cons 40 defaultHeight)
(cons 41 width1)
;(cons 50 0)
;;'(46 . 0.0)
(cons 71 DXF71)
(cons 72 5)
(cons 1 text)
(cons 7 "Standard")
'(210 0.0 0.0 1.0)
'(11 1.0 0.0 0.0)
'(50 . 0.0)
'(73 . 1)
)
)
)
)
)
)
)
(setq Curpt (polar Curpt 0 width))
)
)
) ;_ t
) ;_ cond
)
(GXL-SYS-PROGRESS-DONE)
(if *Merge*
(progn
(if *pageSetUp*
(setq dd (* PageMargin (* (length HPAGEBREAKS))))
(setq dd 0)
)
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(if *pageSetUp*
(cons 10 (setq p0 RightTopPt))
(cons 10
(setq
p0 (polar BasePoint
0
(* defaultHeight GridScale Totalwide)
)
)
)
)
(cons 11 p3)
;(cons 11 (setq p1 (polar p0 (* 1.5 pi) (+ dd (* defaultHeight GridScale Totalheight)))))
'(210 0.0 0.0 1.0)
)
)
(entmake
(list
'(0 . "line")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 Blayer)
(cons 62 *defaultColor*)
'(100 . "AcDbLine")
(cons 10 (polar p3 pi (* defaultHeight GridScale Totalwide)))
(cons 11 p3)
'(210 0.0 0.0 1.0)
)
)
(setq p3 (polar p2 (* 1.5 pi) height1))
)
)
;;输出页脚代吗
(if *pageSetUp* (DrawPageSetUp pagesetup StartPoint nil))
(setq ss (GXL-SEL-ENTNEXTALL endent))
(if *CellColor*
(progn
(command "_select" ss "")
(setq s1 (ssget "_p" '((0 . "solid"))))
(if s1
(gxl-MovetoBottom s1)
)
)
)
(cond
((= 1 *Oprate*)
(gxl-AX:AddUnNameGroup ss)
)
((= 2 *Oprate*)
(gxl-BLK-UnBlockBase ss 4)
)
)
(vlax-release-object *xlapp*)
)
)
(reerr)
(princ)
)

(defun c:x2c (/        *XLAPP*              ACT_ANNOCOLOR ACT_BLAYER          ACT_CELLCOLOR                ACT_GETFILE   ACT_GROUP            ACT_KEEPTHEIGHT 
                ACT_MERGE     ACT_NONE            ACT_PAGESETUP ACT_PRINTAREA 
                ACT_TLAYER    ACT_UBLOCK    ACT_USED          ACT_USER 
                BASEPOINT     CELLS            COL                  CURPT 
                DCLCODE              DD            DEFAULTHEIGHT DRAWPAGESETUP 
                DXF40              DXF420            DXF62          DXF7 
                DXF71              DXF71DATA            ECODE          ENDENT 
                FONT              GET9JUSTPTS   GETRANGETEXTSTYLE 
                GRIDSCALE     HEIGHT            HEIGHT1 
                HORIZONTALALIGNMENT            HORLINE          HPAGEBREAKS 
                INTERIORCOLOR INTERIORTRUECOLOR                  LAYERS 
                MERGEID              MERGEP            MKTMPDCL          
                OLDHEIGHT     OLDROW            P0                  P1 
                P2              P3            PAGE          PAGEMARGIN 
                PAGESETUP     PRINTAREA            PRINTTITLEROWS 
                RANGE              RANGEFONT            RIGHTTOPPT          ROW 
                S1              SCALE            SELECTION          SHEET 
                SS              STANDARDFONT  STANDARDFONTSIZE 
                START_XL2X    STARTPOINT    TEXT          TEXTFONT 
                TEXTPT              TEXTVERFLAG   TMP                  TO 
                TOTALHEIGHT   TOTALPAGE            TOTALWIDE          USEDRANGE 
                VERLINES      VERTICALALIGNMENT                  WIDTH 
                WIDTH1              WORKBOOK            WORKBOOKS          ACT_RANGE 
                ACT_THEIGHT   BLAYER            CAPTION          CFONT 
                CHAR              CHARFONT            F 
                HORIZONTALALIGNMEN            I                  II 
                INTERIORCOLOR1                    KD                  SSTITLE 
                TLAYER              TMPPT            VERLINE          TITLEROWS 
                TMP              TMP1            *DRAWRANGE*          *CELLCOLOR* 
                *ANNOCOLOR*   *OPRATE*            *MERGE*          *THEIGHT* 
                *KEEPTHEIGHT* *PAGESETUP*   *DEFAULTCOLOR* SSSolid 
               ) 
  ;;计算九宫格点 
  (defun Get9JustPts (LL UR / tmp BC BL BR MC ML MR TC TL TR) 
    (setq 
      LL (list (car LL) (cadr LL) 0.0) 
      UR (list (car UR) (cadr UR) 0.0) 
      BL LL 
      TR UR 
      MC (GXL-MIDPOINT BL TR) 
      TL (list (car BL) (cadr TR) 0.0) 
      TC (list (car MC) (cadr TR) 0.0) 
      MR (list (car TR) (cadr MC) 0.0) 
      BR (list (car TR) (cadr BL) 0.0) 
      BC (list (car MC) (cadr BL) 0.0) 
      ML (list (car BL) (cadr MC) 0.0) 
      ) 
    (list TL TC TR ML MC MR BL BC BR) 
    ) 
 ;;创建临时对话框 
 (defun mkTmpDcl (dclname / tmpdcl f _GetSavePath) 
   (DEFUN _GETSAVEPATH (/ TMP) 
     (COND ((SETQ TMP (GETVAR (QUOTE ROAMABLEROOTPREFIX))) 
            (OR (EQ "\\" (SUBSTR TMP (STRLEN TMP))) 
                (SETQ TMP (STRCAT TMP "\\")) 
                ) 
            (STRCAT TMP "Support") 
            ) 
           ((SETQ TMP (FINDFILE "ACAD.pat")) 
            (SETQ TMP (VL-FILENAME-DIRECTORY TMP)) 
            (AND (EQ "\\" (SUBSTR TMP (STRLEN TMP))) 
                 (SETQ TMP (SUBSTR TMP (1- (STRLEN TMP)))) 
                 ) 
            TMP 
            ) 
           ) 
     ) 
   (IF DCLNAME 
     (SETQ TMPDCL 
            (STRCAT (_GETSAVEPATH) 
                    "\\" 
                    (if        (and 
                          (> (strlen DCLNAME) 4) 
                          (= ".dcl" 
                             (substr (setq DCLNAME (STRCASE DCLNAME T)) 
                                     (- (strlen DCLNAME) 3) 
                                     4 
                             ) 
                          ) 
                        ) 
                      (substr DCLNAME 1 (- (strlen DCLNAME) 4)) 
                      DCLNAME 
                    ) 
                    ".dcl" 
            ) 
     ) 
     (SETQ TMPDCL (VL-FILENAME-MKTEMP "tmp" "" ".dcl")) 
     ) 
   (if (not (findfile tmpdcl)) 
     (progn 
       (setq f (open tmpdcl "w")) 
       (foreach str '("xl2cad:dialog {" 
                      "    label = \"Excel 转CAD表格 【Gu_xl】\" ;" 
                      "    :boxed_radio_column {" 
                      "        key = \"Range\" ;" 
                      "        label = \"Excel数据范围\" ;" 
                      "        :radio_button {" 
                      "            key = \"Used\" ;" 
                      "            label = \"所有使用的单元格\" ;" 
                      "        }" 
                      "        :radio_button {" 
                      "            key = \"User\" ;" 
                      "            label = \"用户选定的单元格\" ;" 
                      "        }" 
                      "        :radio_button {" 
                      "            key = \"PrintArea\" ;" 
                      "            label = \"页面可打印区域\" ;" 
                      "        }" 
                      "    }" 
                      ":button {" 
                      "    alignment = left ;" 
                      "    fixed_height = true ;" 
                      "    fixed_width = true ;" 
                      "    key = \"getfile\" ;" 
                      "    label = \"选择Excel文件->\" ;" 
                      "    width = 20 ;" 
                      "}" 
                      "    :boxed_column {" 
                      "        label = \"生成设定\" ;" 
                      "        :row {" 
                      "            :toggle {" 
                      "                key = \"CellColor\" ;" 
                      "                label = \"单元格背景颜色\" ;" 
                      "            }" 
                      "            :toggle {" 
                      "                key = \"AnnoColor\" ;" 
                      "                label = \"文 本 颜 色\" ;" 
                      "            }" 
                      "        }" 
                      "        :row {" 
                      "        :toggle {" 
                      "            key = \"PageSetup\" ;" 
                      "            label = \"按页面设置输出\" ;" 
                      "        }" 
                      "        :toggle {" 
                      "            key = \"Merge\" ;" 
                      "            label = \"合并表格线\" ;" 
                      "        }" 
                      "        }" 
                      "        :row {" 
                      "            :toggle {" 
                      "                key = \"KeepTHeight\" ;" 
                      "                label = \"缺省文本高度\" ;" 
                      "            }" 
                      "            :edit_box {" 
                      "                key = \"THeight\" ;" 
                      "                label = \"\" ;" 
                      "            }" 
                      "        }" 
                      "        :boxed_radio_row {" 
                      "            key = \"Gather\" ;" 
                      "            label = \"实体集合\" ;" 
                      "            :radio_button {" 
                      "                key = \"None\" ;" 
                      "                label = \"无操作\" ;" 
                      "            }" 
                      "            :radio_button {" 
                      "                key = \"Group\" ;" 
                      "                label = \"无名组\" ;" 
                      "            }" 
                      "            :radio_button {" 
                      "                key = \"UBlock\" ;" 
                      "                label = \"无名块\" ;" 
                      "            }" 
                      "        }" 
                      "        :boxed_column {" 
                      "            label = \"实体图层\" ;" 
                      "            :popup_list {" 
                      "                edit_width = 15 ;" 
                      "                key = \"BLayer\" ;" 
                      "                label = \"单元格线:\" ;" 
                      "            }" 
                      "            :popup_list {" 
                      "                edit_width = 15 ;" 
                      "                key = \"TLayer\" ;" 
                      "                label = \"表格内容:\" ;" 
                      "            }" 
                      "         :row {" 
                      "        :radio_button {" 
                      "            key = \"ByLayer\" ;" 
                      "            label = \"颜色随层\" ;" 
                      "        }" 
                      "        :radio_button {" 
                      "            key = \"ByBlock\" ;" 
                      "            label = \"颜色随块\" ;" 
                      "        }" 
                      "            }" 
                      "        }" 
                      "    }" 
                      "    ok_cancel_help;" 
                      "    errtile;" 
                      "}" 
                      ) 
         (write-line str f) 
         ) 
       (close f) 
       ) 
     ) 
   tmpdcl 
   ) 
  ;; 
 (defun start_xl2x () 
   (setq *DrawRange* (getenv "Excel2CAD\\DrawRange")) 
   (if (null *DrawRange*) 
     (progn 
     (setq *DrawRange* "Used") 
     (setEnv "Excel2CAD\\DrawRange" *DrawRange*) 
     ) 
     ) 
   (set_tile *DrawRange* "1") 
   (GXL-DCL-ADDLIST "BLayer" Layers (VL-POSITION "0" Layers)) 
   (setq BLayer (nth 0 layers)) 
   (GXL-DCL-ADDLIST "TLayer" Layers (VL-POSITION "0" Layers)) 
   (setq TLayer (nth 0 layers)) 
   (setq *CellColor* (= "1" (getenv "Excel2CAD\\CellColor"))) 
   (if *CellColor* 
       (set_tile "CellColor" "1") ;_ 背景颜色 
     (progn 
       (set_tile "CellColor" "0") ;_ 背景颜色 
       (setEnv "Excel2CAD\\CellColor" "0") 
     ) 
   ) 
   (setq *AnnoColor* (= "1" (getenv "Excel2CAD\\AnnoColor"))) 
   (if *AnnoColor* 
       (set_tile "AnnoColor" "1") ;_ 文本颜色 
     (progn 
       (set_tile "AnnoColor" "0") ;_ 文本颜色 
       (setEnv "Excel2CAD\\AnnoColor" "0") 
     ) 
   ) 
   (setq *Oprate* (getenv "Excel2CAD\\Oprate")) 
   (if *Oprate* 
     (setq *Oprate* (atoi *Oprate*)) 
     (setq *Oprate* 0) 
     ) 
   (setenv "Excel2CAD\\Oprate" (itoa *Oprate*)) 
   (cond 
     ((or (null *Oprate*) (= 0 *Oprate*)) 
      (setq *Oprate* 0) 
      (set_tile "None" "1") 
      ) 
     ((= 1 *Oprate*) 
      (set_tile "Group" "1") 
      ) 
     ((= 2 *Oprate*) 
      (set_tile "UBlock" "1") 
      ) 
     ) 
   (setq *Merge* (= "1" (getenv "Excel2CAD\\Merge"))) 
   (if *Merge* 
     (set_tile "Merge" "1") 
     (progn 
     (set_tile "Merge" "0") 
     (Setenv "Excel2CAD\\Merge" "0") 
     ) 
     ) 
   (setq *THeight* (getenv "Excel2CAD\\THeight")) 
   (if (null *THeight*) 
     (progn 
       (setq *THeight* 300) 
       (Setenv "Excel2CAD\\THeight" "300") 
     ) 
     (setq *THeight* (atof *THeight*)) 
   ) 
   (set_tile "THeight" (rtos *THeight* 2)) 
   (setq *KeepTHeight* (= "1" (getenv "Excel2CAD\\KeepTHeight"))) 
   (if *KeepTHeight* 
     (progn 
     (mode_tile "THeight" 0) 
     (set_tile "KeepTHeight" "1") 
     ) 
     (progn 
     (mode_tile "THeight" 1) 
     (set_tile "KeepTHeight" "0") 
     (Setenv "Excel2CAD\\KeepTHeight" "0") 
     ) 
     ) 
   (setq *pageSetUp* (= "1" (getenv "Excel2CAD\\pageSetUp"))) 
   (if *pageSetUp* 
     (set_tile "PageSetup" "1") 
     (progn 
     (set_tile "PageSetup" "0") 
     (Setenv "Excel2CAD\\PageSetup" "0") 
     ) 
     ) 
   (setq *defaultColor* (getenv "Excel2CAD\\defaultColor")) 
   (if (null *defaultColor*) 
     (progn 
     (setq *defaultColor* 0) 
     (Setenv "Excel2CAD\\defaultColor" "0") 
     ) 
     (setq *defaultColor* (atoi *defaultColor*)) 
     ) 
   (cond 
     ((= 0 *defaultColor*) (set_tile "ByBlock" "1")) 
     (t (set_tile "ByLayer" "1") 
      (setq *defaultColor* 256) 
      ) 
     ) 
 ;;控件控制动作 
   (action_tile "getfile" "(act_getfile)") 
   (action_tile "Used" "(act_Used $key $value $reason)") 
   (action_tile "PrintArea" "(act_PrintArea $key $value)") 
   (action_tile "User" "(act_User $key $value $reason)") 
   (action_tile "CellColor" "(act_CellColor $key $value $reason)") 
   (action_tile "AnnoColor" "(act_AnnoColor $key $value $reason)") 
   (action_tile "PageSetup" "(act_PageSetup $key $value)") 
   (action_tile "Merge" "(act_Merge $key $value $reason)") 
   (action_tile "KeepTHeight" "(act_KeepTHeight $value)") 
   (action_tile "THeight" "(setq *THeight* (gxl-chkrealp $value $key 6)) (if *THeight* (Setenv \"Excel2CAD\\\\THeight\" (rtos *THeight* 2)))") 
   (action_tile "Gather" "(act_Gather $key $value $reason)") 
   (action_tile "None" "(act_None $key $value $reason)") 
   (action_tile "Group" "(act_Group $key $value $reason)") 
   (action_tile "UBlock" "(act_UBlock $key $value $reason)") 
   (action_tile "BLayer" "(act_BLayer $key $value $reason)") 
   (action_tile "TLayer" "(act_TLayer $key $value $reason)") 
   (action_tile "ByBlock" "(setq *defaultColor* 0) (Setenv \"Excel2CAD\\\\defaultColor\" \"0\")") 
   (action_tile "ByLayer" "(setq *defaultColor* 256) (Setenv \"Excel2CAD\\\\defaultColor\" \"256\")") 
   (action_tile "help" "(alert \"***Excel To <a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>*** \n\n版权所有:Gu_xl \n\n联系方式:Gu_xl@sohu.com\n\n\")") 
 ) 
  ;;act_getfile动作 
  (defun act_getfile (/ filename) 
    (setq filename (getfiled "" "" "xls;xlsx" 4)) 
    (if filename (setq *xlapp* (vlxls-app-open filename t))) 
    ) 
 
  ;;控件 Used 动作 
    (defun act_Used (key val reason) 
      (setq *DrawRange* key) 
      (setEnv "Excel2CAD\\DrawRange" key) 
     ) 
 
  ;;控件 User 动作 
    (defun act_User (key val reason) 
      (setq *DrawRange* key) 
      (setEnv "Excel2CAD\\DrawRange" key) 
     ) 
   (defun act_PrintArea (key val) 
     (setq *DrawRange* key) 
     (setEnv "Excel2CAD\\DrawRange" key) 
     ) 
  ;;控件 CellColor 动作 
    (defun act_CellColor (key val reason) 
      (setq *CellColor* (= "1" val)) 
      (setEnv "Excel2CAD\\CellColor" val) 
     ) 
 
  ;;控件 AnnoColor 动作 
    (defun act_AnnoColor (key val reason) 
      (setq *AnnoColor* (= "1" val)) 
      (setEnv "Excel2CAD\\AnnoColor" val) 
     ) 
 ;;按页面设置输出 
  (defun act_PageSetup (key val) 
    (setq *PageSetUp* (= "1" val)) 
    (setEnv "Excel2CAD\\PageSetup" val) 
    ) 
  ;;控件 Merge 动作 
    (defun act_Merge (key val reason) 
      (setq *Merge* (= "1" val)) 
      (setEnv "Excel2CAD\\Merge" val) 
     ) 
 
 
  ;;控件 None 动作 
    (defun act_None (key val reason) 
      (setq *Oprate* 0) 
      (set_tile "None" "1") 
      (setEnv "Excel2CAD\\Oprate" "0") 
     ) 
 
  ;;控件 Group 动作 
    (defun act_Group (key val reason) 
      (setq *Oprate* 1) 
      (set_tile "Group" "1") 
      (setEnv "Excel2CAD\\Oprate" "1") 
     ) 
 
  ;;控件 UBlock 动作 
    (defun act_UBlock (key val reason) 
      (setq *Oprate* 2) 
      (set_tile "UBlock" "1") 
      (setEnv "Excel2CAD\\Oprate" "2") 
     ) 
  ;;缺省文本高度 
  (defun act_KeepTHeight (val) 
    (setq *KeepTHeight* (= "1" val)) 
    (setEnv "Excel2CAD\\KeepTHeight" val) 
    (if *KeepTHeight* 
      (mode_tile "THeight" 0) 
      (mode_tile "THeight" 1) 
      ) 
    ) 
  ;;控件 BLayer 动作 
    (defun act_BLayer (key val reason) 
      (setq BLayer (nth (read val) layers)) 
     ) 
 
  ;;控件 TLayer 动作 
    (defun act_TLayer (key val reason) 
      (setq TLayer (nth (read val) layers)) 
     ) 
  ;;绘制顶端标题 
  (defun PrintTitleRows        (Range / R                PRINTAREA    
                           CELLS        COL             ROW 
                           MERGEP        WIDTH             HEIGHT 
                           TEXT                FONT             HORIZONTALALIGNMENT 
                           VERTICALALIGNMENT             DXF71 
                           DXF62        DXF420             RANGEFONT 
                           DXF7                TEXTFONT     DXF40 
                           TEXTVERFLAG        TMP             OLDROW 
                                   P0             
                           RIGHTTOPPT        OLDHEIGHT    MERGEID 
                           WIDTH1        HEIGHT1             P1 
                           P2                P3             HORLINE 
                           VERLINES        INTERIORCOLOR 
                           INTERIORTRUECOLOR             TEXTPT 
                         Columns 
                          ) 
    (setq r (VLXLS-GET-PROPERTY 
              *XLAPP* 
              "ActiveSheet.PageSetup.PrintTitleRows" 
            ) 
    ) 
    (if        (/= "" r) 
      (progn 
        (progn 
            (setq r            (GXL-STRPARSE r ":")) 
          (vlax-for a (VLXLS-GET-PROPERTY range "Columns") 
            (setq 
              Columns (cons (VLXLS-GET-PROPERTY a "Column") Columns) 
              ) 
            ) 
          (setq Columns (reverse Columns)) 
          (setq r (strcat (chr (+ 64 (car Columns))) (car r) ":" (chr (+ 64 (last Columns))) (last r))) 
          (setq range            (vlax-get-property *XLAPP* 'range r) 
                cells            (vlax-get-property range 'cells) 
                ) 
            ;;逐个绘制表头，未完成 
            (vlax-for cell cells 
              (gxl-Sys-Progress to -1) 
              (setq col           (vlax-get-property cell 'column) 
                    row           (vlax-get-property cell 'row) 
                    range  (msxlp-get-range 
                             *xlApp* 
                             (VLXLS-RANGEID (list col row)) 
                           ) 
                    Mergep (equal :vlax-true 
                                  (vlax-variant-value 
                                    (vlax-get-property cell 'MergeCells) 
                                  ) 
                           ) 
                    width  (* defaultHeight 
                              GridScale 
                              (vlax-variant-value 
                                (vlax-get-property cell 'width) 
                              ) 
                           ) 
                    height (* defaultHeight 
                              GridScale 
                              (vlax-variant-value 
                                (vlax-get-property cell 'height) 
                              ) 
                           ) 
                    text   (vlax-variant-value (vlax-get-property cell 'text)) 
              ) 
              (if (and (/= text "") 
                       (not (equal width 0 0.01)) 
                  ) 
                (progn 
                  (setq 
                    font (vlax-get-property range 'font) 
                    HorizontalAlignment 
                     (vlax-variant-value 
                       (vlax-get-property 
                         Cell 
                         'HorizontalAlignment 
                       ) 
                     ) 
                    HorizontalAlignment 
                     (cond ((= HorizontalAlignment -4152) 2) ;_ 右 
                           ((= HorizontalAlignment -4108) 1) ;_ 中 
                           (t 0) ;_ 左 
                     ) 
                    VerticalAlignment 
                     (vlax-variant-value 
                       (vlax-get-property 
                         Cell 
                         'VerticalAlignment 
                       ) 
                     ) 
                    VerticalAlignment 
                     (cond ((= VerticalAlignment -4160) 0) ;_ 上 
                           ((= VerticalAlignment -4108) 1) ;_ 中 
                           (t 2) ;_ 下 
                     ) 
                    DXF71 (nth VerticalAlignment 
                               (nth HorizontalAlignment dxf71data) 
                          ) 
                    DXF62 (vlxls-color-eci->aci 
                            (vlax-variant-value 
                              (vlax-get-property Font 'colorIndex) 
                            ) 
                          ) 
                    DXF420 (vlxls-color-eci->truecolor 
                             (vlax-variant-value 
                               (vlax-get-property Font 'colorIndex) 
                             ) 
                           ) 
                  ) 
                  ;;计算Range的字体 RangeFont i ii char cfont charFont caption f TextVerFlag 
                  (setq        RangeFont 
                         (mapcar 
                           '(lambda (x) (cons x (VLXLS-GET-PROPERTY font x))) 
                           '("NAME"            "SIZE" 
                             "COLORINDEX"   "BOLD" 
                             "ITALIC"            "SUBSCRIPT" 
                             "SUPERSCRIPT"  "UNDERLINE" 
                            ) 
                         ) 
                  ) 
                  (setq DXF7 (cdr (assoc "NAME" RangeFont))) 
                  (if (null dxf7) 
                    (setq DXF7 StandardFont) 
                  ) 
                  ;;字体 
                  (setq textFont (strcat "{\\f" DXF7 "|b0|i0|c134|p0;")) 
                  (setq Dxf40 (cdr (assoc "SIZE" RangeFont))) 
                  (if (null DXF40) 
                    (setq DXF40 StandardFontSize) 
                  ) 
                  ;;字大小 
                  (setq        textFont (strcat textFont 
                                         "\\H" 
                                         (rtos DXF40 2 1) 
                                         "x;" 
                                 ) 
                  ) 
                  ;;加粗 
                  (if (equal :vlax-true (cdr (assoc "BOLD" RangeFont))) 
                    (setq textfont (strcat textFont "\\W1.2;")) 
                  ) 
                  ;;倾斜 
                  (if 
                    (equal :vlax-true (cdr (assoc "ITALIC" RangeFont))) 
                     (setq textfont (strcat textFont "\\Q18;")) 
                  ) 
                  ;;下划线 
                  (if (= 2 (cdr (assoc "UNDERLINE" RangeFont))) 
                    (setq textfont (strcat textFont "\\L")) 
                  ) 
                  ;;上标 "SUPERSCRIPT" 
                  ;;下标 "SUBSCRIPT" 
                  ;;文字是否竖向 
                  (setq        TextVerFlag 
                         (= (GXL-CATCHAPPLY 
                              VLXLS-GET-PROPERTY 
                              (list range "Orientation") 
                            ) 
                            -4166 
                         ) 
                  ) 
                  (if TextVerFlag 
                    (progn 
                      (setq text (gxl-str->singleonly text)) 
                      (setq tmp         (car text) 
                            text (cdr text) 
                      ) 
                      (foreach a text (setq tmp (strcat tmp "\\P" a))) 
                      (setq text tmp) 
                    ) 
                  ) 
                  ;;逐字取样式 
                  ;;(setq textFont (strcat textFont (GetRangeTextStyle RANGE RANGEFONT text) "}")) 
 
                  (setq text (strcat textFont text "}")) 
 
                ) 
              ) 
              (cond ((null OldRow) (setq OldRow Row)) 
                    ((/= OldRow Row) ;_ 换行 
                     (if *pageSetUp* 
                       (progn 
                         (if nil        ;(member row HPageBreaks) ;_ 换页 
                           (progn 
                             (setq OldRow Row 
                                   StartPoint 
                                    (polar StartPoint 
                                           (* 1.5 pi) 
                                           oldheight 
                                    ) 
                             ) 
                             (if *Merge* 
                               (progn 
                                 (entmake 
                                   (list 
                                     '(0 . "line") 
                                     '(100 . "AcDbEntity") 
                                     '(67 . 0) 
                                     (cons 8 Blayer) 
                                     (cons 62 *defaultColor*) 
                                     '(100 . "AcDbLine") 
                                     (cons 10 
                                           StartPoint 
 
                                     ) 
                                     (cons 
                                       11 
                                       (setq p0 
                                              (polar 
                                                StartPoint 
                                                0 
                                                (* defaultHeight 
                                                   GridScale 
                                                   Totalwide 
                                                ) 
                                              ) 
                                       ) 
                                     ) 
                                     '(210 0.0 0.0 1.0) 
                                   ) 
                                 ) 
                                 (entmake 
                                   (list 
                                     '(0 . "line") 
                                     '(100 . "AcDbEntity") 
                                     '(67 . 0) 
                                     (cons 8 Blayer) 
                                     (cons 62 *defaultColor*) 
                                     '(100 . "AcDbLine") 
                                     (cons 10 RightTopPt) 
                                     (cons 11 p0) 
                                     '(210 0.0 0.0 1.0) 
                                   ) 
                                 ) 
 
                               ) 
                             ) 
                             (setq StartPoint (polar StartPoint 
                                                     (* 1.5 pi) 
                                                     PageMargin 
                                              ) 
                                   Curpt      StartPoint 
                                   RightTopPt (polar StartPoint 
                                                     0 
                                                     (*        defaultHeight 
                                                        GridScale 
                                                        Totalwide 
                                                     ) 
                                              ) 
                             ) ;_ 移动页间距 
                           ) 
                           (setq OldRow            Row 
                                 StartPoint (polar StartPoint 
                                                   (* 1.5 pi) 
                                                   oldheight 
                                            ) 
                                 Curpt            StartPoint 
                           ) 
                         ) 
                       ) 
                       (setq OldRow        Row 
                             StartPoint        (polar StartPoint (* 1.5 pi) oldheight) 
                             Curpt        StartPoint 
                       ) 
                     ) 
 
 
                    ) 
              ) 
 
              (setq oldheight height) 
              (if (not (equal width 0 0.01)) 
                (progn 
                  (if Mergep 
                    (progn 
                      (setq mergeId (mapcar 'vlxls-rangeid 
                                            (vlxls-cellid 
                                              (vlxls-range-getid range) 
                                            ) 
                                    ) 
                            width1  (* defaultHeight 
                                       GridScale 
                                       (VLXLS-GET-PROPERTY 
                                         range 
                                         "MergeArea.width" 
                                       ) 
                                    ) 
                            height1 (* defaultHeight 
                                       GridScale 
                                       (VLXLS-GET-PROPERTY 
                                         range 
                                         "MergeArea.height" 
                                       ) 
                                    ) 
                      ) 
                    ) 
                    (setq width1  width 
                          height1 height 
                    ) 
                  ) 
                  (if 
                    (or        (not Mergep) 
                        (and Mergep (equal (car mergeId) (list col row))) 
                    ) 
                     (progn 
                       (setq p0        (polar Curpt (* 1.5 pi) height1) 
                             p1        Curpt 
                             p2        (polar Curpt 0 width1) 
                             p3        (polar p2 (* 1.5 pi) height1) 
                       ) ;_ 框的四个角点 左下、左上、右上、右下 
                       (if *Merge* 
                         (progn 
                           (if Horline 
                             (progn 
                               (if (equal p1 (gxl-dxf HorLine 11) 1e-3) 
                                 (gxl-ch_ent HorLine 11 p2) ;_ 更新水平直线末端点 
                                 (progn 
                                   (entmake 
                                     (list 
                                       '(0 . "line") 
                                       '(100 . "AcDbEntity") 
                                       '(67 . 0) 
                                       (cons 8 Blayer) 
                                       (cons 62 *defaultColor*) 
                                       '(100 . "AcDbLine") 
                                       (cons 10 p1) 
                                       (cons 11 p2) 
                                       '(210 0.0 0.0 1.0) 
                                     ) 
                                   ) 
                                   (setq Horline (entlast)) 
                                 ) 
                               ) 
                             ) 
                             (progn 
                               (entmake 
                                 (list 
                                   '(0 . "line") 
                                   '(100 . "AcDbEntity") 
                                   '(67 . 0) 
                                   (cons 8 Blayer) 
                                   (cons 62 *defaultColor*) 
                                   '(100 . "AcDbLine") 
                                   (cons 10 p1) 
                                   (cons 11 p2) 
                                   '(210 0.0 0.0 1.0) 
                                 ) 
                               ) 
                               (setq Horline (entlast)) 
                             ) 
                           ) 
                           (if VerLines 
                             (progn 
                               (if (not 
                                     (vl-some 
                                       (Function 
                                         (lambda (Line) 
                                           (if (equal p1 
                                                      (gxl-dxf Line 11) 
                                                      1e-3 
                                               ) 
                                             (gxl-ch_ent Line 11 p0) ;_ 更新垂直直线末端点 
                                           ) 
                                         ) 
                                       ) 
                                       VerLines 
                                     ) 
                                   ) 
                                 (progn 
                                   (entmake 
                                     (list 
                                       '(0 . "line") 
                                       '(100 . "AcDbEntity") 
                                       '(67 . 0) 
                                       (cons 8 Blayer) 
                                       (cons 62 *defaultColor*) 
                                       '(100 . "AcDbLine") 
                                       (cons 10 p1) 
                                       (cons 11 p0) 
                                       '(210 0.0 0.0 1.0) 
                                     ) 
                                   ) 
                                   (setq 
                                     VerLines (cons (entlast) VerLines) 
                                   ) 
                                 ) 
                               ) 
                             ) 
                             (progn 
                               (entmake 
                                 (list 
                                   '(0 . "line") 
                                   '(100 . "AcDbEntity") 
                                   '(67 . 0) 
                                   (cons 8 Blayer) 
                                   (cons 62 *defaultColor*) 
                                   '(100 . "AcDbLine") 
                                   (cons 10 p1) 
                                   (cons 11 p0) 
                                   '(210 0.0 0.0 1.0) 
                                 ) 
                               ) 
                               (setq VerLines (cons (entlast) VerLines)) 
                             ) 
                           ) 
                         ) 
                         (entmake 
                           (list 
                             '(0 . "LWPOLYLINE") 
                             '(100 . "AcDbEntity") 
                             '(67 . 0) 
                             (cons 8 BLayer) 
                             (cons 62 *defaultColor*) 
                             '(100 . "AcDbPolyline") 
                             '(90 . 4) 
                             '(70 . 1) 
                             '(43 . 0.0) 
                             '(38 . 0.0) 
                             '(39 . 0.0) 
                             (cons 10 p0) 
                             (cons 10 p1) 
                             (cons 10 p2) 
                             (cons 10 p3) 
                             '(210 0.0 0.0 1.0) 
                           ) 
                         ) 
                       ) 
                       (if *CellColor* ;_ 绘制背景颜色 
                         (progn 
                           (if (/= -4142 
                                   (setq Interiorcolor 
                                          (VLXLS-GET-PROPERTY 
                                            range 
                                            "Interior.ColorIndex" 
                                          ) 
                                   ) 
                               ) 
                             (progn 
                               (setq Interiorcolor     (VLXLS-COLOR-ECI->ACI 
                                                         Interiorcolor 
                                                       ) 
                                     Interiortruecolor (VLXLS-COLOR-ECI->TRUECOLOR 
                                                         Interiorcolor 
                                                       ) 
                               ) 
                               (entmake 
                                 (vl-remove 
                                   nil 
                                   (list 
                                     '(0 . "SOLID") 
                                     '(100 . "AcDbEntity") 
                                     '(67 . 0) 
                                     (cons 8 BLayer) 
                                     (cons 62 Interiorcolor) 
                                     ;|(if (not (or (= 256 Interiorcolor) 
                                   (= 0 Interiortruecolor) 
                               ) 
                          ) 
                        (cons 420 Interiortruecolor) 
                      )|; 
                                     '(100 . "AcDbTrace") 
                                     (cons 10 p0) 
                                     (cons 11 p1) 
                                     (cons 12 p3) 
                                     (cons 13 p2) 
                                     '(210 0.0 0.0 1.0) 
                                   ) 
                                 ) 
                               ) 
                               ;(setq SSSolid (cons (entlast) SSSolid)) 
                             ) 
                           ) 
 
                         ) 
                       ) 
                       (if (/= "" text) 
                         (progn 
                           (setq textpt 
                                  (nth (1- DXF71) (Get9JustPts p0 p2)) 
                           ) 
                           (cond ((= 0 HorizontalAlignment) ;_ 左对齐 
                                  (setq 
                                    textpt (polar textpt 0 (* height 0.1)) 
                                  ) 
                                 ) 
                                 ((= 2 HorizontalAlignment) ;_ 右对齐 
                                  (setq 
                                    textpt (polar textpt pi (* height 0.1)) 
                                  ) 
                                 ) 
                           ) 
                           (cond 
                             ((= 0 VerticalAlignment) ;_ 上对齐 
                              (setq textpt (polar textpt 
                                                  (* 1.5 pi) 
                                                  (* height 0.1) 
                                           ) 
                              ) 
                             ) 
                             ((= 2 VerticalAlignment) ;_ 下对齐 
                              (setq textpt (polar textpt 
                                                  (* 0.5 pi) 
                                                  (* height 0.1) 
                                           ) 
                              ) 
                             ) 
                           ) 
                           (entmake 
                             (vl-remove 
                               nil 
                               (list 
                                 (cons 0 "MTEXT") 
                                 '(100 . "AcDbEntity") 
                                 '(67 . 0) 
                                 (cons 8 TLayer) 
                                 (if *AnnoColor* 
                                   (cons 62 dxf62) 
                                   (cons 62 *defaultColor*) 
                                 ) 
                                 '(100 . "AcDbMText") 
                                 (cons 10 textpt) 
                                 (cons 40 defaultHeight) 
                                 (cons 41 width1) 
                                        ;(cons 50 0) 
                                 ;;'(46 . 0.0) 
                                 (cons 71 DXF71) 
                                 (cons 72 5) 
                                 (cons 1 text) 
                                 (cons 7 "Standard") 
                                 '(210 0.0 0.0 1.0) 
                                 '(11 1.0 0.0 0.0) 
                                 '(50 . 0.0) 
                                 '(73 . 1) 
                               ) 
                             ) 
                           ) 
                         ) 
                       ) 
                     ) 
                  ) 
                  (setq Curpt (polar Curpt 0 width)) 
                ) 
              ) 
            ) ;_ vlax-for 
             
          ) 
        (setq startpoint (polar startpoint (* 1.5 pi) oldheight) curpt startpoint) 
      ) 
    ) 
 
  ) 
  ;;Range的text逐字取样式 
  (defun GetRangeTextStyle (RANGE RANGEFONT text            /             I 
                                  II           CHAR            CFONT    CAPTION 
                                  CHARFONT F            TEXTFONT 
                                 ) 
   (if (equal :vlax-false (vlxls-get-property range "HasFormula")) 
          (progn 
            (setq i  0 
                  ii (GXL-CATCHAPPLY 
                       vlax-get-property 
                       (list (vlax-get-property range 'characters) 'count) 
                     ) 
            ) 
            (if        ii 
              (repeat ii 
                (setq char  (vlax-get-property 
                              range 
                              'characters 
                              (setq i (1+ i)) 
                              1 
                            ) 
                      cfont (vlax-get-property char 'font) 
                      caption (VLXLS-GET-PROPERTY char "caption") 
                ) 
                (setq charFont 
                       (mapcar 
                         '(lambda (x) (cons x (VLXLS-GET-PROPERTY cfont x))) 
                         '("NAME"          "SIZE"         "COLORINDEX" 
                           "BOLD"          "ITALIC"         "SUBSCRIPT" 
                           "SUPERSCRIPT"  "UNDERLINE" 
                          ) 
                       ) 
                ) 
                (if (and (setq f (cdr (assoc "NAME" charFont))) 
                         (/= f (cdr (assoc "NAME" RangeFont))) 
                         ) 
                  (setq textfont (strcat "\\f" f  "|b0|i0|c134|p0;")) 
                  ) ;_ 字体 
                (if (and (setq f (cdr (assoc "SIZE" charFont))) 
                         (equal f (cdr (assoc "SIZE" RangeFont)) 0.01) 
                         ) 
                  (setq textfont (strcat textFont "\\H" (rtos f 2 1) "x;")) 
                  ) ;_ 大小 
                (if (and (setq f (cdr (assoc "COLORINDEX" charFont))) 
                         (equal f (cdr (assoc "COLORINDEX" RangeFont)) 0.01) 
                         ) 
                  (setq textfont (strcat textFont "\\C" (itoa (vlxls-color-eci->aci f)) ";")) 
                  ) ;_ 颜色 
                ;;加粗 
                (if (not (equal        (setq f (cdr (assoc "BOLD" charFont))) 
                                (cdr (assoc "BOLD" RangeFont)) 
                         ) 
                    ) 
                  (if (equal :vlax-true f) 
                    (setq textfont (strcat textFont "\\W1.2;")) 
                    (setq textfont (strcat textFont "\\W0.83;")) 
                  ) 
                ) 
                ;;倾斜 
                (if 
                  (not (equal (setq f (cdr (assoc "ITALIC" charFont))) 
                              (cdr (assoc "ITALIC" RangeFont)) 
                       ) 
                  ) 
                   (if (equal :vlax-true f) 
                     (setq textfont (strcat textFont "\\Q18;")) 
                     (setq textfont (strcat textFont "\\Q0;")) 
                   ) 
                ) 
                ;;上标 
                (if (equal :vlax-true (cdr (assoc "SUPERSCRIPT" RangeFont))) 
                    (setq textFont (strcat textFont "\\H0.33x;\\A2;")) 
                    ) 
                ;;下标 
                (if (equal :vlax-true (cdr (assoc "SUPERSCRIPT" RangeFont))) 
                    (setq textFont (strcat textFont "\\H0.33x;\\A0;")) 
                    ) 
                ;;下划线 
                (if 
                  (not (equal (setq f (cdr (assoc "UNDERLINE" charFont))) 
                              (cdr (assoc "UNDERLINE" RangeFont)) 
                       ) 
                  ) 
                   (if (= 2 f) 
                     (setq textfont (strcat textFont "\\L")) 
                     (setq textfont (strcat textFont "\\l")) 
                   ) 
                ) 
               (setq textFont (strcat textFont caption)) 
               (if (and TextVerFlag (/= i ii)) (setq textFont (strcat textFont "\\P"))) 
              ) 
              (setq textfont (strcat textfont text)) 
            ) 
          ) 
          (setq textfont (strcat textfont text)) 
        ) 
    ) 
  ;;绘制页眉页脚 PageSetUp vla对象 pt 表格基点 Flag = t 页眉 = nil 页脚 
  (defun DrawPageSetUp (PAGESETUP PT              FLAG          / 
                                  GETFONTSTR  LEFTHEADER  CENTERHEADER 
                                  RIGHTHEADER D                  TEXTPT 
                         LeftFooter CenterFooter RightFooter 
                                 ) 
; PageSetup:特性值: 
;   AlignMarginsHeaderFooter = 0 
;   Application (RO) = #<VLA-OBJECT _Application 0cdd3e9c> 
;   BlackAndWhite = 0 
;   BottomMargin = 70.8661 
;   CenterFooter = "&\"幼圆,加粗\"&16页脚中&N第&P页" 
;   CenterFooterPicture (RO) = #<VLA-OBJECT Graphic 1821ca84> 
;   CenterHeader = "页眉中" 
;   CenterHeaderPicture (RO) = #<VLA-OBJECT Graphic 1821d5c4> 
;   CenterHorizontally = 0 
;   CenterVertically = 0 
;   Creator (RO) = 1480803660 
;   DifferentFirstPageHeaderFooter = 0 
;   Draft = 0 
;   EvenPage (RO) = #<VLA-OBJECT Page 1821c454> 
;   FirstPage (RO) = #<VLA-OBJECT Page 1821ddec> 
;   FirstPageNumber = -4105 
;   FitToPagesTall = 1 
;   FitToPagesWide = 1 
;   FooterMargin = 36.8504 
;   HeaderMargin = 36.8504 
;   LeftFooter = "&\"楷体,常规\"&14页&\"楷体,加粗 倾斜\"脚&\"楷体,常规\"左" 
;   LeftFooterPicture (RO) = #<VLA-OBJECT Graphic 1821df54> 
;   LeftHeader = "页眉左" 
;   LeftHeaderPicture (RO) = #<VLA-OBJECT Graphic 1821c724> 
;   LeftMargin = 53.8583 
;   OddAndEvenPagesHeaderFooter = 0 
;   Order = 1.0 
;   Orientation = 1.0 
;   Pages (RO) = #<VLA-OBJECT Pages 1821c0ac> 
;   PaperSize = 9.0 
;   Parent (RO) = #<VLA-OBJECT _Worksheet 1821dad4> 
;   PrintArea = "$A$1:$N$105" 
;   PrintComments = -4142 
;   PrintErrors = 0 
;   PrintGridlines = 0 
;   PrintHeadings = 0 
;   PrintNotes = 0 
;   PrintQuality = ...不显示带索引的内容... 
;   PrintTitleColumns = "" 
;   PrintTitleRows = "$1:$3" 
;   RightFooter = "&\"楷体,加粗\"&KFF0000页脚右" 
;   RightFooterPicture (RO) = #<VLA-OBJECT Graphic 1821dccc> 
;   RightHeader = "页眉右" 
;   RightHeaderPicture (RO) = #<VLA-OBJECT Graphic 1821c8d4> 
;   RightMargin = 53.8583 
;   ScaleWithDocHeaderFooter = -1 
;   TopMargin = 70.8661 
;   Zoom = 100 
    (defun GetFontstr (str / size fontname fontstr color) 
      ;;用正则表达式删除格式文字 
      ;;"&\"幼圆,加粗\"&16页脚&\"楷体,加粗倾斜\"&12&KFFFF00中共&\"幼圆,加粗\"&16&K000000&N页 第&P页" 
      (setq fontname 
             (gxl-RegExSearch 
               str 
               "\&\\\".+?\"" 
               "im" 
               ) 
            ) 
      (if fontname 
        (progn 
          (setq fontname (caddar fontname)) 
          (setq fontname 
                (gxl-RegExRePlace 
                  fontname 
                  "" 
                  "&\\\"|\\\"" 
                  "mg" 
                  ) 
                ) 
          (setq fontname (GXL-STRPARSE fontname ",")) 
          (setq fontstr (strcat "{\\f" (car fontname) "|b0|i0|c134|p0;")) 
          (if (cadr fontname) 
            (progn 
              (if (WCMATCH (cadr fontname) "*加粗*") 
                (setq fontstr (strcat fontstr "\\W1.2;")) 
                ) 
              (if (WCMATCH (cadr fontname) "*倾斜*") 
                (setq fontstr (strcat fontstr "\\Q18;")) 
                ) 
               
              ) 
            ) 
          ) 
        (setq fontstr (strcat "{\\f" standardFont "|b0|i0|c134|p0;" "\\H" (rtos StandardFontSize 2 1) "x;")) 
        ) 
      (setq size 
             (gxl-RegExSearch 
               str 
               "&\\d{1,2}" 
               "im" 
               ) 
            ) 
      (if size 
        (progn 
          (setq size (caddar size)) 
          (setq size 
                (gxl-RegExRePlace 
                  size 
                  "" 
                  "&" 
                  "mg" 
                  ) 
                ) 
          (setq fontstr (strcat fontstr "\\H" size "x;")) 
          ) 
        ) 
      (if *AnnoColor* 
        (progn 
          (setq        color 
                 (gxl-RegExSearch 
                   str 
                   "\&K[A-Za-z0-9]{6}" 
                   "im" 
                 ) 
          ) 
          (if color 
            (progn 
              (setq color (strcat "#" (substr (caddar color) 3))) 
              (setq color (gxl-Hex->ACI color)) 
              (setq fontstr (strcat fontstr "\\C" (itoa color) ";")) 
            ) 
          ) 
        ) 
        (setq fontstr (strcat fontstr "\\C" (itoa *defaultColor*) ";")) 
      ) 
 
          
      (setq str 
             (gxl-RegExRePlace 
               str 
               "" 
               "&\\d{1,2}|\&\\\".+?\"|\&K[A-Za-z0-9]{6}" 
               "mg" 
             ) 
      ) 
      (setq str 
             (gxl-RegExRePlace 
               str 
               (itoa TotalPage) 
               "&N" 
               "mg" 
             ) 
      ) 
      (setq str 
             (gxl-RegExRePlace 
               str 
               (itoa Page) 
               "&P" 
               "mg" 
             ) 
      ) 
      ;(strcat "{\\f" standardFont "|b0|i0|c134|p0;" "\\H" (rtos StandardFontSize 2 1) "x;" str"}") 
      (strcat fontstr str "}") 
      ) 
    (cond 
      (flag ;_ 页眉 
       (setq LeftHeader (vlax-get-property PageSetUp 'LeftHeader) 
             CenterHeader (vlax-get-property PageSetUp 'CenterHeader) 
             RightHeader (vlax-get-property PageSetUp 'RightHeader) 
             ) 
       (if (/= "" LeftHeader) 
         (progn 
           (setq d (* defaultHeight GridScale (vlax-get-property PageSetUp 'HeaderMargin))) 
           (setq textpt (polar pt (* pi 0.5) d)) 
           (setq LeftHeader (GetFontstr LeftHeader)) 
           (entmake 
              (vl-remove 
                nil 
                (list 
                  (cons 0 "MTEXT") 
                  '(100 . "AcDbEntity") 
                  '(67 . 0) 
                  (cons 8 TLayer) 
                  (cons 62 *defaultColor*) 
                  '(100 . "AcDbMText") 
                  (cons 10 textpt) 
                  (cons 40 defaultHeight) 
                  (cons 41 (* 0.333 totalwide GridScale defaultHeight)) 
                  (cons 71 4) 
                  (cons 72 5) 
                  (cons 1 LeftHeader) 
                  (cons 7 "Standard") 
                  '(210 0.0 0.0 1.0) 
                  '(11 1.0 0.0 0.0) 
                  '(50 . 0.0) 
                  '(73 . 1) 
                ) 
              ) 
            ) 
           ) 
         ) 
       (if (/= "" CenterHeader) 
         (progn 
           (setq d (* defaultHeight GridScale (vlax-get-property PageSetUp 'HeaderMargin))) 
           (setq textpt (polar (polar pt (* pi 0.5) d) 0 (* 0.5 totalwide GridScale defaultHeight))) 
           (setq CenterHeader (GetFontstr CenterHeader)) 
           (entmake 
              (vl-remove 
                nil 
                (list 
                  (cons 0 "MTEXT") 
                  '(100 . "AcDbEntity") 
                  '(67 . 0) 
                  (cons 8 TLayer) 
                  (cons 62 *defaultColor*) 
                  '(100 . "AcDbMText") 
                  (cons 10 textpt) 
                  (cons 40 defaultHeight) 
                  (cons 41 (* 0.333 totalwide GridScale defaultHeight)) 
                  (cons 71 5) 
                  (cons 72 5) 
                  (cons 1 CenterHeader) 
                  (cons 7 "Standard") 
                  '(210 0.0 0.0 1.0) 
                  '(11 1.0 0.0 0.0) 
                  '(50 . 0.0) 
                  '(73 . 1) 
                ) 
              ) 
            ) 
           ) 
         ) 
       (if (/= "" RightHeader) 
         (progn 
           (setq d (* defaultHeight GridScale (vlax-get-property PageSetUp 'HeaderMargin))) 
           (setq textpt (polar (polar pt (* pi 0.5) d) 0 (* totalwide GridScale defaultHeight))) 
           (setq RightHeader (GetFontstr RightHeader)) 
           (entmake 
              (vl-remove 
                nil 
                (list 
                  (cons 0 "MTEXT") 
                  '(100 . "AcDbEntity") 
                  '(67 . 0) 
                  (cons 8 TLayer) 
                  (cons 62 *defaultColor*) 
                  '(100 . "AcDbMText") 
                  (cons 10 textpt) 
                  (cons 40 defaultHeight) 
                  (cons 41 (* 0.333 totalwide GridScale defaultHeight)) 
                  (cons 71 6) 
                  (cons 72 5) 
                  (cons 1 RightHeader) 
                  (cons 7 "Standard") 
                  '(210 0.0 0.0 1.0) 
                  '(11 1.0 0.0 0.0) 
                  '(50 . 0.0) 
                  '(73 . 1) 
                ) 
              ) 
            ) 
           ) 
         ) 
       ) 
      (t ;_ 页脚 
       (setq LeftFooter (vlax-get-property PageSetUp 'LeftFooter) 
             CenterFooter (vlax-get-property PageSetUp 'CenterFooter) 
             RightFooter (vlax-get-property PageSetUp 'RightFooter) 
             d (* defaultHeight GridScale (vlax-get-property PageSetUp 'FooterMargin)) 
             ) 
       (if (/= "" LeftFooter) 
         (progn 
           (setq textpt (polar pt (* pi 1.5) d)) 
           (setq LeftFooter (GetFontstr LeftFooter)) 
           (entmake 
              (vl-remove 
                nil 
                (list 
                  (cons 0 "MTEXT") 
                  '(100 . "AcDbEntity") 
                  '(67 . 0) 
                  (cons 8 TLayer) 
                  (cons 62 *defaultColor*) 
                  '(100 . "AcDbMText") 
                  (cons 10 textpt) 
                  (cons 40 defaultHeight) 
                  (cons 41 (* 0.333 totalwide GridScale defaultHeight)) 
                  (cons 71 4) 
                  (cons 72 5) 
                  (cons 1 LeftFooter) 
                  (cons 7 "Standard") 
                  '(210 0.0 0.0 1.0) 
                  '(11 1.0 0.0 0.0) 
                  '(50 . 0.0) 
                  '(73 . 1) 
                ) 
              ) 
            ) 
           ) 
         ) 
       (if (/= "" CenterFooter) 
         (progn 
           (setq textpt (polar (polar pt (* pi 1.5) d) 0 (* 0.5 totalwide GridScale defaultHeight))) 
           (setq CenterFooter (GetFontstr CenterFooter)) 
           (entmake 
              (vl-remove 
                nil 
                (list 
                  (cons 0 "MTEXT") 
                  '(100 . "AcDbEntity") 
                  '(67 . 0) 
                  (cons 8 TLayer) 
                  (cons 62 *defaultColor*) 
                  '(100 . "AcDbMText") 
                  (cons 10 textpt) 
                  (cons 40 defaultHeight) 
                  (cons 41 (* 0.333 totalwide GridScale defaultHeight)) 
                  (cons 71 5) 
                  (cons 72 5) 
                  (cons 1 CenterFooter) 
                  (cons 7 "Standard") 
                  '(210 0.0 0.0 1.0) 
                  '(11 1.0 0.0 0.0) 
                  '(50 . 0.0) 
                  '(73 . 1) 
                ) 
              ) 
            ) 
           ) 
         ) 
       (if (/= "" RightFooter) 
         (progn 
           (setq textpt (polar (polar pt (* pi 1.5) d) 0 (* totalwide GridScale defaultHeight))) 
           (setq RightFooter (GetFontstr RightFooter)) 
           (entmake 
              (vl-remove 
                nil 
                (list 
                  (cons 0 "MTEXT") 
                  '(100 . "AcDbEntity") 
                  '(67 . 0) 
                  (cons 8 TLayer) 
                  (cons 62 *defaultColor*) 
                  '(100 . "AcDbMText") 
                  (cons 10 textpt) 
                  (cons 40 defaultHeight) 
                  (cons 41 (* 0.333 totalwide GridScale defaultHeight)) 
                  (cons 71 6) 
                  (cons 72 5) 
                  (cons 1 RightFooter) 
                  (cons 7 "Standard") 
                  '(210 0.0 0.0 1.0) 
                  '(11 1.0 0.0 0.0) 
                  '(50 . 0.0) 
                  '(73 . 1) 
                ) 
              ) 
            ) 
           ) 
         ) 
 
       ) 
      ) 
    ) 
;;主程序开始 
  (setierr) 
(setq Layers (gxl-table "layer")) 
  ;;对话框开始 
  ;; 
  ;;(vl-file-delete (findfile "xl2cad.dcl")) 
   (setq dclcode (load_dialog (mkTmpDcl "xl2cad"))) 
   (new_dialog "xl2cad" dclcode) 
   (start_xl2x) 
   (setq ecode (start_dialog)) 
  (cond 
    ((= 1 ecode) 
  (if *CellColor* (setvar "REGENMODE" 0)) 
 (vlxls-app-init) 
 (or *xlapp* 
     (if (VL-CATCH-ALL-ERROR-P 
           (setq *xlApp* (VL-CATCH-ALL-APPLY 
                           'vlax-get-or-create-object 
                           '("Excel.Application") 
                         ) 
           ) 
         ) 
       (exit) 
     ) 
 ) 
 (if (equal :vlax-false (vlax-get-property *XLAPP* 'visible)) 
    (vla-put-visible *xlApp* 1) 
  ) 
 (if (= "User" *DrawRange*) 
     (vlax-put-property *XLAPP* 'Visible 1) 
 ) 
  (setq workbooks (vlax-get-property *xlApp* 'workbooks)) 
  (if (= 0 (vla-get-Count workbooks)) 
    (setq workbook (vlax-invoke workbooks 'add)) 
    (setq workbook (vlax-get-property *xlApp* 'activeworkbook)) 
  ) 
  (setq sheet (vlax-get-property *xlApp* 'activesheet)) 
  (setq        UsedRange (vlax-get-property sheet 'UsedRange) 
        col          (vlax-get-property 
                    (vlax-get-property UsedRange 'columns) 
                    'count 
                  ) 
        row          (vlax-get-property 
                    (vlax-get-property UsedRange 'rows) 
                    'count 
                  ) 
  ) 
  (cond 
    ((= "Used" *DrawRange*) 
     (setq Cells (vlax-get-property UsedRange 'Cells)) 
     ;(setq PrintArea (VLXLS-GET-PROPERTY *xlApp* "Activesheet.PageSetup.PrintArea")) 
    ) 
    ((= "User" *DrawRange*) 
     (alert "请在表格中选择数据后按确定键！") 
     (setq Selection (vlax-get-property *xlApp* 'Selection) 
           Cells     (vlax-get-property Selection 'Cells) 
     ) 
     ;(setq PrintArea (VLXLS-GET-PROPERTY *xlApp* "Activesheet.PageSetup.PrintArea")) 
    ) 
    ((= "PrintArea" *DrawRange*) 
     (setq PrintArea (VLXLS-GET-PROPERTY *xlApp* "Activesheet.PageSetup.PrintArea")) 
     (if (/= "" PrintArea) 
       (setq Cells (vlax-get-property 
                     (vlax-get-property *xlApp* 'range PrintArea) 
                     'Cells 
                   ) 
       ) 
       (progn 
         (alert "当前活动表格没有可打印的页面！\n\n请重新设置页面！程序将退出！") 
         (exit) 
         ) 
     ) 
    ) 
  ) 
  (if (= 1 (vlax-get-property cells 'count)) 
    (progn 
      (alert "Excel表格只有一行一列，程序将退出！") 
      (exit) 
    ) 
  ) 
  (if *pageSetUp* 
    (progn 
      (setq HPageBreaks nil) 
      (GXL-CATCHAPPLY 
        (lambda () 
           (vlax-for a (VLXLS-GET-PROPERTY 
                         *xlapp* 
                         "activesheet.HPageBreaks" 
                       ) 
             (setq HPageBreaks 
                    (cons (VLXLS-GET-PROPERTY a "Location.row") 
                          HPageBreaks 
                    ) 
             ) 
           ) 
         ) 
        nil 
      ) 
      (setq HPageBreaks (reverse HPageBreaks)) ;_ 储存分页的Row位置 
    ) 
  ) 
  (initget 7) 
  (setq StartPoint (getpoint "\n放置位置:")) 
  (setq StartPoint (trans StartPoint 1 0) 
        BasePoint StartPoint) 
  (setq        curpt  StartPoint 
        OldRow nil 
        to (vlax-get-property cells 'count) 
  ) 
    ;|71 
         附着点： 
        1 = 左上；2 = 中上；3 = 右上 
        4 = 左中；5 = 正中；6 = 右中 
        7 = 左下；8 = 中下；9 = 右下 
   |; 
  (setq dxf71data '((1 4 7) (2 5 8) (3 6 9))) 
  (GXL-SYS-PROGRESS-INIT "" to) 
  (setq StandardFont (vlax-get-property *xlApp* 'StandardFont)) 
  (setq StandardFontSize (vlax-get-property *XLAPP* 'StandardFontSize)) 
  (setq defaultHeight (/ *THeight* StandardFontSize)) ;_ 默认高度 
  (setq GridScale 1.941747572815534) 
  (setq totalwide (vlax-variant-value (vlax-get-property cells 'Width)) 
            totalheight (vlax-variant-value (vlax-get-property cells 'height)) 
            ) 
  (setq pagesetup (VLXLS-GET-PROPERTY *xlapp* "activesheet.pagesetup")) 
     (if (not *KeepTHeight*) 
    (progn       
      (entmake 
          (list 
            '(0 . "LWPOLYLINE") 
            '(100 . "AcDbEntity") 
            '(67 . 0) 
            '(100 . "AcDbPolyline") 
            '(90 . 4) 
            '(70 . 1) 
            '(43 . 0.0) 
            '(38 . 0.0) 
            '(39 . 0.0) 
            (cons 10 StartPoint) 
            (cons 10 
                  (setq p0 (polar StartPoint 
                                  0 
                                  (* totalwide GridScale defaultHeight) 
                                  ) 
                        ) 
                  ) 
            (cons 10 
                  (polar p0 
                         (* 1.5 pi) 
                         (* totalheight GridScale defaultHeight) 
                         ) 
                  ) 
            (cons 10 
                  (polar StartPoint 
                         (* 1.5 pi) 
                         (* totalheight GridScale defaultHeight) 
                         ) 
                  ) 
            '(210 0.0 0.0 1.0) 
            ) 
          ) 
      (setq endent (entlast)) 
      (setvar 'ORTHOMODE 1) 
      (initget 6) 
      (setq p0 (getdist (trans StartPoint 0 1) (strcat "\n输入表格宽度<" (rtos (* totalwide GridScale defaultHeight) 2 2) ">:"))) 
      (if (null p0) (setq p0 (* totalwide GridScale defaultHeight))) 
      (entdel endent) 
      (setq scale (/ p0 (* totalwide GridScale defaultHeight))) 
      (setq defaultHeight (* defaultHeight scale))   
     ) 
    ) 
     (setq endent (entlast) ) 
     (setq page 1 TotalPage (1+ (length HPageBreaks))) 
     (if *pageSetUp* 
       (progn 
         (setq PageMargin  ;_ 计算页间距 
                (* defaultHeight 
                   GridScale 
                   (+ 
                   (VLXLS-GET-PROPERTY 
                     *xlapp* 
                     "activesheet.pagesetup.BottomMargin" 
                   ) 
                   (VLXLS-GET-PROPERTY 
                     *xlapp* 
                     "activesheet.pagesetup.FooterMargin" 
                   ) 
                   (VLXLS-GET-PROPERTY 
                     *xlapp* 
                     "activesheet.pagesetup.TopMargin" 
                   ) 
                   (VLXLS-GET-PROPERTY 
                     *xlapp* 
                     "activesheet.pagesetup.HeaderMargin" 
                   ) 
                   ) 
                ) 
         ) 
         (setq RightTopPt  ;_ 每页右上角点 
                (polar StartPoint 
                       0 
                       (* defaultHeight GridScale Totalwide) 
                ) 
         ) 
         ;;输出页眉 
         (if *pageSetUp* (DrawPageSetUp pagesetup StartPoint t)) 
       ) 
     ) 
  ;;输出表头 
  (if *pageSetUp* (PrintTitleRows cells)) 
  (if (setq TitleRows ;_ 存储表头的行数 
             (VLXLS-GET-PROPERTY 
               *XLAPP* 
               "ActiveSheet.PageSetup.PrintTitleRows" 
             ) 
      ) 
    (progn 
      (setq TitleRows 
             (mapcar 
               'atoi 
               (vl-remove "" 
                          (GXL-STRPARSEBYLST TitleRows '(":" "$")) 
               ) 
             ) 
            tmp (car TitleRows) 
            tmp1 (cadr TitleRows) 
            TitleRows nil 
      ) 
      (if tmp1 
        (while (<= tmp tmp1) 
          (setq TitleRows (cons tmp TitleRows) 
                tmp (1+ tmp) 
                ) 
          ) 
        (setq TitleRows (list tmp)) 
        ) 
      (setq TitleRows (reverse TitleRows)) 
    ) 
  ) 
 
 
 
   ;;逐行逐列绘制表格 
  (vlax-for cell cells 
    (gxl-Sys-Progress to -1) 
    (setq col         (vlax-get-property cell 'column) 
          row         (vlax-get-property cell 'row) 
          range (msxlp-get-range *xlApp* (VLXLS-RANGEID (list col row))) 
          Mergep (equal :vlax-true (vlax-variant-value (vlax-get-property cell 'MergeCells))) 
          width         (* defaultHeight GridScale (vlax-variant-value (vlax-get-property cell 'width))) 
          height (* defaultHeight GridScale (vlax-variant-value (vlax-get-property cell 'height))) 
          text         (vlax-variant-value (vlax-get-property cell 'text)) 
          ) 
    (cond 
      ((and *pageSetUp* (member row TitleRows))) ;_ 忽略打印表头位置的表格 
      (t 
    (if        (and (/= text "") 
             (not (equal width 0 0.01)) 
        ) 
      (progn 
        (setq 
          font (vlax-get-property range 'font) 
          HorizontalAlignment 
           (vlax-variant-value 
             (vlax-get-property 
               Cell 
               'HorizontalAlignment 
             ) 
           ) 
          HorizontalAlignment 
           (cond ((= HorizontalAlignment -4152) 2) ;_ 右 
                 ((= HorizontalAlignment -4108) 1) ;_ 中 
                 (t 0) ;_ 左 
           ) 
          VerticalAlignment 
           (vlax-variant-value 
             (vlax-get-property 
               Cell 
               'VerticalAlignment 
             ) 
           ) 
          VerticalAlignment 
           (cond ((= VerticalAlignment -4160) 0) ;_ 上 
                 ((= VerticalAlignment -4108) 1) ;_ 中 
                 (t 2) ;_ 下 
           ) 
          DXF71        (nth VerticalAlignment 
                     (nth HorizontalAlignment dxf71data) 
                ) 
          DXF62        (vlxls-color-eci->aci 
                  (vlax-variant-value 
                    (vlax-get-property Font 'colorIndex) 
                  ) 
                ) 
          DXF420 (vlxls-color-eci->truecolor 
                   (vlax-variant-value 
                     (vlax-get-property Font 'colorIndex) 
                   ) 
                 ) 
        ) 
        ;;计算Range的字体 RangeFont i ii char cfont charFont caption f TextVerFlag 
        (setq RangeFont 
               (mapcar 
                 '(lambda (x) (cons x (VLXLS-GET-PROPERTY font x))) 
                 '("NAME"          "SIZE"         "COLORINDEX" 
                   "BOLD"          "ITALIC"         "SUBSCRIPT" 
                   "SUPERSCRIPT"  "UNDERLINE" 
                  ) 
               ) 
        ) 
        (setq DXF7 (cdr (assoc "NAME" RangeFont))) 
        (if (null dxf7) (setq DXF7 StandardFont)) 
        ;;字体 
        (setq textFont (strcat "{\\f" DXF7 "|b0|i0|c134|p0;")) 
        (setq Dxf40 (cdr (assoc "SIZE" RangeFont))) 
        (if (null DXF40) (setq DXF40 StandardFontSize)) 
        ;;字大小 
        (setq textFont (strcat textFont "\\H" (rtos DXF40 2 1) "x;")) 
        ;;加粗 
        (if (equal :vlax-true (cdr (assoc "BOLD" RangeFont))) 
          (setq textfont (strcat textFont "\\W1.2;")) 
          ) 
        ;;倾斜 
        (if (equal :vlax-true (cdr (assoc "ITALIC" RangeFont))) 
          (setq textfont (strcat textFont "\\Q18;")) 
          ) 
        ;;下划线 
        (if (= 2 (cdr (assoc "UNDERLINE" RangeFont))) 
          (setq textfont (strcat textFont "\\L")) 
          ) 
        ;;上标 "SUPERSCRIPT" 
        ;;下标 "SUBSCRIPT" 
        ;;文字是否竖向 
        (setq TextVerFlag 
               (= (GXL-CATCHAPPLY 
                    VLXLS-GET-PROPERTY 
                    (list range "Orientation") 
                  ) 
                  -4166 
               ) 
        ) 
        (if TextVerFlag 
          (progn 
            (setq text (gxl-str->singleonly text)) 
            (setq tmp  (car text) 
                  text (cdr text) 
            ) 
            (foreach a text (setq tmp (strcat tmp "\\P" a))) 
            (setq text tmp) 
          ) 
        ) 
        ;;逐字取样式 
        ;;(setq textFont (strcat textFont (GetRangeTextStyle RANGE RANGEFONT text) "}")) 
         
        (setq text (strcat textFont text "}")) 
 
      ) 
    ) 
    (cond ((null OldRow) (setq OldRow Row)) 
          ((/= OldRow Row) ;_ 换行 
           (if *pageSetUp* 
             (progn 
               (if (member row HPageBreaks) ;_ 换页 
                 (progn 
                   (setq OldRow            Row 
                         StartPoint (polar StartPoint 
                                           (* 1.5 pi) 
                                           oldheight 
                                    ) 
                   ) 
                   (if *Merge* 
                     (progn 
                       (entmake 
                         (list 
                           '(0 . "line") 
                           '(100 . "AcDbEntity") 
                           '(67 . 0) 
                           (cons 8 Blayer) 
                           (cons 62 *defaultColor*) 
                           '(100 . "AcDbLine") 
                           (cons 10 
                                 StartPoint 
 
                           ) 
                           (cons 
                             11 
                             (setq p0 
                                    (polar 
                                      StartPoint 
                                      0 
                                      (* defaultHeight GridScale Totalwide) 
                                    ) 
                             ) 
                           ) 
                           '(210 0.0 0.0 1.0) 
                         ) 
                       ) 
                       (entmake 
                         (list 
                           '(0 . "line") 
                           '(100 . "AcDbEntity") 
                           '(67 . 0) 
                           (cons 8 Blayer) 
                           (cons 62 *defaultColor*) 
                           '(100 . "AcDbLine") 
                           (cons 10 RightTopPt) 
                           (cons 11 p0) 
                           '(210 0.0 0.0 1.0) 
                         ) 
                       ) 
                        
                     ) 
                   ) 
                   ;;输出页脚代吗 
                   (if *pageSetUp* (DrawPageSetUp pagesetup StartPoint nil)) 
                   ;;分组或分块 
                   (cond 
                     ((= 1 *Oprate*) 
                      (setq ss (GXL-SEL-ENTNEXTALL endent)) 
                      (if *CellColor* 
                        (progn 
                          (command "_select" ss "") 
                          (setq s1 (ssget "_p" '((0 . "solid")))) 
                          (if s1 
                            (gxl-MovetoBottom s1) 
                          ) 
                        ) 
                      ) 
                      (gxl-AX:AddUnNameGroup ss) 
                      (setq endent (entlast)) 
                     ) 
                     ((= 2 *Oprate*) 
                      (setq ss (GXL-SEL-ENTNEXTALL endent)) 
                      (if *CellColor* 
                        (progn 
                          (command "_select" ss "") 
                          (setq s1 (ssget "_p" '((0 . "solid")))) 
                          (if s1 
                            (gxl-MovetoBottom s1) 
                          ) 
                        ) 
                      ) 
                      (gxl-BLK-UnBlockBase ss 4) 
                      (setq endent (entlast)) 
                     ) 
                   ) 
 
                      
                   (setq StartPoint (polar StartPoint (* 1.5 pi) PageMargin) 
                         Curpt            StartPoint 
                         RightTopPt (polar StartPoint 0 (* defaultHeight GridScale Totalwide)) 
                         ) ;_ 移动页间距 
                   (setq page (1+ page)) 
                   ;;输出页眉代吗 
                   (if *pageSetUp* (DrawPageSetUp pagesetup StartPoint t)) 
                   ;;输出表头 
                   (if *pageSetUp* (PrintTitleRows cells)) 
                   
                 ) 
                 (setq OldRow          Row 
                       StartPoint (polar StartPoint (* 1.5 pi) oldheight) 
                       Curpt          StartPoint 
                 ) 
               ) 
             ) 
             (setq OldRow     Row 
                   StartPoint (polar StartPoint (* 1.5 pi) oldheight) 
                   Curpt      StartPoint 
             ) 
           ) 
 
            
          ) 
    ) 
 
    (setq oldheight height) 
    (if (not (equal width 0 0.01)) 
      (progn 
    (if Mergep 
      (progn 
        (setq mergeId (mapcar 'vlxls-rangeid 
                              (vlxls-cellid (vlxls-range-getid range)) 
                              ) 
              width1 (* defaultHeight GridScale (VLXLS-GET-PROPERTY range "MergeArea.width")) 
              height1 (* defaultHeight GridScale (VLXLS-GET-PROPERTY range "MergeArea.height")) 
              ) 
        ) 
      (setq width1 width height1 height) 
      ) 
    (if        (or (not Mergep) 
            (and Mergep (equal (car mergeId) (list col row))) 
        ) 
      (progn 
        (setq p0 (polar Curpt (* 1.5 pi) height1) 
              p1 Curpt 
              p2 (polar Curpt 0 width1) 
              p3 (polar p2 (* 1.5 pi) height1) 
              ) ;_ 框的四个角点 左下、左上、右上、右下 
        (if *Merge* 
          (progn 
            (if Horline 
              (progn 
                (if (equal p1 (gxl-dxf HorLine 11) 1e-3) 
                  (gxl-ch_ent HorLine 11 p2) ;_ 更新水平直线末端点 
                  (progn 
                (entmake 
                  (list 
                    '(0 . "line") 
                    '(100 . "AcDbEntity") 
                    '(67 . 0) 
                    (cons 8 Blayer) 
                    (cons 62 *defaultColor*) 
                    '(100 . "AcDbLine") 
                    (cons 10 p1) 
                    (cons 11 p2) 
                    '(210 0.0 0.0 1.0) 
                    ) 
                  ) 
                (setq Horline (entlast)) 
                ) 
                  ) 
               ) 
              (progn 
                (entmake 
                  (list 
                    '(0 . "line") 
                    '(100 . "AcDbEntity") 
                    '(67 . 0) 
                    (cons 8 Blayer) 
                    (cons 62 *defaultColor*) 
                    '(100 . "AcDbLine") 
                    (cons 10 p1) 
                    (cons 11 p2) 
                    '(210 0.0 0.0 1.0) 
                    ) 
                  ) 
                (setq Horline (entlast)) 
                ) 
              ) 
            (if VerLines 
              (progn 
                (if (not 
                      (vl-some 
                      (Function 
                      (lambda (Line) 
                         (if (equal p1 (gxl-dxf Line 11) 1e-3) 
                           (gxl-ch_ent Line 11 p0) ;_ 更新垂直直线末端点 
                           ) 
                         ) 
                      ) 
                      VerLines 
                      ) 
                    ) 
                  (progn 
                    (entmake 
                      (list 
                        '(0 . "line") 
                        '(100 . "AcDbEntity") 
                        '(67 . 0) 
                        (cons 8 Blayer) 
                        (cons 62 *defaultColor*) 
                        '(100 . "AcDbLine") 
                        (cons 10 p1) 
                        (cons 11 p0) 
                        '(210 0.0 0.0 1.0) 
                        ) 
                      ) 
                    (setq VerLines (cons (entlast) VerLines)) 
                    ) 
                  ) 
                ) 
              (progn 
                (entmake 
                  (list 
                    '(0 . "line") 
                    '(100 . "AcDbEntity") 
                    '(67 . 0) 
                    (cons 8 Blayer) 
                    (cons 62 *defaultColor*) 
                    '(100 . "AcDbLine") 
                    (cons 10 p1) 
                    (cons 11 p0) 
                    '(210 0.0 0.0 1.0) 
                    ) 
                  ) 
                (setq VerLines (cons (entlast) VerLines)) 
                ) 
              ) 
            ) 
          (entmake 
            (list 
              '(0 . "LWPOLYLINE") 
              '(100 . "AcDbEntity") 
              '(67 . 0) 
              (cons 8 BLayer) 
              (cons 62 *defaultColor*) 
              '(100 . "AcDbPolyline") 
              '(90 . 4) 
              '(70 . 1) 
              '(43 . 0.0) 
              '(38 . 0.0) 
              '(39 . 0.0) 
              (cons 10 p0) 
              (cons 10 p1) 
              (cons 10 p2) 
              (cons 10 p3) 
              '(210 0.0 0.0 1.0) 
              ) 
            ) 
          ) 
        (if *CellColor* ;_ 绘制背景颜色 
          (progn 
            (if        (/= -4142 
                    (setq Interiorcolor 
                           (VLXLS-GET-PROPERTY 
                             range 
                             "Interior.ColorIndex" 
                           ) 
                    ) 
                ) 
              (progn 
                (setq Interiorcolor        (VLXLS-COLOR-ECI->ACI Interiorcolor) 
                      Interiortruecolor        (VLXLS-COLOR-ECI->TRUECOLOR 
                                          Interiorcolor 
                                        ) 
                ) 
                (entmake 
                  (vl-remove 
                    nil 
                    (list 
                      '(0 . "SOLID") 
                      '(100 . "AcDbEntity") 
                      '(67 . 0) 
                      (cons 8 BLayer) 
                      (cons 62 Interiorcolor) 
                      ;|(if (not (or (= 256 Interiorcolor) 
                                   (= 0 Interiortruecolor) 
                               ) 
                          ) 
                        (cons 420 Interiortruecolor) 
                      )|; 
                      '(100 . "AcDbTrace") 
                      (cons 10 p0) 
                      (cons 11 p1) 
                      (cons 12 p3) 
                      (cons 13 p2) 
                      '(210 0.0 0.0 1.0) 
                    ) 
                  ) 
                ) 
              ) 
            ) 
          ) 
        ) 
        (if (/= "" text) 
          (progn 
            (setq textpt (nth (1- DXF71) (Get9JustPts p0 p2))) 
            (cond ((= 0 HorizontalAlignment) ;_ 左对齐 
                   (setq textpt (polar textpt 0 (* height 0.1))) 
                  ) 
                  ((= 2 HorizontalAlignment) ;_ 右对齐 
                   (setq textpt (polar textpt pi (* height 0.1))) 
                  ) 
            ) 
            (cond 
              ((= 0 VerticalAlignment) ;_ 上对齐 
               (setq textpt (polar textpt (* 1.5 pi) (* height 0.1))) 
              ) 
              ((= 2 VerticalAlignment) ;_ 下对齐 
               (setq textpt (polar textpt (* 0.5 pi) (* height 0.1))) 
              ) 
            ) 
            (entmake 
              (vl-remove 
                nil 
                (list 
                  (cons 0 "MTEXT") 
                  '(100 . "AcDbEntity") 
                  '(67 . 0) 
                  (cons 8 TLayer) 
                  (if *AnnoColor* 
                    (cons 62 dxf62) 
                    (cons 62 *defaultColor*) 
                  ) 
                  ;|(if (and *AnnoColor* 
                           (not (or (= 256 dxf62) (= 0 dxf420))) 
                      ) 
                    (cons 420 dxf420) 
                  )|; 
                  '(100 . "AcDbMText") 
                  (cons 10 textpt) 
                  (cons 40 defaultHeight) 
                  (cons 41 width1) 
                  ;(cons 50 0) 
                  ;;'(46 . 0.0) 
                  (cons 71 DXF71) 
                  (cons 72 5) 
                  (cons 1 text) 
                  (cons 7 "Standard") 
                  '(210 0.0 0.0 1.0) 
                  '(11 1.0 0.0 0.0) 
                  '(50 . 0.0) 
                  '(73 . 1) 
                ) 
              ) 
            ) 
          ) 
        ) 
      ) 
    ) 
    (setq Curpt (polar Curpt 0 width)) 
    ) 
      ) 
    ) ;_ t 
     ) ;_ cond 
  ) 
 (GXL-SYS-PROGRESS-DONE) 
 (if *Merge* 
   (progn 
     (if *pageSetUp* 
       (setq dd (* PageMargin (* (length HPAGEBREAKS)))) 
       (setq dd 0) 
       ) 
            (entmake 
              (list 
                '(0 . "line") 
                '(100 . "AcDbEntity") 
                '(67 . 0) 
                (cons 8 Blayer) 
                (cons 62 *defaultColor*) 
                '(100 . "AcDbLine") 
                (if *pageSetUp* 
                  (cons 10 (setq p0 RightTopPt)) 
                  (cons        10 
                        (setq 
                          p0 (polar BasePoint 
                                    0 
                                    (* defaultHeight GridScale Totalwide) 
                             ) 
                        ) 
                  ) 
                ) 
                (cons 11 p3) 
                ;(cons 11 (setq p1 (polar p0 (* 1.5 pi) (+ dd (* defaultHeight GridScale Totalheight))))) 
                '(210 0.0 0.0 1.0) 
                ) 
              ) 
            (entmake 
              (list 
                '(0 . "line") 
                '(100 . "AcDbEntity") 
                '(67 . 0) 
                (cons 8 Blayer) 
                (cons 62 *defaultColor*) 
                '(100 . "AcDbLine") 
                (cons 10 (polar p3 pi (* defaultHeight GridScale Totalwide))) 
                (cons 11 p3) 
                '(210 0.0 0.0 1.0) 
                ) 
              ) 
            (setq p3 (polar p2 (* 1.5 pi) height1)) 
            ) 
   ) 
   ;;输出页脚代吗 
    (if *pageSetUp* (DrawPageSetUp pagesetup StartPoint nil)) 
 (setq ss (GXL-SEL-ENTNEXTALL endent)) 
 (if *CellColor* 
   (progn 
     (command "_select" ss "") 
     (setq s1 (ssget "_p" '((0 . "solid")))) 
     (if s1 
       (gxl-MovetoBottom s1) 
       ) 
     ) 
   ) 
 (cond 
     ((= 1 *Oprate*) 
      (gxl-AX:AddUnNameGroup ss) 
      ) 
     ((= 2 *Oprate*) 
      (gxl-BLK-UnBlockBase ss 4) 
      ) 
     ) 
     (vlax-release-object *xlapp*) 
     ) 
    ) 
  (reerr) 
(princ) 
)

hao3ren · 发表于 2013-6-9 13:43

G版的东西一定要顶

stoyer · 发表于 2013-6-9 14:43

G版的强贴，收藏关注中

hbumen · 发表于 2016-6-20 15:14

正在学习 excel和cad的交互操作，可惜没权限下载这个附件。。。

hao3ren · 发表于 2013-6-9 13:58

暂时发现两个问题，1.表头没有合并居中的话会全部挤在第一个单元格，没有表格线的单元格全部加入了边框线. 2.表格较长时无法绘制完成，直接跳出了，显示如下
X2C
放置位置:
输入表格宽度<25733.01>:
参数类型错误: numberp: nil
现附上测试的表格和图片

kwok · 发表于 2013-6-9 13:42

看起来很牛，支持分享，谢谢!

lpl · 发表于 2013-6-9 13:44

不错，学习了

OWEN7 · 发表于 2013-6-9 13:47

精华帖首页留名。好像用处不大，研究还可以

仲文玉 · 发表于 2013-6-9 13:52

好工具，好长的代码。

hao3ren · 发表于 2013-6-9 13:59

对了，还有上标好像不支持

Gu_xl · 发表于 2013-6-9 14:20

hao3ren 发表于 2013-6-9 13:58
暂时发现两个问题，1.表头没有合并居中的话会全部挤在第一个单元格，没有表格线的单元格全部加入了边框线. ...

本程序没有考虑表格的边框情况，所有单元格均加边框！
单元格文字的局部样式，也没有考虑！
出错的Bug已修改！

账号		自动登录	找回密码
密码			注册

[【Gu_xl】] ExCel表格->AutoCAD表格(源码公布)

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

相关帖子

本帖子中包含更多资源

评分

点评