3D->2D转三维消隐线框为二维
前阵子一直迷茫，要写个将3D消隐图轮廓线转为2D，后来参阅了国外一篇文章，利用AutoCAD自身命令实现，较为繁琐，将它写出来供大家方便使用。(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-*")
(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")
程序在cad2011上测试未通过 <img src="E:\lispbox\gifgifgif\3d2d.gif"/> <p><font face="Verdana">错误: no function definition: XYP-GET-TBLNEXT</font></p>
<p>在2008上通不过</p> <p><font face="Verdana">命令: ; 错误: no function definition: XYP-GET-TBLNEXT</font></p>
<p>06也不行，这是哪里的函数啊</p> <p>是否要下載通用函數?</p> <p>xyp-get-tblnext这是个获取图层名称列表的函数，您可以自己写下；也可以到<font face="Verdana">xyp1964.ys168.com</font><font face="Verdana">下载XYP.lib</font></p>
<p>2009测试没问题，2006没有测试，应该可以</p>
<p> </p> ACAD2011去除图层反应器清理代码应该可以
(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-*") (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) ) 希望楼主把xyp-get-tblnext写出来加进去，谢谢！ 本帖最后由 作者 于 2010-9-3 23:40:40 编辑
改了一下，能用了，谢谢分享。
(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-*")
(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))
)
页:
[1]
2