修改仓老师代码，不开图批量拟合二维多段线等高线

树櫴希德

修改仓老师代码，不开图批量拟合二维多段线等高线

1. ;(assoc 0(entget(car(entsel))'("*")) )
   
2. 
   
3. (defun try-getFolder (msg / WinShell shFolder path catchit)
   
4. (setq winshell (vlax-create-object "Shell.Application"))
   
5. (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
   
6. (setq catchit (vl-catch-all-apply
   
7.            '(lambda ()
   
8.              (setq shFolder (vlax-get-property shFolder 'self))
   
9.              (setq path (vlax-get-property shFolder 'path))
   
10.             )
    
11.           )
    
12. )
    
13. (if (vl-catch-all-error-p catchit)
    
14.   nil
    
15.   path
    
16. )
    
17. )
    
18. 
    
19. (defun c:plind123 (/ BANBEN DBX PATH FILES DH STR PT0 PT1 I DWGNAME temp ob obj)
    
20.   (vl-load-com)
    
21. ;(setvar "cmdecho" 0)
    
22.   (initget 1 "D S F 3S")    (setq temp (getkword "(D)不拟合/(S)2次样条拟合/(3S)3次样条拟合/(F)圆弧拟合] <F>"))
    
23.   (setq banben (substr (getvar "acadver") 1 2))
    
24.   ;版本2004-2006返回16,2007-2009返回17,2010-2012返回18,2013返回19
    
25.   (setq dbx (Vlax-Get-Or-Create-Object (strcat "ObjectDBX.AxDbDocument." banben)))
    
26.   (setq path (strcat (try-getFolder "\n 选择图纸所在文件夹名称：") "\\"));文件夹路径
    
27.   (setq files (vl-directory-files path "*.dwg" 1)) ;获取所有文件名
    
28.   
    
29.   (setq i -1)
    
30.   (while (setq dwgname (nth (setq i (1+ i)) files))
    
31.     (vlax-invoke-method dbx 'open (strcat path dwgname))
    
32.     ;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
33.     (vlax-for ob (Vlax-Get dbx 'ModelSpace) ;历遍模型空间集合;;;;;;;;;;;;;;;;;;;;;;;;
    
34.   ; (vlax-3d-point '(100 100 100))
    
35. (cond  ((equal (type ob) 'ENAME) (setq obj (vlax-ename->vla-object ob)))
    
36.   (T (setq obj ob))  )
    
37. 
    
38.       
    
39. (if  (and   (= (vla-get-Layer Obj) "DGX" )  (= (vlax-get-property obj 'ObjectName) "AcDb2dPolyline")   )
    
40. 
    
41.    (progn   
    
42. 
    
43. (cond
    
44. 
    
45.     ((= temp "D")   (vla-put-Type obj  0) (vla-Update obj )   )
    
46. 
    
47.     ((= temp "F")   (vla-put-Type obj  1) (vla-Update obj ))
    
48. 
    
49.     ((= temp "S")   (vla-put-Type obj  2) (vla-Update obj ))
    
50. 
    
51.     ((= temp "3S")   (vla-put-Type obj  3) (vla-Update obj ))
    
52. 
    
53.   )
    
54. 
    
55. 
    
56.      )
    
57. 
    
58. 
    
59.   )
    
60. 
    
61.       
    
62. 
    
63.       ;(vla-move ob (vlax-3d-point pt0)(vlax-3d-point pt1))
    
64.     );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
65. 
    
66.    
    
67.     (vlax-invoke-method dbx 'SaveAs (strcat path dwgname))
    
68.   )  ;;;;;;;;;;;;;;;;;;;;;;;;
    
69.   (vlax-release-object dbx);释放
    
70.   ;(setvar "cmdecho" 1)
    
71.   (princ)
    
72. )
    
73. ;(princ "\n 不开图地形图平移代号坐标运行命令：pydhzb")
    
74. ;(princ "\n 如有疑问或者好的建议请联系老仓测绘上班记QQ:729292370")
    
75. (princ)
    
76. 
    
77. ;(vlax-get-property (vlax-ename->vla-object (car(entsel))) 'ObjectName)
    
78. 
    
79. ;;(vla-get-Layer (vlax-ename->vla-object (car(entsel))))
    
80. ;(vlax-get-property (vlax-ename->vla-object (car(entsel))) ''EntityType)
    
81. 
    
82. ;(vl-cmdf "CONVERTPOLY" "h" (vlax-vla-object->ename (vlax-ename->vla-object (car(entsel)) ))   "" )

;(assoc 0(entget(car(entsel))'("*")) )<br /> <br /> (defun try-getFolder (msg / WinShell shFolder path catchit)<br /> (setq winshell (vlax-create-object "Shell.Application"))<br /> (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))<br /> (setq catchit (vl-catch-all-apply<br />            '(lambda ()<br />              (setq shFolder (vlax-get-property shFolder 'self))<br />              (setq path (vlax-get-property shFolder 'path))<br />             )<br />           )<br /> )<br /> (if (vl-catch-all-error-p catchit)<br />   nil<br />   path<br /> )<br /> )<br /> <br /> (defun c:plind123 (/ BANBEN DBX PATH FILES DH STR PT0 PT1 I DWGNAME temp ob obj) <br />   (vl-load-com)<br /> ;(setvar "cmdecho" 0)<br />   (initget 1 "D S F 3S")    (setq temp (getkword "(D)不拟合/(S)2次样条拟合/(3S)3次样条拟合/(F)圆弧拟合] <F>"))<br />   (setq banben (substr (getvar "acadver") 1 2))<br />   ;版本2004-2006返回16,2007-2009返回17,2010-2012返回18,2013返回19<br />   (setq dbx (Vlax-Get-Or-Create-Object (strcat "ObjectDBX.AxDbDocument." banben)))<br />   (setq path (strcat (try-getFolder "\n 选择图纸所在文件夹名称：") "\\"));文件夹路径<br />   (setq files (vl-directory-files path "*.dwg" 1)) ;获取所有文件名<br />   <br />   (setq i -1)<br />   (while (setq dwgname (nth (setq i (1+ i)) files)) <br />     (vlax-invoke-method dbx 'open (strcat path dwgname))<br />     ;;;;;;;;;;;;;;;;;;;;;;;;;;;<br />     (vlax-for ob (Vlax-Get dbx 'ModelSpace) ;历遍模型空间集合;;;;;;;;;;;;;;;;;;;;;;;;<br />   ; (vlax-3d-point '(100 100 100))<br /> (cond  ((equal (type ob) 'ENAME) (setq obj (vlax-ename->vla-object ob)))<br />   (T (setq obj ob))  )<br /> <br />       <br /> (if  (and   (= (vla-get-Layer Obj) "DGX" )  (= (vlax-get-property obj 'ObjectName) "AcDb2dPolyline")   )<br /> <br />    (progn    <br /> <br /> (cond<br /> <br />     ((= temp "D")   (vla-put-Type obj  0) (vla-Update obj )   )<br /> <br />     ((= temp "F")   (vla-put-Type obj  1) (vla-Update obj ))<br /> <br />     ((= temp "S")   (vla-put-Type obj  2) (vla-Update obj ))<br /> <br />     ((= temp "3S")   (vla-put-Type obj  3) (vla-Update obj ))<br /> <br />   )<br /> <br /> <br />      )<br /> <br /> <br />   )<br /> <br />       <br /> <br />       ;(vla-move ob (vlax-3d-point pt0)(vlax-3d-point pt1))<br />     );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> <br />     <br />     (vlax-invoke-method dbx 'SaveAs (strcat path dwgname))<br />   )  ;;;;;;;;;;;;;;;;;;;;;;;;<br />   (vlax-release-object dbx);释放<br />   ;(setvar "cmdecho" 1)<br />   (princ)<br /> )<br /> ;(princ "\n 不开图地形图平移代号坐标运行命令：pydhzb")<br /> ;(princ "\n 如有疑问或者好的建议请联系老仓测绘上班记QQ:729292370")<br /> (princ)<br /> <br /> ;(vlax-get-property (vlax-ename->vla-object (car(entsel))) 'ObjectName)<br /> <br /> ;;(vla-get-Layer (vlax-ename->vla-object (car(entsel))))<br /> ;(vlax-get-property (vlax-ename->vla-object (car(entsel))) ''EntityType)<br /> <br /> ;(vl-cmdf "CONVERTPOLY" "h" (vlax-vla-object->ename (vlax-ename->vla-object (car(entsel)) ))   "" )

gzxl

我个人喜欢写成这样，感觉代码可读性好些, 0 1 2 3 时间久了都不知道是什么了。
(vla-put-Type obj acSimplePoly)
(vla-put-Type obj acFitCurvePoly)
(vla-put-Type obj acQuadSplinePoly)
(vla-put-Type obj acCubicSplinePoly)

树櫴希德

gzxl 发表于 2023-6-22 09:43
我个人喜欢写成这样，感觉代码可读性好些, 0 1 2 3 时间久了都不知道是什么了。
(vla-put-Type obj acSimp ...

请问大神 dbx 不能使用CAD命令吗？如(vl-cmdf "convertpoly "  (vlax-vla-object->ename  ob) "")
在(vlax-for )下面

树櫴希德

树櫴希德 发表于 2023-6-22 09:55
请问大神 dbx 不能使用CAD命令吗？如(vl-cmdf "convertpoly "  (vlax-vla-object->ename  ob) "")
在(vl ...

【话唠】t18-13nil(158675958)  10:06:24
dbx只是数据库，没有doc环境

【话唠】t18-13nil(158675958)  10:06:32
不能用命令
管理员】LLSheng_73■■■
相当于某个时候对你点名一次，至于你来没来都没事，来了不会和你互动，没来也不会找你也不找人替代你

树櫴希德

1. ;二维多段线与多段线互相转换
   
2. (defun c:tesaa ( / &k1 &kw1 a10 a42 a70 a8 a90 ent ss1 ss2 ss5 x)
   
3. (vl-load-com)
   
4. (princ "\n请选择对象")
   
5. (if (setq &kw1 (ssget '((0 . "*POLYLINE"))))
   
6.   (progn;;1
   
7.    (setq ss1 '())
   
8.    (while (setq &k1 (ssname &kw1 0))
   
9.     (setq &kw1 (ssdel &k1 &kw1) ss1 (cons &k1 ss1))
   
10.    );while
    
11.    
    
12.    (if (setq ss2 (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "POLYLINE")) ss1))
    
13.     (progn;;2
    
14.      (setq ss1 (vl-remove-if '(lambda (x) (member x ss2)) ss1))
    
15.      (while (setq ent (car ss2))
    
16.       (setq ss2 (cdr ss2) ss5 (s1712081 ent))
    
17.       (if (vlax-curve-isClosed ent) (setq a70 '(70 . 1)) (setq a70 '(70 . 0)))
    
18.       (setq a90 (cons 90 (length ss5))
    
19.             ss5 (apply 'append ss5)
    
20.             a8 (assoc 8 ss5)
    
21.             a10 (vl-remove-if-not '(lambda (x) (member (car x) '(10 42))) ss5)
    
22.             ss5 (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") a8 '(100 . "AcDbPolyline") a90 a70 '(38 . 0)) a10)
    
23.       )
    
24.       (entmake ss5)
    
25.       (entdel ent)
    
26.      );while
    
27.     );progn;2
    
28.    );if;2
    
29.    (if (car ss1)
    
30.     (progn
    
31.      (while (setq ent (car ss1))
    
32.       (setq ss1 (cdr ss1) ss5 (entget ent))
    
33.       (setq a70 (assoc 70 ss5)
    
34.             a8 (assoc 8 ss5)
    
35.             a10 (vl-remove-if-not '(lambda (x) (= (car x) 10)) ss5)
    
36.             a42 (vl-remove-if-not '(lambda (x) (= (car x) 42)) ss5)
    
37.             ss5 (mapcar '(lambda (x) (append (list '(0 . "VERTEX") '(100 . "AcDbEntity") '(67 . 0) a8 '(100 . "AcDbVertex") '(100 . "AcDb2dVertex")) x))
    
38.             (mapcar 'cons a10 (mapcar '(lambda (x) (list x a70)) a42)))
    
39.       )
    
40.       (s1712082 ss5 a70 a8)
    
41.       (entdel ent)
    
42.      );while
    
43.     )
    
44.    );if;3
    
45.   );progn;1
    
46. );if;1
    
47. (princ)
    
48. )
    
49. 
    
50. ;entmake生成二维多段线
    
51. (defun s1712082 (ss5 a70 a8 / a70 a8 ed ss5)
    
52. (entmake (list  '(0 . "POLYLINE") '(100 . "AcDbEntity") a8 '(100 . "AcDb2dPolyline") a70))
    
53. (while (setq ed (car ss5))
    
54.   (setq ss5 (cdr ss5))
    
55.   (entmake ed)
    
56. )
    
57. (entmake '((0 . "SEQEND")))
    
58. )
    
59. 
    
60. ;提取二维多段线数据
    
61. (defun s1712081 (e / e ed pts)
    
62.   (if (eq (cdr (assoc 0 (entget e))) "POLYLINE")
    
63.     (progn
    
64.       (while (and (setq e (entnext e))
    
65.                (/= (cdr (assoc 0 (setq ed (entget e)))) "SEQEND")
    
66.              )
    
67.         (setq pts (cons ed pts))
    
68.       )
    
69.     )
    
70.   )
    
71.   (reverse pts)
    
72. )

;二维多段线与多段线互相转换<br /> (defun c:tesaa ( / &k1 &kw1 a10 a42 a70 a8 a90 ent ss1 ss2 ss5 x)<br /> (vl-load-com)<br /> (princ "\n请选择对象")<br /> (if (setq &kw1 (ssget '((0 . "*POLYLINE"))))<br />   (progn;;1<br />    (setq ss1 '())<br />    (while (setq &k1 (ssname &kw1 0))<br />     (setq &kw1 (ssdel &k1 &kw1) ss1 (cons &k1 ss1))<br />    );while<br />     <br />    (if (setq ss2 (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "POLYLINE")) ss1))<br />     (progn;;2<br />      (setq ss1 (vl-remove-if '(lambda (x) (member x ss2)) ss1))<br />      (while (setq ent (car ss2))<br />       (setq ss2 (cdr ss2) ss5 (s1712081 ent))<br />       (if (vlax-curve-isClosed ent) (setq a70 '(70 . 1)) (setq a70 '(70 . 0)))<br />       (setq a90 (cons 90 (length ss5))<br />             ss5 (apply 'append ss5)<br />             a8 (assoc 8 ss5)<br />             a10 (vl-remove-if-not '(lambda (x) (member (car x) '(10 42))) ss5)<br />             ss5 (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") a8 '(100 . "AcDbPolyline") a90 a70 '(38 . 0)) a10)<br />       )<br />       (entmake ss5)<br />       (entdel ent)<br />      );while<br />     );progn;2<br />    );if;2<br />    (if (car ss1)<br />     (progn<br />      (while (setq ent (car ss1))<br />       (setq ss1 (cdr ss1) ss5 (entget ent))<br />       (setq a70 (assoc 70 ss5)<br />             a8 (assoc 8 ss5)<br />             a10 (vl-remove-if-not '(lambda (x) (= (car x) 10)) ss5)<br />             a42 (vl-remove-if-not '(lambda (x) (= (car x) 42)) ss5)<br />             ss5 (mapcar '(lambda (x) (append (list '(0 . "VERTEX") '(100 . "AcDbEntity") '(67 . 0) a8 '(100 . "AcDbVertex") '(100 . "AcDb2dVertex")) x))<br />             (mapcar 'cons a10 (mapcar '(lambda (x) (list x a70)) a42)))<br />       )<br />       (s1712082 ss5 a70 a8)<br />       (entdel ent)<br />      );while<br />     )<br />    );if;3<br />   );progn;1<br /> );if;1<br /> (princ)<br /> )<br /> <br /> ;entmake生成二维多段线<br /> (defun s1712082 (ss5 a70 a8 / a70 a8 ed ss5)<br /> (entmake (list  '(0 . "POLYLINE") '(100 . "AcDbEntity") a8 '(100 . "AcDb2dPolyline") a70))<br /> (while (setq ed (car ss5))<br />   (setq ss5 (cdr ss5))<br />   (entmake ed)<br /> )<br /> (entmake '((0 . "SEQEND")))<br /> )<br /> <br /> ;提取二维多段线数据<br /> (defun s1712081 (e / e ed pts)<br />   (if (eq (cdr (assoc 0 (entget e))) "POLYLINE")<br />     (progn<br />       (while (and (setq e (entnext e))<br />                (/= (cdr (assoc 0 (setq ed (entget e)))) "SEQEND")<br />              )<br />         (setq pts (cons ed pts))<br />       )<br />     )<br />   )<br />   (reverse pts)<br /> )

树櫴希德

不开图批量等高线lwpoly  to  二维poly 并拟合，可以保留南方代码了  "south"

1. ;(setq startPnt(vlax-make-safearray vlax-vbDouble '(0 . 2)))
   
2. ;(vlax-safearray-fill startPnt st_point)
   
3. ;(setq endPnt(vlax-make-safearray vlax-vbDouble '(0 . 2)))
   
4. ;(vlax-safearray-fill endPnt p3)
   
5. ;(setq Line_Obj(vla-AddLine mSpace startPnt endPnt))
   
6. ;(vl-load-com )
   
7. ;(vlax-dump-object(vlax-ename->vla-object(car(entsel)))T)   (entget(car(entsel))'("*"))
   
8.        ;(setq xtype (vlax-make-safearray vlax-vbvariant '(0 . 1)))
   
9. ;(setq xtype (vlax-make-safearray vlax-vbInteger '(0 . 1)))
   
10.    ;(setq xdata (vlax-make-safearray vlax-vbvariant '(0 . 1)))
    
11.          ; (vlax-safearray-fill xtype '(1001 1000))
    
12.           ;(vlax-safearray-fill xdata '("loop" "loop"))
    
13.           ; (vla-setxdata (vlax-ename->vla-object(car(entsel))) xtype xdata)
    
14. 
    
15. ;(-3 ("loop" (1000 . "loop")))
    
16. 
    
17. (defun c:GetX (/ xType XData)
    
18. (vl-load-com)
    
19. (setq appid "south")
    
20. (setq vlaobj (car(entsel"\\n）选择环：")))
    
21. (cond ((= (type vlaObj) 'ENAME) (SETQ vlaObj (vlax-ename->vla-object vlaObj)))
    
22. ((= (type vlaObj) 'VLA-OBJECT) (SETQ vlaObj vlaObj))
    
23. (t (setq olderror *error*)))
    
24. (vla-getxdata vlaObj appid 'xType 'xData) ;；此处监视时，其值为nil
    
25. (mapcar '(lambda (key val) (cons key (VLAX-VARIANT-value val)))
    
26. (vlax-safearray->list xType)
    
27. (vlax-safearray->list xData)
    
28. )
    
29. )
    
30. 
    
31. ;(VLAX-VARIANT-value (vlax-safearray->list xData))
    
32. 
    
33. ; (apply 'append(mapcar '(lambda (x) (list (cdr x))) (mapcar '(lambda (key val) (cons key (VLAX-VARIANT-value val)))(vlax-safearray->list xType)(vlax-safearray->list xData)))) ;;; ("SOUTH" "202101")
    
34. 
    
35. ;(apply 'append '(("SOUTH") ("202101")))
    
36. 
    
37. ; (mapcar '(lambda (x) (append (cdr x))) '((1001 . "SOUTH") (1000 . "202101")) )
    
38. ;注意APPID是一个已经注册的应用程序名称..是REGAPP以后的名称,是字符串.
    
39. 
    
40. 
    
41. (defun zhnfbm (oldobj newobj / xType  xData  xType1 xData1)
    
42.     (vl-load-com)
    
43. (setq appid "south")
    
44.   (vla-getxdata oldobj appid 'xType 'xData) ;；此处监视时，其值为nil  
    
45. (setq xType1 (vlax-safearray->list xType) )
    
46. 
    
47. (setq xData1 (apply 'append(mapcar '(lambda (x) (list (cdr x))) (mapcar '(lambda (key val) (cons key (VLAX-VARIANT-value val)))(vlax-safearray->list xType)(vlax-safearray->list xData)))) )
    
48. 
    
49. (setq xtype (vlax-make-safearray vlax-vbInteger '(0 . 1)))
    
50.    (setq xdata (vlax-make-safearray vlax-vbvariant '(0 . 1)))
    
51.           (vlax-safearray-fill xtype xType1)
    
52.           (vlax-safearray-fill xdata xData1)
    
53.            (vla-setxdata newobj xtype xdata)
    
54.   
    
55.   )
    
56. 
    
57. ;; (zhnfbm (vlax-ename->vla-object(car(entsel)))  (vlax-ename->vla-object(car(entsel)))  )
    
58. 
    
59. 
    
60. 
    
61. 
    
62.   ;(lw2pl (car(entsel)))   (entget (car(entsel))'("*"))
    
63. 
    
64. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
65. (defun vxs (e / i v lst ppp)
    
66.   (setq i 0)
    
67.   (while
    
68.     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
    
69.      (setq lst (cons v lst))
    
70.   )
    
71.   (setq ppp (reverse lst) )
    
72. (append (list(vlax-curve-getpointatparam e 0)) ppp )
    
73.   
    
74.   );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    
75. (defun mk222 ( en mSpace  / plst plst1 points mSpace )
    
76. (vl-load-com)
    
77. ;(vla-AddPolyline (vxs(car(entsel))))   (vla-addlightweightpolyline (vxs(car(entsel))))
    
78. ;(setq plst nil)
    
79. (setq plst (vxs en) )
    
80. 
    
81. (setq plst1 (apply 'append plst
    
82.                   
    
83.             ) )
    
84. (setq points
    
85.        (vlax-make-safearray
    
86.          vlax-vbdouble
    
87.          (cons 0 (- (length plst1) 1))
    
88.        )
    
89. )
    
90. ;(vlax-safearray-fill points plst1)
    
91. 
    
92. (setq points (vlax-safearray-fill points plst1) )
    
93. 
    
94. (vlax-invoke-method mSpace 'AddPolyline points)
    
95. 
    
96. ;(vla-AddPolyline   ms    points   )
    
97. 
    
98. ;(princ)
    
99. )
    
100. 
     
101. ;(setq ms
     
102.     ;   (vla-get-ModelSpace
     
103.     ;     (vla-get-ActiveDocument
     
104.     ;       (vlax-get-acad-object)
     
105.     ;     )
     
106.   ;     )
     
107. ;)
     
108. 
     
109. 
     
110. 
     
111. 
     
112.   ;(lw2pl (car(entsel)))   (entget (car(entsel))'("*"))
     
113. ;;;;;;;;;;;;;;;;;;;;;;;
     
114. 
     
115. ;(assoc 0(entget(car(entsel))'("*")) )
     
116. 
     
117. (defun try-getFolder (msg / WinShell shFolder path catchit)
     
118. (setq winshell (vlax-create-object "Shell.Application"))
     
119. (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
     
120. (setq catchit (vl-catch-all-apply
     
121.            '(lambda ()
     
122.              (setq shFolder (vlax-get-property shFolder 'self))
     
123.              (setq path (vlax-get-property shFolder 'path))
     
124.             )
     
125.           )
     
126. )
     
127. (if (vl-catch-all-error-p catchit)
     
128.   nil
     
129.   path
     
130. )
     
131. )
     
132. 
     
133. (defun c:mk22 (/ BANBEN DBX PATH FILES DH STR PT0 PT1 I DWGNAME temp ob obj mSpace kd ys tc biaogao kdobj bgobj lyobj ysobj objobj)
     
134. 
     
135. 
     
136. 
     
137. 
     
138.   
     
139.   (vl-load-com)
     
140. ;(setvar "cmdecho" 0)
     
141.   (initget 1 "D S F 3S")    (setq temp (getkword "(D)不拟合/(S)2次样条拟合/(3S)3次样条拟合/(F)圆弧拟合] <F>"))
     
142.   (setq banben (substr (getvar "acadver") 1 2))
     
143.   ;版本2004-2006返回16,2007-2009返回17,2010-2012返回18,2013返回19
     
144.   (setq dbx (Vlax-Get-Or-Create-Object (strcat "ObjectDBX.AxDbDocument." banben)))
     
145.   (setq path (strcat (try-getFolder "\n 选择图纸所在文件夹名称：") "\\"));文件夹路径
     
146.   (setq files (vl-directory-files path "*.dwg" 1)) ;获取所有文件名
     
147.   
     
148.   (setq i -1)
     
149.   (while (setq dwgname (nth (setq i (1+ i)) files))
     
150.     (vlax-invoke-method dbx 'open (strcat path dwgname))
     
151.     ;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
152.      (setq mSpace (Vlax-Get dbx 'ModelSpace)) (vla-SaveAs dbx (strcat path dwgname) )
     
153.     (vlax-for ob  mSpace ;历遍模型空间集合;;;;;;;;;;;;;;;;;;;;;;;;
     
154.   ; (vlax-3d-point '(100 100 100))
     
155.         ;(vla-save dbx)
     
156. (cond  ((equal (type ob) 'ENAME) (setq obj (vlax-ename->vla-object ob)))
     
157.   (T (setq obj ob))  )
     
158. ;(setq circCenter (vlax-3d-point '(2.0 2.0 0.0)))
     
159. ;(vlax-invoke-method mspace 'AddCircle circCenter 3.0)
     
160.       
     
161. (if  (and   (= (vla-get-Layer Obj) "DGX" )  (= (vlax-get-property obj 'ObjectName) "AcDbPolyline")   )
     
162. 
     
163.    (progn
     
164.      
     
165. ;(Setq ms (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'ModelSpace ))
     
166.    ; (mk2d (vlax-vla-object->ename Obj) (Vlax-Get dbx 'ModelSpace))
     
167. ;(vla-put-color obj 1)
     
168.     ;(mk222 OBJ mSpace)
     
169. (setq kd (vlax-get-property Obj  'ConstantWidth))
     
170. (setq ys (vlax-get-property Obj  'color))   
     
171. (setq tc (vlax-get-property Obj  'Layer))
     
172. (setq biaogao (vlax-get-property Obj  'Elevation))
     
173. ;;;;;;;;;;;;
     
174. 
     
175. (setq objobj (mk222 OBJ mSpace))
     
176. (vla-put-ConstantWidth objobj kd)  (vla-put-Elevation objobj biaogao) (vla-put-layer objobj tc) (vla-put-color objobj ys)
     
177. (cond
     
178. 
     
179.     ((= temp "D")   (vla-put-Type objobj  acSimplePoly) (vla-Update objobj )   )
     
180. 
     
181.     ((= temp "F")   (vla-put-Type objobj  acFitCurvePoly) (vla-Update objobj ))
     
182. 
     
183.     ((= temp "S")   (vla-put-Type objobj  acQuadSplinePoly) (vla-Update objobj ))
     
184. 
     
185.     ((= temp "3S")   (vla-put-Type objobj  acCubicSplinePoly) (vla-Update objobj ))
     
186. 
     
187.   )
     
188. (zhnfbm obj  objobj  )
     
189. 
     
190. (vla-delete obj )
     
191. 
     
192. ;(setq kdobj (vla-put-ConstantWidth (mk222 OBJ mSpace) kd))
     
193. ;(setq bgobj (vla-put-Elevation kdobj biaogao))
     
194. ;(setq lyobj (vla-put-layer bgobj tc) )
     
195. ;(setq ysobj (vla-put-color lyobj ys) )
     
196. ;(vla-put-color (vla-put-layer (vla-put-Elevation (vla-put-ConstantWidth (mk222 OBJ mSpace) kd) biaogao)tc) ys)
     
197. ;(vlax-put-property (vlax-put-property (vlax-put-property (vlax-put-property (mk222 OBJ mSpace) 'ConstantWidth kd) 'Layer tc) 'color ys) 'Elevation biaogao)
     
198. 
     
199.    ; (vla-put-Color (mk222 OBJ mSpace) 1)
     
200.     ;(lw2pl (vlax-vla-object->ename Obj))
     
201.      )
     
202. 
     
203. 
     
204.   )
     
205. 
     
206.       
     
207. 
     
208.       ;(vla-move ob (vlax-3d-point pt0)(vlax-3d-point pt1))
     
209.     );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
210. 
     
211.    
     
212.     (vlax-invoke-method dbx 'SaveAs (strcat path dwgname))
     
213.   )  ;;;;;;;;;;;;;;;;;;;;;;;;
     
214.   (vlax-release-object dbx);释放
     
215.   ;(setvar "cmdecho" 1)
     
216.   (princ)
     
217. )
     
218. ;(princ "\n 不开图地形图平移代号坐标运行命令：pydhzb")
     
219. ;(princ "\n 如有疑问或者好的建议请联系老仓测绘上班记QQ:729292370")
     
220. ;(princ)

;(setq startPnt(vlax-make-safearray vlax-vbDouble '(0 . 2)))<br /> ;(vlax-safearray-fill startPnt st_point)<br /> ;(setq endPnt(vlax-make-safearray vlax-vbDouble '(0 . 2)))<br /> ;(vlax-safearray-fill endPnt p3)<br /> ;(setq Line_Obj(vla-AddLine mSpace startPnt endPnt))<br /> ;(vl-load-com )<br /> ;(vlax-dump-object(vlax-ename->vla-object(car(entsel)))T)   (entget(car(entsel))'("*"))<br />        ;(setq xtype (vlax-make-safearray vlax-vbvariant '(0 . 1)))<br /> ;(setq xtype (vlax-make-safearray vlax-vbInteger '(0 . 1)))<br />    ;(setq xdata (vlax-make-safearray vlax-vbvariant '(0 . 1)))<br />          ; (vlax-safearray-fill xtype '(1001 1000))<br />           ;(vlax-safearray-fill xdata '("loop" "loop"))<br />           ; (vla-setxdata (vlax-ename->vla-object(car(entsel))) xtype xdata)<br /> <br /> ;(-3 ("loop" (1000 . "loop")))<br /> <br /> (defun c:GetX (/ xType XData)<br /> (vl-load-com)<br /> (setq appid "south")<br /> (setq vlaobj (car(entsel"\\n）选择环：")))<br /> (cond ((= (type vlaObj) 'ENAME) (SETQ vlaObj (vlax-ename->vla-object vlaObj)))<br /> ((= (type vlaObj) 'VLA-OBJECT) (SETQ vlaObj vlaObj))<br /> (t (setq olderror *error*)))<br /> (vla-getxdata vlaObj appid 'xType 'xData) ;；此处监视时，其值为nil<br /> (mapcar '(lambda (key val) (cons key (VLAX-VARIANT-value val)))<br /> (vlax-safearray->list xType)<br /> (vlax-safearray->list xData)<br /> )<br /> )<br /> <br /> ;(VLAX-VARIANT-value (vlax-safearray->list xData))<br /> <br /> ; (apply 'append(mapcar '(lambda (x) (list (cdr x))) (mapcar '(lambda (key val) (cons key (VLAX-VARIANT-value val)))(vlax-safearray->list xType)(vlax-safearray->list xData)))) ;;; ("SOUTH" "202101")<br /> <br /> ;(apply 'append '(("SOUTH") ("202101")))<br /> <br /> ; (mapcar '(lambda (x) (append (cdr x))) '((1001 . "SOUTH") (1000 . "202101")) )<br /> ;注意APPID是一个已经注册的应用程序名称..是REGAPP以后的名称,是字符串.<br /> <br /> <br /> (defun zhnfbm (oldobj newobj / xType  xData  xType1 xData1)<br />     (vl-load-com)<br /> (setq appid "south")<br />   (vla-getxdata oldobj appid 'xType 'xData) ;；此处监视时，其值为nil  <br /> (setq xType1 (vlax-safearray->list xType) )<br /> <br /> (setq xData1 (apply 'append(mapcar '(lambda (x) (list (cdr x))) (mapcar '(lambda (key val) (cons key (VLAX-VARIANT-value val)))(vlax-safearray->list xType)(vlax-safearray->list xData)))) )<br /> <br /> (setq xtype (vlax-make-safearray vlax-vbInteger '(0 . 1)))<br />    (setq xdata (vlax-make-safearray vlax-vbvariant '(0 . 1)))<br />           (vlax-safearray-fill xtype xType1)<br />           (vlax-safearray-fill xdata xData1)<br />            (vla-setxdata newobj xtype xdata)<br />   <br />   )<br /> <br /> ;; (zhnfbm (vlax-ename->vla-object(car(entsel)))  (vlax-ename->vla-object(car(entsel)))  )<br /> <br /> <br /> <br /> <br />   ;(lw2pl (car(entsel)))   (entget (car(entsel))'("*"))<br /> <br /> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun vxs (e / i v lst ppp)<br />   (setq i 0)<br />   (while<br />     (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))<br />      (setq lst (cons v lst))<br />   )<br />   (setq ppp (reverse lst) )<br /> (append (list(vlax-curve-getpointatparam e 0)) ppp )<br />   <br />   );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> (defun mk222 ( en mSpace  / plst plst1 points mSpace )<br /> (vl-load-com)<br /> ;(vla-AddPolyline (vxs(car(entsel))))   (vla-addlightweightpolyline (vxs(car(entsel))))<br /> ;(setq plst nil)<br /> (setq plst (vxs en) )<br /> <br /> (setq plst1 (apply 'append plst<br />                    <br />             ) )<br /> (setq points<br />        (vlax-make-safearray<br />          vlax-vbdouble<br />          (cons 0 (- (length plst1) 1))<br />        )<br /> )<br /> ;(vlax-safearray-fill points plst1)<br /> <br /> (setq points (vlax-safearray-fill points plst1) )<br /> <br /> (vlax-invoke-method mSpace 'AddPolyline points) <br /> <br /> ;(vla-AddPolyline   ms    points   )<br /> <br /> ;(princ)<br /> )<br /> <br /> ;(setq ms<br />     ;   (vla-get-ModelSpace<br />     ;     (vla-get-ActiveDocument<br />     ;       (vlax-get-acad-object)<br />     ;     )<br />   ;     )<br /> ;)<br /> <br /> <br /> <br /> <br />   ;(lw2pl (car(entsel)))   (entget (car(entsel))'("*"))<br /> ;;;;;;;;;;;;;;;;;;;;;;;<br /> <br /> ;(assoc 0(entget(car(entsel))'("*")) )<br /> <br /> (defun try-getFolder (msg / WinShell shFolder path catchit)<br /> (setq winshell (vlax-create-object "Shell.Application"))<br /> (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))<br /> (setq catchit (vl-catch-all-apply<br />            '(lambda ()<br />              (setq shFolder (vlax-get-property shFolder 'self))<br />              (setq path (vlax-get-property shFolder 'path))<br />             )<br />           )<br /> )<br /> (if (vl-catch-all-error-p catchit)<br />   nil<br />   path<br /> )<br /> )<br /> <br /> (defun c:mk22 (/ BANBEN DBX PATH FILES DH STR PT0 PT1 I DWGNAME temp ob obj mSpace kd ys tc biaogao kdobj bgobj lyobj ysobj objobj)<br /> <br /> <br /> <br /> <br />   <br />   (vl-load-com)<br /> ;(setvar "cmdecho" 0)<br />   (initget 1 "D S F 3S")    (setq temp (getkword "(D)不拟合/(S)2次样条拟合/(3S)3次样条拟合/(F)圆弧拟合] <F>"))<br />   (setq banben (substr (getvar "acadver") 1 2))<br />   ;版本2004-2006返回16,2007-2009返回17,2010-2012返回18,2013返回19<br />   (setq dbx (Vlax-Get-Or-Create-Object (strcat "ObjectDBX.AxDbDocument." banben)))<br />   (setq path (strcat (try-getFolder "\n 选择图纸所在文件夹名称：") "\\"));文件夹路径<br />   (setq files (vl-directory-files path "*.dwg" 1)) ;获取所有文件名<br />   <br />   (setq i -1)<br />   (while (setq dwgname (nth (setq i (1+ i)) files)) <br />     (vlax-invoke-method dbx 'open (strcat path dwgname))<br />     ;;;;;;;;;;;;;;;;;;;;;;;;;;;<br />      (setq mSpace (Vlax-Get dbx 'ModelSpace)) (vla-SaveAs dbx (strcat path dwgname) )<br />     (vlax-for ob  mSpace ;历遍模型空间集合;;;;;;;;;;;;;;;;;;;;;;;;<br />   ; (vlax-3d-point '(100 100 100))<br />         ;(vla-save dbx)<br /> (cond  ((equal (type ob) 'ENAME) (setq obj (vlax-ename->vla-object ob)))<br />   (T (setq obj ob))  )<br /> ;(setq circCenter (vlax-3d-point '(2.0 2.0 0.0))) <br /> ;(vlax-invoke-method mspace 'AddCircle circCenter 3.0) <br />       <br /> (if  (and   (= (vla-get-Layer Obj) "DGX" )  (= (vlax-get-property obj 'ObjectName) "AcDbPolyline")   )<br /> <br />    (progn<br />      <br /> ;(Setq ms (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'ModelSpace ))<br />    ; (mk2d (vlax-vla-object->ename Obj) (Vlax-Get dbx 'ModelSpace))<br /> ;(vla-put-color obj 1)<br />     ;(mk222 OBJ mSpace)<br /> (setq kd (vlax-get-property Obj  'ConstantWidth))<br /> (setq ys (vlax-get-property Obj  'color))    <br /> (setq tc (vlax-get-property Obj  'Layer))<br /> (setq biaogao (vlax-get-property Obj  'Elevation))<br /> ;;;;;;;;;;;;<br /> <br /> (setq objobj (mk222 OBJ mSpace))<br /> (vla-put-ConstantWidth objobj kd)  (vla-put-Elevation objobj biaogao) (vla-put-layer objobj tc) (vla-put-color objobj ys)<br /> (cond<br /> <br />     ((= temp "D")   (vla-put-Type objobj  acSimplePoly) (vla-Update objobj )   )<br /> <br />     ((= temp "F")   (vla-put-Type objobj  acFitCurvePoly) (vla-Update objobj ))<br /> <br />     ((= temp "S")   (vla-put-Type objobj  acQuadSplinePoly) (vla-Update objobj ))<br /> <br />     ((= temp "3S")   (vla-put-Type objobj  acCubicSplinePoly) (vla-Update objobj ))<br /> <br />   )<br /> (zhnfbm obj  objobj  )<br /> <br /> (vla-delete obj )<br /> <br /> ;(setq kdobj (vla-put-ConstantWidth (mk222 OBJ mSpace) kd))<br /> ;(setq bgobj (vla-put-Elevation kdobj biaogao))<br /> ;(setq lyobj (vla-put-layer bgobj tc) )<br /> ;(setq ysobj (vla-put-color lyobj ys) )<br /> ;(vla-put-color (vla-put-layer (vla-put-Elevation (vla-put-ConstantWidth (mk222 OBJ mSpace) kd) biaogao)tc) ys)<br /> ;(vlax-put-property (vlax-put-property (vlax-put-property (vlax-put-property (mk222 OBJ mSpace) 'ConstantWidth kd) 'Layer tc) 'color ys) 'Elevation biaogao)<br /> <br />    ; (vla-put-Color (mk222 OBJ mSpace) 1)<br />     ;(lw2pl (vlax-vla-object->ename Obj))<br />      )<br /> <br /> <br />   )<br /> <br />       <br /> <br />       ;(vla-move ob (vlax-3d-point pt0)(vlax-3d-point pt1))<br />     );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<br /> <br />     <br />     (vlax-invoke-method dbx 'SaveAs (strcat path dwgname))<br />   )  ;;;;;;;;;;;;;;;;;;;;;;;;<br />   (vlax-release-object dbx);释放<br />   ;(setvar "cmdecho" 1)<br />   (princ)<br /> )<br /> ;(princ "\n 不开图地形图平移代号坐标运行命令：pydhzb")<br /> ;(princ "\n 如有疑问或者好的建议请联系老仓测绘上班记QQ:729292370")<br /> ;(princ)

树櫴希德

树櫴希德 发表于 2023-6-23 15:34

南方等高线多段线转二维多段线  非拟合 非圆弧

1. ;entmake生成二维多段线
   
2. (defun s1712082 (ss5 a38 a-3 a62 a8 / a70 a8 ed ss5 )
   
3. (entmake (list  '(0 . "POLYLINE") '(100 . "AcDbEntity") a8 '(100 . "AcDb2dPolyline") '(70 . 0) a38 a-3 a62))
   
4. (while (setq ed (car ss5))
   
5.   (setq ss5 (cdr ss5))
   
6.   (entmake ed)
   
7. )
   
8. (entmake '((0 . "SEQEND")))
   
9. )
   
10. 
    
11. (defun  lw2pl  (  ent /  ss5 a70 a8 a10 a42 a70 a40 a41 a38 a-3 a62) ;ss5 a70 a8 a10 a42 a70
    
12. ;(setq ent (car ss1))
    
13.       (setq  ss5 (entget ent '("*") ))
    
14.       (setq a70 (assoc 70 ss5)
    
15.             a8 (assoc 8 ss5)
    
16.       a38 (assoc 38 ss5)
    
17.       a-3 (assoc -3 ss5)
    
18.       a62 (assoc 62 ss5)
    
19.             a10 (vl-remove-if-not '(lambda (x) (= (car x) 10)) ss5)
    
20.       a40 (vl-remove-if-not '(lambda (x) (= (car x) 40)) ss5)
    
21.       a41 (vl-remove-if-not '(lambda (x) (= (car x) 41)) ss5)
    
22.             a42 (vl-remove-if-not '(lambda (x) (= (car x) 42)) ss5)
    
23.             ss5 (mapcar '(lambda (x) (append (list '(0 . "VERTEX") '(100 . "AcDbEntity") '(67 . 0) a8 '(100 . "AcDbVertex") '(100 . "AcDb2dVertex")) x))
    
24.           (mapcar 'cons a41 (mapcar 'cons a40 (mapcar 'cons a10 (mapcar '(lambda (x) (list x '(70 . 0))) a42)  )  ))      )
    
25.       )
    
26.       (s1712082 ss5 a38 a-3 a62 a8)
    
27.      ; (entdel ent)
    
28. (princ )
    
29. )
    
30. 
    
31.   ;(lw2pl (car(entsel)))   (entget (car(entsel))'("*"))

;entmake生成二维多段线<br /> (defun s1712082 (ss5 a38 a-3 a62 a8 / a70 a8 ed ss5 )<br /> (entmake (list  '(0 . "POLYLINE") '(100 . "AcDbEntity") a8 '(100 . "AcDb2dPolyline") '(70 . 0) a38 a-3 a62))<br /> (while (setq ed (car ss5))<br />   (setq ss5 (cdr ss5))<br />   (entmake ed)<br /> )<br /> (entmake '((0 . "SEQEND")))<br /> )<br /> <br /> (defun  lw2pl  (  ent /  ss5 a70 a8 a10 a42 a70 a40 a41 a38 a-3 a62) ;ss5 a70 a8 a10 a42 a70<br /> ;(setq ent (car ss1))<br />       (setq  ss5 (entget ent '("*") ))<br />       (setq a70 (assoc 70 ss5)<br />             a8 (assoc 8 ss5)<br />       a38 (assoc 38 ss5)<br />       a-3 (assoc -3 ss5)<br />       a62 (assoc 62 ss5)<br />             a10 (vl-remove-if-not '(lambda (x) (= (car x) 10)) ss5)<br />       a40 (vl-remove-if-not '(lambda (x) (= (car x) 40)) ss5)<br />       a41 (vl-remove-if-not '(lambda (x) (= (car x) 41)) ss5)<br />             a42 (vl-remove-if-not '(lambda (x) (= (car x) 42)) ss5)<br />             ss5 (mapcar '(lambda (x) (append (list '(0 . "VERTEX") '(100 . "AcDbEntity") '(67 . 0) a8 '(100 . "AcDbVertex") '(100 . "AcDb2dVertex")) x))<br />           (mapcar 'cons a41 (mapcar 'cons a40 (mapcar 'cons a10 (mapcar '(lambda (x) (list x '(70 . 0))) a42)  )  ))      )<br />       )<br />       (s1712082 ss5 a38 a-3 a62 a8)<br />      ; (entdel ent)<br /> (princ )<br /> )<br /> <br />   ;(lw2pl (car(entsel)))   (entget (car(entsel))'("*"))

树櫴希德

1. (setq jb (cdr (assoc 5 (entget (car(entsel ""))))))
   
2. (setq newobj (vlax-ename->vla-object (car(entsel ""))  ))
   
3. (regapp "ZXCAD")
   
4. (setq xtype (vlax-make-safearray vlax-vbInteger '(0 . 4)))
   
5.    (setq xdata (vlax-make-safearray vlax-vbvariant '(0 . 4)))
   
6. (vlax-safearray-fill xtype (list 1001 1000 1002 1005 1002))
   
7.           (vlax-safearray-fill xdata (list "ZXCAD" "1005的值是圆的句柄值,当用户复制到新图纸的时候cad自动更新1005的值为圆的新句柄" "{" jb "}") )
   
8.            (vla-setxdata newobj xtype xdata)

(setq jb (cdr (assoc 5 (entget (car(entsel ""))))))<br /> (setq newobj (vlax-ename->vla-object (car(entsel ""))  ))<br /> (regapp "ZXCAD")<br /> (setq xtype (vlax-make-safearray vlax-vbInteger '(0 . 4)))<br />    (setq xdata (vlax-make-safearray vlax-vbvariant '(0 . 4)))<br /> (vlax-safearray-fill xtype (list 1001 1000 1002 1005 1002))<br />           (vlax-safearray-fill xdata (list "ZXCAD" "1005的值是圆的句柄值,当用户复制到新图纸的时候cad自动更新1005的值为圆的新句柄" "{" jb "}") )<br />            (vla-setxdata newobj xtype xdata)