Excel2cad

(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)
(DE

FUN _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 "Ex

cel2CAD\\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@https://www.wendangku.net/doc/619701547.html,\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"
)
)
)
(p

rogn
(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) = #
; BlackAndWhite = 0
; BottomMargin = 70.8661
; CenterFooter = "&\"幼圆,加粗\"&16页脚中&N第&P页"
; CenterFooterPicture (RO) = #
; CenterHeader = "页眉中"
; CenterHeaderPicture (RO) = #
; CenterHorizontally = 0
; CenterVertically = 0
; Creator (RO) = 1480803660
; DifferentFirstPageHeaderFooter = 0
; Draft = 0
; EvenPage (RO) = #
; FirstPage (RO) = #
; FirstPageNumber = -4105
; FitToPagesTall = 1
; FitToPagesWide = 1
; FooterMargin = 36.8504
; HeaderMargin = 36.8504
; LeftFooter = "&\"楷体,常规\"&14页&\"楷体,加粗 倾斜\"脚&\"楷体,常规\"左"
; LeftFooterPicture (RO) = #
; LeftHeader = "页眉左"
; LeftHeaderPicture (RO) = #
; LeftMargin = 53.8583
; OddAndEvenPagesHeaderFooter = 0
; Order = 1.0
; Orientation = 1.0
; Pages (RO) = #
; PaperSize = 9.0
; Parent (RO) = #
; PrintArea = "$A$1:$N$105"
; PrintComments = -4142
; PrintErrors = 0
; PrintGridlines = 0
; PrintHeadings = 0
; PrintNotes = 0
; PrintQuality = ...不显示带索引的内容...
; PrintTitleColumns = ""
; PrintTitleRows = "$1:$3"
; RightFooter = "&\"楷体,加粗\"&KFF0000页脚右"
; RightFooterPicture (RO) = #
; RightHeader = "页眉右"
; RightHeaderPicture (RO) = #
; 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 fon

tname
(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 Grid

Scale (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 "Stand

ard")
'(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请重新设置页面