[原创] Excel表格转CAD表格源码

admin · 发表于 2024-2-17 20:32:41

;;;--------------------------------------------------;;;
;;;Range对象的几个属性和方法： ;;;
;;;--------------------------------------------------;;;
;;;属性： ;;;
;;; Address----地址，如"A
1" "A
1:C
4" ;;;
;;; 这个属性需要三个参数： ;;;
;;; :vlax-true :vlax-true 1 ;;;
;;; Borders----单元格边框 ;;;
;;; Characters----返回单元格字符串中的单个字符对象 ;;;
;;; 两个参数 start length ;;;
;;; Borders----单元格边框 ;;;
;;; Column----返回指定区域第一列的列号 ;;;
;;; Columns----所有列集合 ;;;
;;; End----指定区域尾端的单元格 ;;;
;;; -4121 向下 -4159 向左 -4161 向右 -4162 向上 ;;;
;;; HorizontalAlignment----水平对齐方式 ;;;
;;; 1 常规 -4131 靠左 -4108 居中 -4152 靠右 ;;;
;;; 5 填充 -4130 两端 7 跨列居中 -4117 分散 ;;;
;;; IndentLevel----缩进 0--15 ;;;
;;; MergeArea----返回Range对象，如果单元格不被包含合 ;;;
;;; 并格，就返回单元格本身。 ;;;
;;; Next----下一个单元格对象 ;;;
;;; Previous----上一个单元格 ;;;
;;; Range----"A1" "A1:D3" "A
1:B
2" ;;;
;;; Row----返回指定区域第一排 ;;;
;;; Text----返回或设置单元格的文本 ;;;
;;; Value----返回或设置单元格的值 ;;;
;;; Value2----返回或设置单元格的值 ;;;
;;; VerticalAlignment----垂直对齐方式 ;;;
;;; -4160靠上 -4108居中 -4107靠下 -4130两端 -4117分散;;;
;;;--------------------------------------------------;;;
;;;Font字体对象的属性 ;;;
;;; Background: 背景颜色 ;;;
;;; XlBackground常量 ;;;
;;; xlBackgroundAutomatic=-4105 Excel控制背景 ;;;
;;; xlBackgroundOpaque=3 不透明背景 ;;;
;;; xlBackgroundTransparent=2 透明背景 ;;;
;;; Bold: 是否加粗 Boolean值 ;;;
;;; Color: 字体颜色 RGB值 ;;;
;;; ColorIndex: 字体颜色索引号值 ;;;
;;; FontStyle: 字体样式名 string ;;;
;;; Italic: 是否倾斜 Boolean值 ;;;
;;; Name: 字体名 string ;;;
;;; Size: 字号 ;;;
;;; Strikethrough: 中间删除线 Boolean值 ;;;
;;; Subscript: 下标 Boolean值 ;;;
;;; Superscript: 上标 Boolean值 ;;;
;;; TintAndShade: 字体亮度 -1 最暗 1 最亮 ;;;
;;; Underline: 下划线 ;;;
;;; xlUnderlineStyleDouble=-4119 粗双下划线 ;;;
;;; xlUnderlineStyleDoubleAccounting=5 细双下划线 ;;;
;;; xlUnderlineStyleNone=-4142 无下划线 ;;;
;;; xlUnderlineStyleSingle=2 单下划线 ;;;
;;; xlUnderlineStyleSingleAccounting=4 不支持 ;;;
;;;--------------------------------------------------;;;
;;; 替换编辑器设置多行文字的格式 ;;;
;;; \~ 插入不间断空格 ;;;
;;; \\ 插入反斜杠 ;;;
;;; \{...\} 插入大括号 ;;;
;;; \Avalue; 设置对齐方式 ;;;
;;; 0--底端对正 ;;;
;;; 1--居中对正 ;;;
;;; 2--顶端对正 ;;;
;;; \Cvalue; 设置颜色 ;;;
;;; \Ffilename; 设置字体文件 ;;;
;;; \Hvalue; 设置高度 ;;;
;;; \Hvaluex; 设置当前字体高度的倍数 ;;;
;;; \L...\l 打开或关闭下划线 ;;;
;;; \O...\o 打开或关闭删除线(上划线) ;;;
;;; ...\P 结束段落 ;;;
;;; \Qangle; 设置倾斜角度 ;;;
;;; \S...^...; 设置堆叠 ;;;
;;; /--除号 ;;;
;;; #--斜线 ;;;
;;; ^--上下界 ;;;
;;; \Tvalue; 设置字符间距，有效值0.75-4倍 ;;;
;;; \Wvalue; 设置宽度比例 ;;;
;;;--------------------------------------------------;;;
;;;Borders 集合对象的 item 属性 ;;;
;;; (vlax-get-property Borders 'Item xlEdgeLeft) ;;;
;;; 返回一个Border对象 ;;;
;;; xlDiagonalDown = 5 左上角至右下角 ;;;
;;; xlDiagonalUp = 6 左下角至右上角 ;;;
;;; xlEdgeBottom = 9 区域底部 ;;;
;;; xlEdgeLeft = 7 区域左边 ;;;
;;; xlEdgeRight =10 区域右边 ;;;
;;; xlEdgeTop = 8 区域顶部 ;;;
;;; xlInsideHorizontal =12 所有水平边框 ;;;
;;; xlInsideVertical =11 所有垂直边框 ;;;
;;;--------------------------------------------------;;;
;;;Border 对象的 LineStyle 属性 ;;;
;;; (vlax-get-property Border 'LineStyle) ;;;
;;; xlContinuous 1 实线。 ;;;
;;; xlDash -4115 虚线。 ;;;
;;; xlDashDot 4 点划相间线。 ;;;
;;; xlDashDotDot 5 划线后跟两个点。 ;;;
;;; xlDot -4118 点式线。 ;;;
;;; xlDouble -4119 双线。 ;;;
;;; xlLineStyleNone -4142 无线条。 ;;;
;;; xlSlantDashDot 13 倾斜的划线。 ;;;
;;;--------------------------------------------------;;;
;;;--------------------------------- 开始 ---------------------------------;;;
(vl-load-com)
;;;将单位磅转换成毫米
(defun AYL-ConvertUnit (ENumber)
(/ (* ENumber 25.4) 72)
)
;;;将真彩色值转换成RGB三色的表
(defun AYL-i->RGB (c)
(list (lsh c -16)
(lsh (lsh c 16) -24)
(lsh (lsh c 24) -24)
)
)
;;;将RGB转换成真彩色值
;;;(defun AYL-RBG->i (Lst)
;;; (+ (lsh (car Lst) 16)
;;; (lsh (cadr Lst) 8)
;;; (caddr Lst)
;;; )
;;;)
;;;将Excel真彩色值转换成AutoCAD颜色索引号
(defun AYL-tColorCiColor (TrueColor / AcadApp AccVer cObj AppLst ci)
(setq ci nil)
(setq AcadApp (vlax-get-acad-object)
AccVer (strcat "AutoCAD.AcCmColor." (substr (getvar 'AcadVer) 1 2))
)
(setq cObj (vl-catch-all-apply 'vla-getinterfaceobject (list AcadApp AccVer)))
(if (vl-catch-all-error-p cObj)
(vlax-release-object AcadApp)
(progn
(setq AppLst (reverse (AYL-i->RGB TrueColor)))
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-setRGB (cons cObj AppLst))))
(setq ci (vla-get-ColorIndex cObj))
)
(mapcar 'vlax-release-object (list AcadApp cObj))
)
)
ci
)
(defun AYL-GetColorIndex (Int)
(if (member Int '(0 16777215))
(setq Int (- 16777215 Int))
)
(AYL-tColorCiColor Int)
)
;;;--------------- AYL-GetStringProp 函数 ---------------;;;
;;; (AYL-GetStringProp CellObj) ;;;
;;;单元格字符串的属性 ;;;
;;; CellObj 单元格或合并单元格对象 ;;;
;;;返回格式化后的多行文字字符串，或nil。 ;;;
;;;------------------------------------------------------;;;
;;;调用的子函数 ;;;
;;; AYL-ConvertUnit ;;;
;;; AYL-tColorCiColor ;;;
;;;------------------------------------------------------;;;
(defun AYL-GetStringProp (CellObj / string oFont isItalic isBold
vColor vSize vULine sName n CharObj
CurStr sChar isSubscript isSuperscript vColor0 vSize0
sName0 isBold0 isItalic0 vULine0 sChar0 CTsize
)
(if (setq string (vlax-variant-value (vlax-get-property CellObj 'Text)))
(progn
(setq oFont (vlax-get-property CellObj 'Font)
isItalic (vlax-variant-value (vlax-get-property oFont 'Italic))
isBold (vlax-variant-value (vlax-get-property oFont 'Bold))
vColor (vlax-variant-value (vlax-get-property oFont 'Color))
vSize (/ (AYL-ConvertUnit (vlax-variant-value (vlax-get-property oFont 'Size))) 1.35)
vULine (vlax-variant-value (vlax-get-property oFont 'Underline))
sName (vlax-variant-value (vlax-get-property oFont 'Name))
CTsize (getvar 'textsize) ;采用当前默认字体大小
)
(vlax-release-object oFont)
;;如果单元格存在多种颜色时，vColor的值为nil
(if vColor (setq vColor (fix vColor)))
;;---------- 单字符对象处理开始 ----------;;
(setq n 1
CharObj (vlax-get-property CellObj 'Characters n 1)
CurStr ""
*vSize* 0.0 ;采用初始化字符串长度的值
)
(while (and
;;字符对象不支持数字的Text属性
(setq sChar (vl-catch-all-apply 'vlax-get-property (list CharObj 'Text)))
(not (vl-catch-all-error-p sChar))
(/= sChar "")
)
;;将三种特定的字符转换成LISP格式
(cond
((= sChar "{") (setq sChar "\\{"))
((= sChar "}") (setq sChar "\\}"))
((= sChar "\") (setq sChar "\\\"))
(t nil)
)
(setq oFont (vlax-get-property CharObj 'Font)
isSubscript (vlax-variant-value (vlax-get-property oFont 'Subscript))
isSuperscript (vlax-variant-value (vlax-get-property oFont 'Superscript))
vColor0 (fix (vlax-variant-value (vlax-get-property oFont 'Color)))
vSize0 (/ (AYL-ConvertUnit (vlax-variant-value (vlax-get-property oFont 'Size))) 1.35)
*vSize* (+ *vSize* vSize0)
vSize0 (/ vSize0 CTsize)
sName0 (vlax-variant-value (vlax-get-property oFont 'Name))
vULine0 (vlax-variant-value (vlax-get-property oFont 'Underline))
sChar0 sChar
)
(if (not (= isBold :vlax-true)) (setq isBold0 (vlax-variant-value (vlax-get-property oFont 'Bold))))
(if (not (= isItalic :vlax-true)) (setq isItalic0 (vlax-variant-value (vlax-get-property oFont 'Italic))))
(vlax-release-object oFont)
(if (= isSubscript :vlax-true) (setq sChar (strcat "\\A1;\\H" (rtos (* vSize0 0.6)) "x;\\S^" sChar ";"))) ;采用下标
(if (= isSuperscript :vlax-true) (setq sChar (strcat "\\A1;\\H" (rtos (* vSize0 0.6)) "x;\\S" sChar "^;"))) ;采用上标
(cond
((and (/= vULine -4142) (= vULine0 -4142)) (setq sChar (strcat "\\l" sChar)))
((and (= vULine -4142) (/= vULine0 -4142)) (setq sChar (strcat "\\L" sChar)))
(t nil)
)
(and sName0 (/= sName sName0) (setq sChar (strcat "\\F" sName0 ";" sChar)))
(if (= isBold0 :vlax-true) (setq sChar (strcat "\\W1.2;" sChar)))
(if (= isItalic0 :vlax-true) (setq sChar (strcat "\\Q18;" sChar)))
(and (/= vColor vColor0)
(progn
(setq vColor0 (AYL-GetColorIndex vColor0))
(setq sChar (strcat "\\C" (itoa vColor0) ";" sChar))
)
)
(if (not (equal vSize0 (/ vSize CTsize) 0.00001))
(setq sChar (strcat "\\H" (rtos vSize0 2 2) "x;" sChar))
)
(if (/= sChar0 sChar) (setq sChar (strcat "{" sChar "}")))
(setq CurStr (strcat CurStr sChar))
(vlax-release-object CharObj)
(setq n (1+ n)
CharObj (vlax-get-property CellObj 'Characters n 1)
)
) ;采用 end while
(vlax-release-object CharObj)
;;---------- 单字符对象处理结束 ----------;;
(if (= *vSize* 0.0) (setq *vSize* (* vSize (strlen string))))
(setq vSize (/ vSize CTsize))
(if (= CurStr "") (setq CurStr String))
(setq CurStr (strcat "{" CurStr "}"))
(if (/= vULine -4142) (setq CurStr (strcat "\\L" CurStr)))
(if sName (setq CurStr (strcat "\\F" sName ";" CurStr)))
(if (= isBold :vlax-true) (setq CurStr (strcat "\\W1.2;" CurStr)))
(if (= isItalic :vlax-true) (setq CurStr (strcat "\\Q18;" CurStr)))
(if vColor
(progn
;;CAD的颜色转换系统用暗红色代替黑色
(setq vColor (AYL-GetColorIndex vColor))
(setq CurStr (strcat "\\C" (itoa vColor) ";" CurStr))
)
)
(setq CurStr (strcat "\\H" (rtos vSize 2 2) "x;" CurStr))
) ;采用 end progn
) ;采用 end if
)
;;;--------------- AYL-GetBordersPr 函数 ---------------;;;
;;;(AYL-GetBordersPr RangeObj pt0 pt1 pt2 pat) ;;;
;;;获取区域对象的边框属性，并设置给Acad表格相应方框。 ;;;
;;; ;;;
;;;RangeObj Excel区域对象 ;;;
;;;pt0 方框的左上点 ;;;
;;;pt1 方框的右上点 ;;;
;;;pt2 方框的左下点 ;;;
;;;pat 需要处理的边框类型，详细说明如下： ;;;
;;; 1----上边线和左边线； ;;;
;;; 2----右边线； ;;;
;;; 4----下边线； ;;;
;;; 8----对角线。 ;;;
;;;-----------------------------------------------------;;;
;;;调用的子函数： ;;;
;;; AYL-GetColorIndex ;;;
;;;-----------------------------------------------------;;;
(defun AYL-GetBordersPr (RangeObj pt0 pt1 pt2 pat /
oBorders pt3 oBorder1 oBorder2 LnStyle1 LnStyle2
Color1 Color2)
(setq oBorders (vlax-get-property RangeObj 'Borders)
pt3 (list (car pt1) (cadr pt2))
)
;;如果pat参数包含1，就处理边框的上边线和左边线；
;;如果pat参数包含2，就处理边框的右边线；
;;如果pat参数包含4，就处理边框的下边线；
;;如果pat参数包含8，就处理边框的对角线。
(if (= (logand pat 1) 1)
(progn
(setq oBorder1 (vlax-get-property oBorders 'Item 8)
oBorder2 (vlax-get-property oBorders 'Item 7)
LnStyle1 (vlax-variant-value (vlax-get-property oBorder1 'LineStyle))
LnStyle2 (vlax-variant-value (vlax-get-property oBorder2 'LineStyle))
)
(mapcar 'vlax-release-object (list oBorder1 oBorder2))
(if (/= LnStyle1 -4142)
(setq *HLineData* (cons (list pt0 pt1) *HLineData*))
)
(if (/= LnStyle2 -4142)
(setq *VLineData* (cons (list pt0 pt2) *VLineData*))
)
)
)
(if (= (logand pat 2) 2)
(progn
(setq oBorder1 (vlax-get-property oBorders 'Item 10)
LnStyle1 (vlax-variant-value (vlax-get-property oBorder1 'LineStyle))
)
(vlax-release-object oBorder1)
(if (/= LnStyle1 -4142)
(setq *VLineData* (cons (list pt1 pt3) *VLineData*))
)
)
)
(if (= (logand pat 4) 4)
(progn
(setq oBorder1 (vlax-get-property oBorders 'Item 9)
LnStyle1 (vlax-variant-value (vlax-get-property oBorder1 'LineStyle))
)
(vlax-release-object oBorder1)
(if (/= LnStyle1 -4142)
(setq *HLineData* (cons (list pt2 pt3) *HLineData*))
)
)
)
(if (= (logand pat 8) 8)
(progn
(setq oBorder1 (vlax-get-property oBorders 'Item 5)
oBorder2 (vlax-get-property oBorders 'Item 6)
LnStyle1 (vlax-variant-value (vlax-get-property oBorder1 'LineStyle))
LnStyle2 (vlax-variant-value (vlax-get-property oBorder2 'LineStyle))
Color1 (fix (vlax-variant-value (vlax-get-property oBorder1 'Color)))
Color2 (fix (vlax-variant-value (vlax-get-property oBorder2 'Color)))
)
(mapcar 'vlax-release-object (list oBorder1 oBorder2))
(if (/= LnStyle1 -4142)
(progn
(setq Color1 (AYL-GetColorIndex Color1))
(entmakex (list '(0 . "Line") (cons 10 pt0) (cons 11 pt3) (cons 62 Color1)))
)
)
(if (/= LnStyle2 -4142)
(progn
(setq Color2 (AYL-GetColorIndex Color2))
(entmakex (list '(0 . "Line") (cons 10 pt2) (cons 11 pt1) (cons 62 Color2)))
)
)
)
)
(vlax-release-object oBorders)
)
(defun AYL-ModString (k str n / m1 m2 ss)
(cond
((and (setq m1 (vl-string-search "\\H" str n))
(setq m2 (vl-string-search "x;" str m1))
)
(setq ss (substr str (+ 3 m1) (- m2 m1 2)))
(AYL-ModString k (vl-string-subst (rtos (* (atof ss) k)) ss str n) m2)
)
(t str)
)
)
;;;--------------- AYL-FixText 函数 ---------------;;;
;;; (AYL-FixText EnText MinPnt MaxPnt) ;;;
;;;把自动换行的多行文字缩小以取消自动换行 ;;;
;;;------------------------------------------------;;;
;;;这个函数有问题 ;;;
;;;????????????????????????????????????????????????;;;
(defun AYL-FixText (EnText MinPnt MaxPnt / EnData kkkk width)
;;如果文字的高度大于方框的高度
(if (> (cdr (assoc 43 (entget EnText))) (- (cadr MaxPnt) (cadr MinPnt)))
(progn
(setq EnText (vlax-ename->vla-object EnText))
(vla-put-width EnText (* *vSize* 1.25))
(setq kkkk (/ (setq Width (- (car MaxPnt) (car MinPnt)))
(cdr (assoc 42 (setq EnData (entget (vlax-vla-object->ename EnText)))))
)
)
(vla-put-textstring
EnText
(AYL-ModString kkkk (cdr (assoc 1 EnData)) 0)
)
(vla-put-width EnText width)
(vlax-release-object EnText)
)
)
(setq *vSize* nil)
)
;;;--------------- AYL-ControlMA 函数 ---------------;;;
;;;AYL-ControlMA 子函数有两个功能 ;;;
;;;1 绘制文字图元 ;;;
;;;2 返回单元格上边线和左边线的表，边线用点对表表示 ;;;
;;;(AYL-ControlMA RangeObj InitPt) ;;;
;;;RangeObj 合并区域的vla对象 ;;;
;;;InitPt 左上点 ;;;
;;;--------------------------------------------------;;;
;;;调用的子函数： ;;;
;;; AYL-ConvertUnit ;;;
;;; AYL-GetStringProp ;;;
;;; AYL-GetBordersPr ;;;
;;; AYL-FixText (目前还只是个空函数) ;;;
;;;--------------------------------------------------;;;
(defun AYL-ControlMA (RangeObj InitPt / Width Height RetPnt
String HAlign VAlign IndLvl Align MaCells
lusPnt lrsPnt
)
(setq Width (AYL-ConvertUnit (vlax-variant-value (vlax-get-property RangeObj 'Width)))
Height (AYL-ConvertUnit (vlax-variant-value (vlax-get-property RangeObj 'Height)))
lusPnt InitPt
lrsPnt (polar InitPt (* pi 1.5) Height)
RetPnt (polar InitPt 0.0 Width)
String nil
MaCells (vlax-get-property RangeObj 'Cells)
)
(vlax-for Item MaCells
(if (not String)
(setq String (AYL-GetStringProp Item))
)
(vlax-release-object Item)
)
(vlax-release-object MaCells)
(if String
(progn
;;水平对正方式、垂直对正方式、缩进值
(setq HAlign (vlax-variant-value (vlax-get-property RangeObj 'HorizontalAlignment))
VAlign (vlax-variant-value (vlax-get-property RangeObj 'VerticalAlignment))
IndLvl (vlax-variant-value (vlax-get-property RangeObj 'IndentLevel))
IndLvl (* (AYL-ConvertUnit (* IndLvl 19.05)) 1.25)
*isStr* t ;采用临时的全局变量，暂时没用
)
(cond ((and (= HAlign 1)
(numberp (read String))
)
(setq HAlign -4152)
)
((and (= HAlign 1) (not (numberp (read String))))
(setq HAlign -4131)
)
((= HAlign -4130) (setq HAlign -4108))
((= HAlign -4117) (setq HAlign -4108))
((= HAlign 5) (setq HAlign -4108))
(t nil)
)
(cond ((= VAlign -4130) (setq VAlign -4108))
((= VAlign -4117) (setq VAlign -4108))
(t nil)
)
;;文本文字的插入点和对正方式
(cond
((and (= HAlign -4131) (= VAlign -4160))
(setq Align 1
InitPt (polar InitPt 0.0 IndLvl)
)
)
((and (= HAlign -4131) (= VAlign -4108))
(setq Align 4
InitPt (polar InitPt (* pi 1.5) (* Height 0.5))
InitPt (polar InitPt 0.0 IndLvl)
)
)
((and (= HAlign -4131) (= VAlign -4107))
(setq Align 7
InitPt (polar InitPt (* pi 1.5) Height)
InitPt (polar InitPt 0.0 IndLvl)
)
)
((and (= HAlign -4108) (= VAlign -4160))
(setq Align 2
InitPt (polar InitPt 0.0 (* Width 0.5))
)
)
((and (= HAlign -4108) (= VAlign -4108))
(setq Align 5
InitPt (polar InitPt 0.0 (* Width 0.5))
InitPt (polar InitPt (* pi 1.5) (* Height 0.5))
)
)
((and (= HAlign -4108) (= VAlign -4107))
(setq Align 8
InitPt (polar InitPt 0.0 (* Width 0.5))
InitPt (polar InitPt (* pi 1.5) Height)
)
)
((and (= HAlign -4152) (= VAlign -4160))
(setq Align 3
InitPt (polar InitPt 0.0 Width)
InitPt (polar InitPt pi IndLvl)
)
)
((and (= HAlign -4152) (= VAlign -4108))
(setq Align 6
InitPt (polar InitPt 0.0 Width)
InitPt (polar InitPt (* pi 1.5) (* Height 0.5))
InitPt (polar InitPt pi IndLvl)
)
)
((and (= HAlign -4152) (= VAlign -4107))
(setq Align 9
InitPt (polar InitPt 0.0 Width)
InitPt (polar InitPt (* pi 1.5) Height)
InitPt (polar InitPt pi IndLvl)
)
)
(t (setq Align 4))
)
(AYL-FixText
(entmakex
(list
'(0 . "MText")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
(cons 1 String)
(cons 10 InitPt)
(cons 41 (/ Width 1.35))
(cons 71 Align)
)
)
lrsPnt
RetPnt
)
)
) ;采用 end if
(AYL-GetBordersPr RangeObj lusPnt RetPnt lrsPnt 9)
(list (list lusPnt RetPnt) (list lusPnt lrsPnt))
)
;;;--------------- AYL-DrawRange 函数 ---------------;;;
;;;根据点对表绘制直线 ;;;
;;;(AYL-DrawRange DPntsLst) ;;;
;;;DPntsLst 子表是点对表，表示单元格的一条边线 ;;;
;;; 指所有上边线或者所有左边线，顺序是颠倒的 ;;;
;;;--------------------------------------------------;;;
(defun AYL-DrawRange (DPntsLst Cint / Lst0 Lst1 Item0 Item1 Pnt)
(setq Lst0 (reverse DPntsLst)
Lst1 nil
)
;;按顺序将共线的直线合并
(while Lst0
(setq Item0 (car Lst0)
Pnt (cadr Item0)
Lst0 (cdr Lst0)
)
(while (setq
Item1 (car (vl-member-if
(function
(lambda (x)
(equal (distance Pnt (car x)) 0 0.00001)
)
)
Lst0
)
)
)
(setq Pnt (cadr Item1)
Item0 (list (car Item0) Pnt)
Lst0 (vl-remove Item1 Lst0)
)
)
(setq Lst1 (cons Item0 Lst1))
)
;;用Entmakex函数绘制直线
(mapcar
(function
(lambda (x)
(entmakex
(list '(0 . "Line") (cons 10 (car x)) (cons 11 (cadr x)) (cons 62 Cint))
)
)
)
Lst1
)
)
;;;-------------------- AYL-GetExcPr 函数 --------------------;;;
;;; (AYL-GetExcPr Range AlPnt) ;;;
;;; 把指定的Excel表格对象绘制在AutoCAD制图界面 ;;;
;;; Range Excel表格对象，指定要在AutoCAD制图界面绘制的表格 ;;;
;;; AlPnt 制图界面插入点，指定表格的左上点 ;;;
;;;-----------------------------------------------------------;;;
;;; 调用的子函数： ;;;
;;; AYL-ControlMA ;;;
;;; AYL-ConvertUnit ;;;
;;; AYL-DrawRange ;;;
;;; AYL-GetBordersPr ;;;
;;;-----------------------------------------------------------;;;
(defun AYL-GetExcPr (Range AlPnt / Rows CeLst
luPnt Cells MArea MaAddr CeAddr
DPtLst RowH RowW rlPnt ruPnt
*HLineData* *VLineData* *isStr*
n m CellW CellH
)
(setq Rows (vlax-get-property Range 'Rows) ;采用所有行的集合对象
n (vlax-get-property Rows 'Count)
DPtLst nil
CeLst nil
luPnt AlPnt
*HLineData* nil
*VLineData* nil
)
(vlax-for Item0 Rows
(setq Cells (vlax-get-property Item0 'Cells) ;采用每一行所有单元格的集合对象
m (vlax-get-property Cells 'Count)
n (1- n)
*isStr* nil
)
(vlax-for Item1 Cells
;;获取单元格的合并区域，绝对地址
(setq MArea (vlax-get-property Item1 'MergeArea) ;采用单元格被包含的合并区域对象
MaAddr (vlax-get-property MArea 'Address :vlax-true :vlax-true 1) ;采用合并区域的绝对地址
CeAddr (vlax-get-property Item1 'Address :vlax-true :vlax-true 1) ;采用单元格的绝对地址
CellW (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item1 'Width)))
CellH (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item1 'Height)))
m (1- m)
)
(if (= m 0) (AYL-GetBordersPr Item1 AlPnt (polar AlPnt 0.0 CellW) (polar AlPnt (* pi 1.5) CellH) 2))
(if (= n 0) (AYL-GetBordersPr Item1 AlPnt (polar AlPnt 0.0 CellW) (polar AlPnt (* pi 1.5) CellH) 4))
(cond
;;如果地址相同，说明单元格不被包含于合并区域
;;那么，就对此单元格进行文字和边框的处理
((equal MaAddr CeAddr)
(setq DPtLst (cons (AYL-ControlMA MArea luPnt) DPtLst)
luPnt (cadaar DPtLst)
)
)
;;如果地址不相同，而且单元格被包含的合并区域还没被保存
;;那么，就把这个合并区域的绝对地址保存在表CeLst中
;;并对此单元格进行文字和边框的处理
((not (member MaAddr CeLst))
(setq CeLst (append CeLst (list MaAddr)))
(setq DPtLst (cons (AYL-ControlMA MArea luPnt) DPtLst)
luPnt (cadaar DPtLst)
)
)
;;如果地址不相同，单元格被包含的合并区域已经被保存
;;而且单元格不是合并区域的第一行
;;那么，改变左上点前进当前单元格的一个宽度，而不对
;;单元格进行文字和边框的处理
((and (member MaAddr CeLst)
(not (wcmatch CeAddr (strcat "*" (itoa (vlax-get-property MArea 'Row)))))
)
(setq luPnt (polar luPnt 0.0 CellW))
)
(t nil)
)
(mapcar 'vlax-release-object (list Item1 MArea))
(setq AlPnt (polar AlPnt 0.0 CellW))
)
;;换行，把左上点移动到下一行的左上点
(setq RowH (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item0 'Height)))
RowW (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Item0 'Width)))
luPnt (polar (polar luPnt pi RowW) (* pi 1.5) RowH)
AlPnt luPnt
)
(mapcar 'vlax-release-object (list Item0 Cells))
)
(vlax-release-object Rows)
;;根据点对表绘制表格
(if (and (not *HLineData*) (not *VLineData*))
(progn
(mapcar 'AYL-DrawRange (apply 'mapcar (cons 'list DPtLst)) '(8 8))
;;最后绘制使用区域的下边线和右边线
(setq RowH (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Range 'Height)))
RowW (AYL-ConvertUnit (vlax-variant-value (vlax-get-property Range 'Width)))
rlPnt (polar luPnt 0.0 RowW)
ruPnt (polar rlPnt (* pi 0.5) RowH)
)
(entmakex (list '(0 . "Line") (cons 10 luPnt) (cons 11 rlPnt) '(62 . 8)))
(entmakex (list '(0 . "Line") (cons 10 ruPnt) (cons 11 rlPnt) '(62 . 8)))
)
)
(if *HLineData*
(AYL-DrawRange *HLineData* 7)
)
(if *VLineData*
(AYL-DrawRange *VLineData* 7)
)
nil
)
;;;-------------------- 主命令 XlCAc --------------------;;;
;;; auther: 秋寒 ;;;
;;; QQ: 982049859 ;;;
;;;调用 AYL-GetExcPr 子函数 ;;;
;;;------------------------------------------------------;;;
(defun c:XlCAc (/ TtLst ExcApp Wkbk Sheet URange Cells InsPt)
(setq TtLst (list vl-catch-all-apply set
"作者：秋寒" vlax-get-object
+ "QQ：982049859"
vlax-release-object -
"\000\001\002\003\004\005\006\007\010"
vlax-variant-value boole
"????????????????????????????????????"
mapcar entdel
"\011\012\013\014\015\016\017\020\021"
entmakex logand
"\022\023\024\025\026\027\030\031\032"
cons entsel
"作者：秋寒" vlax-for
entget "QQ：982049859"
progn entmake
vl-catch-all-error-p logior
"QQ：982049859" setq
vlax-3d-point getpoint
vla-addLine "QQ：982049859"
defun substr
function getvar
"QQ：982049859" lambda
command polar
distance "QQ：982049859"
not reverse
pi setvar
"QQ：982049859" member
abs strcat
numberp "QQ：982049859"
wcmatch <
append >
"QQ：982049859" cadaar
cdr vl-remove
caddr "QQ：982049859"
* cadddr
car cddr
"QQ：982049859" cadr
= /=
cdddr "QQ：982049859"
itoa read
1- vlax-get-object
"QQ：982049859" vlax-get-acad-object
vlax-get-or-create-object
/ vlax-curve-getstartpoint
"QQ：982049859" fix
vlax-curve-getendpoint
equal vlax-safearray->list
"QQ：982049859" rtos
vl-string->list :vlax-true
vlax-ename->vla-object
"QQ：982049859" vlax-make-variant
vla-getinterfaceobject
vla-setRGB vla-get-modelspace
"QQ：982049859" vla-addMtext
vla-move vl-list->string
vla-get-ActiveDocument
"QQ：982049859" vla-get-ColorIndex
ssget princ
prin1
)
)
;;防破译
(if (apply 'and TtLst)
(progn
;;提示用户先打开被操作的Excel文件，再继续执行
(alert "需要先打开被操作的Excel文件")
(if (setq ExcApp (vlax-get-object "Excel.Application")) ;采用 Excel应用程序对象
(if (setq Wkbk (vlax-get-property ExcApp 'ActiveWorkbook)) ;采用当前工作簿
(progn
(setq Sheet (vlax-get-property Wkbk 'ActiveSheet) ;采用当前工作表
URange (vlax-get-property Sheet 'UsedRange) ;采用当前使用的区域
Cells (vlax-get-property URange 'Cells) ;采用已经使用区域的所有单元格集合
)
;;判断当前工作表是否是空的
(if (and
(= (vlax-get-property Cells 'Count) 1)
(not (vlax-variant-value (vlax-get-property URange 'Value)))
)
(princ "\n当前工作表是空的")
;;如果不是空的，提示用户在制图界面指定插入点
(if (setq InsPt (getpoint "\n指定表格的插入点<左上点>："))
;;根据使用区域对象和插入点绘制表格
(AYL-GetExcPr URange InsPt)
)
)
;;释放对象
(mapcar 'vlax-release-object (list ExcApp Wkbk Sheet URange Cells))
)
(progn (princ "\n没有打开Excel文件") (vlax-release-object ExcApp))
)
)
)
(princ "函数错误")
)
(princ)
)
(princ "\n将Excel表格转换为Acad表格的命令名是：XlCAc")
(princ)
;;;------------------------------ 结束 ------------------------------;;;

复制代码

		自动登录	找回密码
密码			立即注册

[原创] Excel表格转CAD表格 源码

相关帖子

[原创] Excel表格转CAD表格源码