设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 3D->2D转三维消隐线框为二维
12下一页
返回列表 发新帖
查看: 6616|回复: 16

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

  [复制链接]
chlh_jd
发表于 2010-8-31 21:14:00 | 显示全部楼层 |阅读模式
前阵子一直迷茫，要写个将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")



回复

使用道具 举报

caoyin
发表于 2010-8-31 21:22:00 | 显示全部楼层
程序在cad2011上测试未通过
回复 支持 反对

使用道具 举报

chlh_jd
 楼主| 发表于 2010-8-31 21:23:00 | 显示全部楼层
<img src="E:\lispbox\gifgifgif\3d2d.gif"/>
回复 支持 反对

使用道具 举报

xhq1954425
发表于 2010-9-1 07:00:00 | 显示全部楼层

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

在2008上通不过

回复 支持 反对

使用道具 举报

xiaoquansb
发表于 2010-9-1 12:12:00 | 显示全部楼层

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

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

回复 支持 反对

使用道具 举报

lsjj
发表于 2010-9-1 18:16:00 | 显示全部楼层

是否要下載通用函數?

回复 支持 反对

使用道具 举报

chlh_jd
 楼主| 发表于 2010-9-1 19:46:00 | 显示全部楼层

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

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

 

回复 支持 反对

使用道具 举报

chlh_jd
 楼主| 发表于 2010-9-1 19:50:00 | 显示全部楼层
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)   )
回复 支持 反对

使用道具 举报

xhq1954425
发表于 2010-9-2 06:11:00 | 显示全部楼层
希望楼主把xyp-get-tblnext写出来加进去，谢谢！
回复 支持 反对

使用道具 举报

jh1005
发表于 2010-9-2 23:25:00 | 显示全部楼层
本帖最后由 作者 于 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. )
回复 支持 反对

使用道具 举报

12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-16 16:25 , Processed in 0.191471 second(s), 26 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表