- 积分
- 90646
- 明经币
- 个
- 注册时间
- 2005-3-31
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
本帖最后由 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)
- )
|
本帖子中包含更多资源
您需要 登录 才可以下载或查看,没有账号?注册
x
评分
-
查看全部评分
"觉得好,就打赏"
共1人打赏
|