原创：Vlisp创建图元（慢慢更新）积少成多（2014.8.31更新）

染指_红颜笑

[sell]

1. (setq *doc* (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument))(setq *MsDoc* (Vlax-Get *doc* 'ModelSpace))
   
2. ;
   
3. ;---------------------------=={ Vlisp创建对象 }==---------------------------------;
   
4. ;
   
5. ;---------------------------------------------------------------------------------;
   
6. ;  此函数为晓东CAD论坛首发，你可以复制适当传播，但请保留作者信息，转载务必注明出处;
   
7. ;---------------------------------------------------------------------------------;
   
8. ;  Author: Abner, Copyright@2014                                                        
   
9. ;---------------------------------------------------------------------------------;
   
10. ;  Version:  1.0    -    2014.8.31                                                         
    
11. ;---------------------------------------------------------------------------------;
    
12. ;                                                                                 ;
    
13. ;---------------------------------------------------------------------------------;
    
14. (defun Xk:Double(lst / point pts)
    
15.     (setq pts (vlax-make-safearray vlax-vbDouble (cons 0 (- (length lst) 1))))
    
16.         (vlax-safearray-fill pts lst)
    
17. )
    
18. 
    
19. ;---------------------------------------------------------------------------------;
    
20. (defun xk:AddPoint (/ lst1 pt)
    
21.         (setq lst1 '())
    
22.         (while (setq pt (getpoint "\n请指定点："))
    
23.                 (setq lst1 (append lst1 pt))
    
24.         )
    
25. )
    
26. 
    
27. (defun xk:if-layer (lay);判断图层是否一致
    
28.         (equal lay (Vlax-Get (Vlax-Get *doc* 'ActiveLayer) 'Name))
    
29. )
    
30. 
    
31. ;---------------------------------------------------------------------------------;
    
32. ;  创建多线对象
    
33. (defun Xk:AddMLine (pts Lay /  safe AddMLine)
    
34.         (setq safe (Xk:Double pts))
    
35.         (setq AddMLine (Vlax-Invoke-Method  *MsDoc* 'AddMLine safe))
    
36.         (if (/= (xk:if-layer AddMLine) t)
    
37.                 (Vlax-Put-Property AddMLine 'Layer Lay)
    
38.         )
    
39.         (princ)
    
40. )
    
41. (Xk:AddMLine (xk:AddPoint) "图层1")
    
42. ;---------------------------------------------------------------------------------;
    
43. ;  创建直线对象
    
44. (defun Xk:AddLine (pt1 pt2 Lay / AddLine)
    
45.         (setq AddLine (Vlax-Invoke-Method  *MsDoc* 'AddLine (vlax-3d-point pt1) (vlax-3d-point pt2)))
    
46.         (if (/= (xk:if-layer Lay) t)
    
47.                 (Vlax-Put-Property AddLine 'Layer Lay)
    
48.         )
    
49.         (princ)
    
50. )
    
51. 
    
52. (Xk:AddLine (getpoint) (getpoint) "图层1")
    
53. ;---------------------------------------------------------------------------------;
    
54. ;  创建多段线对象
    
55. (defun Xk:AddPolyline (pts Lay / safe AddPolyline)
    
56.         (setq safe (Xk:Double pts))
    
57.         (setq AddPolyline (Vlax-Invoke-Method *MsDoc* 'AddPolyline safe))
    
58.         (if (/= (xk:if-layer AddPolyline) t)
    
59.                 (Vlax-Put-Property AddPolyline 'Layer Lay)
    
60.         )
    
61.         (princ)
    
62. )
    
63. 
    
64. (Xk:AddPolyline (xk:AddPoint) "图层1")
    
65. ;---------------------------------------------------------------------------------;;  创建单行文字
    
66. (defun Xk:AddText (pt txt width lay / AddText var)
    
67.         (setq var (vlax-3d-point pt))
    
68.         (setq AddText (Vlax-Invoke-Method *MsDoc* 'AddText txt var width))
    
69.         (if (/= (xk:if-layer AddText) t)
    
70.                 (Vlax-Put-Property AddText 'Layer Lay)
    
71.         )
    
72.         (princ)
    
73. )
    
74. 
    
75. (Xk:AddText (getpoint "\n指定文字插入点：") (getstring "\n输入文字：") 7 "图层1")
    
76. ;---------------------------------------------------------------------------------;、
    
77. ;  创建多行文字
    
78. (defun Xk:AddMText (pt width txt lay / AddMText var)
    
79.         (setq var (vlax-3d-point pt))
    
80.         (setq AddMText (Vlax-Invoke-Method *MsDoc* 'AddMText var width txt))
    
81.         (if (/= (xk:if-layer AddMText) t)
    
82.                 (Vlax-Put-Property AddMText 'Layer Lay)
    
83.         )
    
84.         (princ)
    
85. )
    
86. 
    
87. (Xk:AddMText (getpoint "\n指定文字插入点：") 0 (getstring "\n输入文字：") "图层1")
    
88. ;---------------------------------------------------------------------------------;

(setq *doc* (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument))(setq *MsDoc* (Vlax-Get *doc* 'ModelSpace))<br /> ;<br /> ;---------------------------=={ Vlisp创建对象 }==---------------------------------;<br /> ;<br /> ;---------------------------------------------------------------------------------;<br /> ;  此函数为晓东CAD论坛首发，你可以复制适当传播，但请保留作者信息，转载务必注明出处;<br /> ;---------------------------------------------------------------------------------;<br /> ;  Author: Abner, Copyright@2014                                                        <br /> ;---------------------------------------------------------------------------------;<br /> ;  Version:  1.0    -    2014.8.31                                                         <br /> ;---------------------------------------------------------------------------------;<br /> ;                                                                                 ;<br /> ;---------------------------------------------------------------------------------;<br /> (defun Xk:Double(lst / point pts)<br />     (setq pts (vlax-make-safearray vlax-vbDouble (cons 0 (- (length lst) 1))))<br />         (vlax-safearray-fill pts lst)<br /> )<br /> <br /> ;---------------------------------------------------------------------------------;<br /> (defun xk:AddPoint (/ lst1 pt)<br />         (setq lst1 '())<br />         (while (setq pt (getpoint "\n请指定点："))<br />                 (setq lst1 (append lst1 pt))<br />         )<br /> )<br /> <br /> (defun xk:if-layer (lay);判断图层是否一致<br />         (equal lay (Vlax-Get (Vlax-Get *doc* 'ActiveLayer) 'Name))<br /> )<br /> <br /> ;---------------------------------------------------------------------------------;<br /> ;  创建多线对象<br /> (defun Xk:AddMLine (pts Lay /  safe AddMLine)<br />         (setq safe (Xk:Double pts))<br />         (setq AddMLine (Vlax-Invoke-Method  *MsDoc* 'AddMLine safe))<br />         (if (/= (xk:if-layer AddMLine) t)<br />                 (Vlax-Put-Property AddMLine 'Layer Lay)<br />         )<br />         (princ)<br /> )<br /> (Xk:AddMLine (xk:AddPoint) "图层1")<br /> ;---------------------------------------------------------------------------------;<br /> ;  创建直线对象<br /> (defun Xk:AddLine (pt1 pt2 Lay / AddLine)<br />         (setq AddLine (Vlax-Invoke-Method  *MsDoc* 'AddLine (vlax-3d-point pt1) (vlax-3d-point pt2)))<br />         (if (/= (xk:if-layer Lay) t)<br />                 (Vlax-Put-Property AddLine 'Layer Lay)<br />         )<br />         (princ)<br /> )<br /> <br /> (Xk:AddLine (getpoint) (getpoint) "图层1")<br /> ;---------------------------------------------------------------------------------;<br /> ;  创建多段线对象<br /> (defun Xk:AddPolyline (pts Lay / safe AddPolyline)<br />         (setq safe (Xk:Double pts))<br />         (setq AddPolyline (Vlax-Invoke-Method *MsDoc* 'AddPolyline safe))<br />         (if (/= (xk:if-layer AddPolyline) t)<br />                 (Vlax-Put-Property AddPolyline 'Layer Lay)<br />         )<br />         (princ)<br /> )<br /> <br /> (Xk:AddPolyline (xk:AddPoint) "图层1")<br /> ;---------------------------------------------------------------------------------;;  创建单行文字<br /> (defun Xk:AddText (pt txt width lay / AddText var)<br />         (setq var (vlax-3d-point pt))<br />         (setq AddText (Vlax-Invoke-Method *MsDoc* 'AddText txt var width))<br />         (if (/= (xk:if-layer AddText) t)<br />                 (Vlax-Put-Property AddText 'Layer Lay)<br />         )<br />         (princ)<br /> )<br /> <br /> (Xk:AddText (getpoint "\n指定文字插入点：") (getstring "\n输入文字：") 7 "图层1")<br /> ;---------------------------------------------------------------------------------;、<br /> ;  创建多行文字<br /> (defun Xk:AddMText (pt width txt lay / AddMText var)<br />         (setq var (vlax-3d-point pt))<br />         (setq AddMText (Vlax-Invoke-Method *MsDoc* 'AddMText var width txt))<br />         (if (/= (xk:if-layer AddMText) t)<br />                 (Vlax-Put-Property AddMText 'Layer Lay)<br />         )<br />         (princ)<br /> )<br /> <br /> (Xk:AddMText (getpoint "\n指定文字插入点：") 0 (getstring "\n输入文字：") "图层1")<br /> ;---------------------------------------------------------------------------------;

[/sell]

q3_2006

只有这么几个...{:soso_e120:}

HLCAD

“10D豆”不多，性质可不一样。已有高手做得很全了的。

染指_红颜笑

HLCAD 发表于 2014-8-29 07:59
“10D豆”不多，性质可不一样。已有高手做得很全了的。

“很全”，在哪里？

芦苇芦苇

狠心花了10块，却看不懂，赶紧加油学习啦！！！

染指_红颜笑

芦苇芦苇 发表于 2014-9-5 14:22
狠心花了10块，却看不懂，赶紧加油学习啦！！！

这是用VBA的方法创建对象，比组码更方便，直观，等空下来我在继续完善。

kkt123

:@后来才知:@

taoyi0727

又是要100才能看  哎