前阵子一直迷茫，要写个将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")





网友答:
mmmmmm 发表于 2014-12-30 14:01
08版以后好像直接用flatshot就行

这个命令很妙。

网友答: 程序在cad2011上测试未通过

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

网友答:

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

在2008上通不过



网友答:

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

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



网友答:

是否要下載通用函數?



网友答:

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

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

 



网友答: 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)   )


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

网友答: 本帖最后由 作者 于 2010-9-3 23:40:40 编辑

改了一下，能用了，谢谢分享。
  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. )
  • 上一篇：好东西分享以下，dxf组码大全《DXF 参考手册》！
  • 下一篇：没有了
    CAD技术交流中心 | 建筑CAD | 给排水CAD | 暖通CAD | 电气CAD | 电力CAD | 机械CAD | CAD母线槽 | CAD看图
    Copyright © 2019 - 2025