3D->2D转三维消隐线框为二维

chlh_jd

前阵子一直迷茫，要写个将3D消隐图轮廓线转为2D，后来参阅了国外一篇文章，利用AutoCAD自身命令实现，较为繁琐，将它写出来供大家方便使用。

3. (defun C:3d2d (/ laylst lay ss)
4.   (vl-load-com)  
5.   (vl-catch-all-apply 'vl-cmdf (list "UCS" "N" "V" "" "LAYOUT" "N" "Test" "" ))
6.   (setvar "CTAB" "Test")
7.   (setq ss (ssget "x"))
8.   (vl-catch-all-apply 'vl-cmdf (list "ERASE" ss "" "MVIEW" "F" "" "MSPACE" ""))
9.   (setq ss (ssget "x"))
10.   (vl-catch-all-apply 'vl-cmdf (list "SolProf" ss "" "Y" "Y" "Y" ""))
11.   (setq laylst (xyp-get-tblnext "LAYER"))
12.   (setq lay (last (vl-remove-if-not
13.       (function (lambda (x)
14.     (wcmatch x "PV*")
15.          )
16.       )
17.       laylst
18.     )
19.      )
20.   )
21.   (setvar "CTAB" "Model")
22.   (vl-cmdf "UCS" "N" "V" "")
23.   (setq ss (ssget "x" (list (cons 8 lay))))      
24.   (vl-file-delete "C:\\TEST.DWG");_路径您可以更改设置，也可以改成发送到剪贴板
25.   (vl-cmdf "wblock" "c:\\TEST.dwg" "" '(0 0 0) ss "")
26.   (foreach a laylst
27.     (if (wcmatch a "P[VH]-*")
28.       (vl-cmdf "ERASE" (ssget "X" (list (cons 8 a))) "")
29.       )
30.     )
31.   (vl-catch-all-apply 'vl-cmdf (list "layout" "D" "TEST" "" "UCS" "W" ""))
32.   (vl-Catch-All-Apply
33.     '(lambda ()
34.        (vla-Remove
35.   (vla-GetExtensionDictionary
36.     (vla-Get-Layers
37.       (vla-Get-ActiveDocument
38.         (vlax-Get-Acad-Object)
39.       )
40.     )
41.   )
42.   "ACAD_LAYERFILTERS"
43.        )
44.      )
45.   );清理图层过滤器  
46.   (command "_.PURGE" "a" "*" "N");这里您可以选择执行  
47.   (command "UCS"  "W" "")
48.   (princ)
49.   )
50. (princ "\n3D实体Hidden线框转2D线框程序,命令3D2D, 高山流水 2010.08")

(defun C:3d2d (/ laylst lay ss)   (vl-load-com)     (vl-catch-all-apply 'vl-cmdf (list "UCS" "N" "V" "" "LAYOUT" "N" "Test" "" ))   (setvar "CTAB" "Test")   (setq ss (ssget "x"))   (vl-catch-all-apply 'vl-cmdf (list "ERASE" ss "" "MVIEW" "F" "" "MSPACE" ""))   (setq ss (ssget "x"))   (vl-catch-all-apply 'vl-cmdf (list "SolProf" ss "" "Y" "Y" "Y" ""))   (setq laylst (xyp-get-tblnext "LAYER"))   (setq lay (last (vl-remove-if-not       (function (lambda (x)     (wcmatch x "PV*")          )       )       laylst     )      )   )   (setvar "CTAB" "Model")   (vl-cmdf "UCS" "N" "V" "")   (setq ss (ssget "x" (list (cons 8 lay))))         (vl-file-delete "C:\\TEST.DWG");_路径您可以更改设置，也可以改成发送到剪贴板   (vl-cmdf "wblock" "c:\\TEST.dwg" "" '(0 0 0) ss "")   (foreach a laylst     (if (wcmatch a "P[VH]-*")       (vl-cmdf "ERASE" (ssget "X" (list (cons 8 a))) "")       )     )   (vl-catch-all-apply 'vl-cmdf (list "layout" "D" "TEST" "" "UCS" "W" ""))   (vl-Catch-All-Apply     '(lambda ()        (vla-Remove   (vla-GetExtensionDictionary     (vla-Get-Layers       (vla-Get-ActiveDocument         (vlax-Get-Acad-Object)       )     )   )   "ACAD_LAYERFILTERS"        )      )   );清理图层过滤器     (command "_.PURGE" "a" "*" "N");这里您可以选择执行     (command "UCS"  "W" "")   (princ)   ) (princ "\n3D实体Hidden线框转2D线框程序,命令3D2D, 高山流水 2010.08")

caoyin

程序在cad2011上测试未通过

chlh_jd

<img src="E:\lispbox\gifgifgif\3d2d.gif"/>

xhq1954425

错误: no function definition: XYP-GET-TBLNEXT

在2008上通不过

xiaoquansb

命令: ; 错误: no function definition: XYP-GET-TBLNEXT

06也不行，这是哪里的函数啊

lsjj

是否要下載通用函數?

chlh_jd

xyp-get-tblnext这是个获取图层名称列表的函数，您可以自己写下；也可以到xyp1964.ys168.com下载XYP.lib

2009测试没问题，2006没有测试，应该可以

 

chlh_jd

ACAD2011去除图层反应器清理代码应该可以

3. (defun C:3d2d (/ laylst lay ss)   (vl-load-com)     (vl-catch-all-apply 'vl-cmdf (list "UCS" "N" "V" "" "LAYOUT" "N" "Test" "" ))   (setvar "CTAB" "Test")   (setq ss (ssget "x"))   (vl-catch-all-apply 'vl-cmdf (list "ERASE" ss "" "MVIEW" "F" "" "MSPACE" ""))   (setq ss (ssget "x"))   (vl-catch-all-apply 'vl-cmdf (list "SolProf" ss "" "Y" "Y" "Y" ""))   (setq laylst (xyp-get-tblnext "LAYER"))   (setq lay (last (vl-remove-if-not       (function (lambda (x)     (wcmatch x "PV*")          )       )       laylst     )      )   )   (setvar "CTAB" "Model")   (vl-cmdf "UCS" "N" "V" "")   (setq ss (ssget "x" (list (cons 8 lay))))         (vl-file-delete "C:\\TEST.DWG");_路径您可以更改设置，也可以改成发送到剪贴板   (vl-cmdf "wblock" "c:\\TEST.dwg" "" '(0 0 0) ss "")   (foreach a laylst     (if (wcmatch a "P[VH]-*")       (vl-cmdf "ERASE" (ssget "X" (list (cons 8 a))) "")       )     )   (vl-catch-all-apply 'vl-cmdf (list "layout" "D" "TEST" "" "UCS" "W" ""))     (command "_.PURGE" "a" "*" "N");这里您可以选择执行     (command "UCS"  "W" "")   (princ)   )

(defun C:3d2d (/ laylst lay ss)   (vl-load-com)     (vl-catch-all-apply 'vl-cmdf (list "UCS" "N" "V" "" "LAYOUT" "N" "Test" "" ))   (setvar "CTAB" "Test")   (setq ss (ssget "x"))   (vl-catch-all-apply 'vl-cmdf (list "ERASE" ss "" "MVIEW" "F" "" "MSPACE" ""))   (setq ss (ssget "x"))   (vl-catch-all-apply 'vl-cmdf (list "SolProf" ss "" "Y" "Y" "Y" ""))   (setq laylst (xyp-get-tblnext "LAYER"))   (setq lay (last (vl-remove-if-not       (function (lambda (x)     (wcmatch x "PV*")          )       )       laylst     )      )   )   (setvar "CTAB" "Model")   (vl-cmdf "UCS" "N" "V" "")   (setq ss (ssget "x" (list (cons 8 lay))))         (vl-file-delete "C:\\TEST.DWG");_路径您可以更改设置，也可以改成发送到剪贴板   (vl-cmdf "wblock" "c:\\TEST.dwg" "" '(0 0 0) ss "")   (foreach a laylst     (if (wcmatch a "P[VH]-*")       (vl-cmdf "ERASE" (ssget "X" (list (cons 8 a))) "")       )     )   (vl-catch-all-apply 'vl-cmdf (list "layout" "D" "TEST" "" "UCS" "W" ""))     (command "_.PURGE" "a" "*" "N");这里您可以选择执行     (command "UCS"  "W" "")   (princ)   )

xhq1954425

希望楼主把xyp-get-tblnext写出来加进去，谢谢！

jh1005

改了一下，能用了，谢谢分享。

2. (defun c:3d2d(/ laylst lay ss) ;3D转2D,并复制 ;from 高山流水 2010.08
3. (vl-load-com)
4. (setvar "cmdecho" 0)
5. (vl-catch-all-apply 'vl-cmdf (list "UCS" "N" "V" "LAYOUT" "N" "Test"))
6. (setvar "CTAB" "Test")
7. (setq ss (ssget "x"))
8. (vl-catch-all-apply 'vl-cmdf (list "ERASE" ss "" "MVIEW" "F" "MSPACE"))
9. (setq ss (ssget "x"))
10. (if (not SolProf_bak)  ;这里改了一下，谢谢龙龙仔版主提醒。
11.   (progn
12.     (setq SolProf_bak T)
13.     (vl-catch-all-apply 'vl-cmdf (list "SolProf" ss "" "Y" "Y" "N"))
14.   )
15.   (SolProf ss "" "Y" "Y" "N")
16. )
17. (setq laylst (get-layer))
18. (setq lay (last (vl-remove-if-not (function (lambda (x) (wcmatch x "PV*"))) laylst)))
19. (setvar "CTAB" "Model")
20. (vl-cmdf "UCS" "N" "V")
21. (setq ss (ssget "x" (list (cons 8 lay))))
22. ;(vl-file-delete "C:\\TEST.DWG") ;可以更改路径,也可以改成发送到剪贴板
23. ;(vl-cmdf "wblock" "C:\\TEST.dwg" "" '(0 0 0) ss "")
24. (vl-cmdf "_copyclip" ss "")
25. (foreach a laylst
26. (if (wcmatch a "P[VH]-*")
27. (vl-cmdf "ERASE" (ssget "X" (list (cons 8 a))) "")
28. )
29. )
30. (vl-catch-all-apply 'vl-cmdf (list "layout" "D" "TEST" "UCS" ""))
31. (command "_.PURGE" "a" "*" "N") ;这里您可以选择执行
32. (command "UCS" "")
33. (princ "\n3D转换2D完成，2D线框已复制，粘贴即可。")
34. (princ)
35. )
37. (defun get-layer(/ lay layer layname) ;获得图层列表
38. (setq layer nil lay (tblnext "LAYER" T))
39. (while (/= lay nil)
40. (setq layname (cdr (assoc 2 lay))
41.         layer (cons layname layer)
42.          lay (tblnext "LAYER")
43. )
44. )
45. (setq layer (ACAD_Strlsort layer))
46. )

(defun c:3d2d(/ laylst lay ss) ;3D转2D,并复制 ;from 高山流水 2010.08 (vl-load-com) (setvar "cmdecho" 0) (vl-catch-all-apply 'vl-cmdf (list "UCS" "N" "V" "LAYOUT" "N" "Test")) (setvar "CTAB" "Test") (setq ss (ssget "x")) (vl-catch-all-apply 'vl-cmdf (list "ERASE" ss "" "MVIEW" "F" "MSPACE")) (setq ss (ssget "x")) (if (not SolProf_bak)  ;这里改了一下，谢谢龙龙仔版主提醒。   (progn     (setq SolProf_bak T)     (vl-catch-all-apply 'vl-cmdf (list "SolProf" ss "" "Y" "Y" "N"))   )   (SolProf ss "" "Y" "Y" "N") ) (setq laylst (get-layer)) (setq lay (last (vl-remove-if-not (function (lambda (x) (wcmatch x "PV*"))) laylst))) (setvar "CTAB" "Model") (vl-cmdf "UCS" "N" "V") (setq ss (ssget "x" (list (cons 8 lay)))) ;(vl-file-delete "C:\\TEST.DWG") ;可以更改路径,也可以改成发送到剪贴板 ;(vl-cmdf "wblock" "C:\\TEST.dwg" "" '(0 0 0) ss "") (vl-cmdf "_copyclip" ss "") (foreach a laylst (if (wcmatch a "P[VH]-*") (vl-cmdf "ERASE" (ssget "X" (list (cons 8 a))) "") ) ) (vl-catch-all-apply 'vl-cmdf (list "layout" "D" "TEST" "UCS" "")) (command "_.PURGE" "a" "*" "N") ;这里您可以选择执行 (command "UCS" "") (princ "\n3D转换2D完成，2D线框已复制，粘贴即可。") (princ) ) (defun get-layer(/ lay layer layname) ;获得图层列表 (setq layer nil lay (tblnext "LAYER" T)) (while (/= lay nil) (setq layname (cdr (assoc 2 lay))         layer (cons layname layer)          lay (tblnext "LAYER") ) ) (setq layer (ACAD_Strlsort layer)) )