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

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 修定云线
123下一页
返回列表 发新帖
查看: 6756|回复: 21

[源码] 修定云线

  [复制链接]
自贡黄明儒
发表于 2014-10-25 14:46:06 | 显示全部楼层 |阅读模式
本帖最后由 自贡黄明儒 于 2014-10-25 14:48 编辑

;;未知函数见我的其它贴子
;;界面简洁
;;实际上，圆形和矩形是难包罗修改对象的

  1. ;;-------------------------------------------画修定云线 自贡黄明儒 2014.10.18
  2. ;;164.1 [功能] 曲线是否封闭
  3. ;;示例(HH:isClosed (car (entsel)))
  4. (defun HH:isClosed (obj)
  5.   (or (vlax-curve-isclosed e)
  6.       (equal (vlax-curve-getstartpoint e)
  7.              (vlax-curve-getendpoint e)
  8.              1e-5
  9.       )
  10.   )
  11. )
  12. ;;164.2 [功能]使多段线封闭
  13. ;;(HH:MakeClosed (car(entsel)))
  14. (defun HH:MakeClosed (en / OBJ)
  15.   (cond        ((equal (type en) 'ENAME) (setq obj (vlax-ename->vla-object en)))
  16.         (T (setq obj en))
  17.   )
  18.   ;;(if (equal (vlax-get obj 'Closed) 0) (vlax-put obj 'Closed -1))
  19.   ;;(equal (vlax-get-property obj 'closed) :vlax-false)
  20.   ;;(vlax-put-property obj 'closed :vlax-true)
  21.   (cond ((not (vlax-curve-isclosed obj)) (vla-put-closed obj :vlax-true)))
  22. )
  23. ;;[功能] 调用AutoCAD自身命令
  24. ;;(HH:command "PLINE")
  25. (defun HH:command (commandstr / E E0)
  26.   (setq e0 (entlast))
  27.   (apply 'command (list (strcat "_." commandstr)))
  28.   (while (equal (getvar "cmdnames") commandstr) (command pause))
  29.   (setq e (entlast))
  30.   (cond ((not (equal e0 e)) e))
  31. )
  32. ;;[功能] 画多段线
  33. (defun HH:XD:Pline (/ E EN)
  34.   (cond
  35.     ((setq e (HH:command "PLINE"))                            ;成功画得多段
  36.      (setq en (entget e))
  37.      (cond
  38.        ;;没封闭,使其封闭
  39.        ((> (cdr (assoc 90 en)) 2) (cond ((not (HH:isClosed e)) (HH:MakeClosed e))))
  40.        (T (entdel e))                                            ;少于3点，则删除
  41.      )
  42.      e
  43.     )
  44.   )
  45. )
  46. ;;167.6 [功能] Entmake单行文本(左中)
  47. ;;(EntmakeLMTEXT "DDDD" (getpoint) Textheigh)
  48. (defun EntmakeLMTEXT (str pt Textheigh)
  49.   ;;(SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) ;字高
  50.   (entmakeX
  51.     (list '(0 . "TEXT")
  52.           (cons 1 str)
  53.           (cons 10 pt)
  54.           (cons 40 Textheigh)
  55.           (cons 11 pt)
  56.           '(73 . 2)
  57.     )
  58.   )
  59. )
  60. ;;167.8 [功能] Entmake多行文本(左上角)
  61. ;;(EntmakeMtext "ABC\\PDEF\\PGHI" (getpoint))
  62. (defun EntmakeMtext (str pt Textheigh)
  63.   (entmakeX
  64.     (list '(0 . "MTEXT")
  65.           '(100 . "AcDbEntity")
  66.           '(100 . "AcDbMText")
  67.           ;;'(7 . "Standard")
  68.           (cons 1 str)
  69.           (cons 10 pt)
  70.           (cons 40 Textheigh)
  71.     )
  72.   )
  73. )
  74. ;;注释放置位置
  75. ;;(TextPlace (car (entsel)))
  76. (defun HH:TextPlace (e DDJD1 DDJD2 / CODE DATE EN ENTDAT ENTM ENTNAME LST LST0 P P0 P1 PS PS1 PTS STR TEXTHEIGH X Y)
  77.   (setq Lst0 (parse3 (strcat "注释:" DDJD2) "[\\u4E00-\\u9FA5]|[^\\u4E00-\\u9FA5/ ]|[\\s]+"))
  78.   (SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) ;字高
  79.   (while (and (setq code (grread T 8)) (= (car code) 5) (setq p (cadr code)))
  80.     (setq p0 (vlax-curve-getClosestPointTo e p))
  81.     (redraw)
  82.     (grdraw p p0 1)
  83.   )
  84.   ;;以Y最大X最小那个角放置文本开始,应该改为刚好放文字在框内更合理
  85.   (cond        (p
  86.          (EntmakeLine p p0)                                    ;修订到注释画线
  87.          (while        (and (setq code (grread T 8)) (= (car code) 5) (setq p1 (cadr code)))
  88.            (setq pts (list p (list (car p) (cadr p1)) p1 (list (car p1) (cadr p)) p))
  89.            (redraw)
  90.            (mapcar '(lambda (x y) (grdraw x y 1)) pts (cdr pts))
  91.            (setq Y (max (cadr p) (cadr p1)))
  92.            (setq x (min (car p) (car p1)))
  93.            (setq ps (list (+ x Textheigh) (- Y Textheigh Textheigh))) ;ps是文本放置点
  94.            (cond ((not (equal p p1))                  
  95.                   (setq Lst (MtextDivde p p1 Lst0 Textheigh)) ;注释分段
  96.                   (setq str (lst->str1 Lst "\\P"))
  97.                   (setq en (entget EntM))
  98.                   (entmod (subst (cons 1 str) (assoc 1 en) en)) ;更新
  99.                   (command "_.move" Entdat EntName EntM "" "non" ps1 "non" ps)
  100.                   (setq ps1 ps)
  101.                  )
  102.                  (T
  103.                   (setq date (menucmd "M=$(edtime,$(getvar,date),YYYY.MO.DD)"))
  104.                   (setq date (strcat "时间:" date))
  105.                   (setq ps1 ps)
  106.                   (setq Entdat (EntmakeLMTEXT date ps1 Textheigh))
  107.                   (setq ps (mapcar '- ps (list 0 (* Textheigh 2))))
  108.                   (setq EntName (EntmakeLMTEXT (strcat "姓名:" DDJD1) ps Textheigh))
  109.                   (setq ps (mapcar '- ps (list 0 (* Textheigh 1.5))))
  110.                   (setq EntM (EntmakeMtext (strcat "注释:" DDJD2) ps Textheigh))
  111.                  )
  112.            )
  113.          )
  114.         )
  115.   )
  116.   (cond ((and p p1) (command "_.rectang" "non" p "non" p1)))
  117. )
  118. ;;文字按给定长度分段
  119. ;;(MtextDivde (getpoint)  (getpoint) '("A" "B" "C" "D" "E" "F" "G") 3)=>
  120. ;;(("A" "B" "C") ("D" "E" "F") ("G"))
  121. (defun MtextDivde (p p1 L Textheigh / L1 LST SCOR STR1 STR2 W W0 X)
  122.   (setq Lst L)
  123.   (setq w (abs (- (car p) (car p1))))                            ;方框宽度
  124.   (setq w (abs (- w Textheigh Textheigh)))                    ;左右间隙半个字高
  125.   (while (setq L1 (car Lst))
  126.     (setq Lst (cdr Lst))
  127.     ;;(cond ((and scor (not str1)) (setq str1 (cons "    " str1))));加4个空格
  128.     (setq str1 (cons L1 str1))
  129.     (setq str2 (apply 'strcat str1))
  130.     (setq W0 (abs (car (apply 'mapcar (cons '- (HH:String:Len "" str2 Textheigh 1))))))
  131.     (cond ((> w0 w)
  132.            (setq scor (cons str1 scor))
  133.            (setq str1 nil)
  134.           )
  135.     )
  136.   )
  137.   (cond (str1 (setq scor (cons str1 scor))))
  138.   (reverse (mapcar '(lambda (x) (reverse x)) scor))
  139. )
  140. ;;173 [功能] 表->字符串
  141. ;;(lst->str1 '(("A" "B" "C") ("D" "E" "F") ("G")) "\\P")=>"ABC\\PDEF\\PG"
  142. (defun lst->str1 (lst del / A)
  143.   (if (cdr lst)
  144.     (strcat (apply 'strcat (car lst)) del (lst->str1 (cdr lst) del))
  145.     (apply 'strcat (car lst))
  146.   )
  147. )
  148. ;;创建线型
  149. (defun HHXD:makelt (str / EXPRT FILE FN TEXTHEIGH W0 Y)
  150.   (SETQ Textheigh (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE") 0.5)) ;字高一半
  151.   (setq W0 (abs (car (apply 'mapcar (cons '- (HH:String:Len "" str Textheigh 1))))))
  152.   (setq w0 (VL-PRINC-TO-STRING w0));线型文字高
  153.   (setq Y (VL-PRINC-TO-STRING (* -0.5 Textheigh)));线在文字中部
  154.   (setq Textheigh (VL-PRINC-TO-STRING Textheigh))  
  155.   (setq File (vl-filename-mktemp nil nil ".lin"))
  156.   (setq fn (open file "w"))
  157.   (setq exprt (getvar 'expert))
  158.   (write-line (strcat "*" str ", ---" str "---") fn)
  159.   (write-line (strcat "A," w0 ",-0.01,[" (VL-PRIN1-TO-STRING str)
  160.                       ",STANDARD,S=" Textheigh ",R=0.0,X=-0.0,Y=" Y "],"
  161.                       (VL-PRINC-TO-STRING (* -1 (strlen str)))
  162.               )
  163.               fn
  164.   )
  165.   (close fn)
  166.   (setvar 'expert 5)
  167.   (command ".-linetype" "load" "*" file "")
  168.   (setvar 'expert exprt)
  169.   (cond (file (vl-file-delete file)))
  170. )
  171. ;;-------------------------------------------画修定云线 自贡黄明儒 2014.10.18
  172. (defun C:HHXD (/ DDJD1 DDJD2 DDJD3 E OLDCEC OLDCEL OLDLAYER OSM1 RETURN# SCA)
  173.   (defun *error* (msg)
  174.     (vl-bt)
  175.     (cond (*DOC* (_EndUndo *DOC*)))                            ;块内图元增减
  176.     (while (not (equal (getvar "cmdnames") "")) (command nil))
  177.     (setvar "nomutt" 0)
  178.     (cond (oldCel (setvar 'CELTYPE oldCel)))
  179.     (cond (oldCec (setvar 'CECOLOR oldCec)))
  180.     (cond (oldLayer (setvar 'Clayer oldLayer)))
  181.     (cond (osm1 (setvar "osmode" osm1)))
  182.     (princ "\n 出错啦!")
  183.     (princ)
  184.   )
  185.   ;;设置对话框
  186.   (defun GETDATA ()
  187.     (setq DDJD1 (get_tile "DDJD1"))
  188.     (cond ((equal (setq DDJD2 (get_tile "DDJD2")) "") (setq DDJD2 "修改")))
  189.     (setq DDJD3 (get_tile "DDJD3"))
  190.     (setenv "HuangMR\\XDYX" DDJD1)
  191.     (setenv "HuangMR\\XDYXNum" DDJD3)
  192.   )
  193.   ;;获取对话框用户输入
  194.   (defun SETDATA (/ NAME)
  195.     (setq name (getenv "HuangMR\\XDYX"))
  196.     (cond ((not name) (setq name "黄明儒")))
  197.     (Set_tile "DDJD1" name)

  199.     (setq name (getenv "HuangMR\\XDYXNum"))
  200.     (cond ((not name) (setq name "1")))
  201.     (Set_tile "DDJD3" name)
  202.   )
  203.   ;;对话框
  204.   (defun HHXDdia (/ DCLID FN FNAME LIN)
  205.     (setq fname (vl-filename-mktemp nil nil ".dcl"))
  206.     (setq fn (open fname "w"))
  207.     (write-line "HHXDYX : dialog {label = \"修定云线(黄明儒)\";" fn)
  208.     (write-line " :row{" fn)
  209.     (write-line        "  : edit_box {label = \"姓名\";key = \"DDJD1\";value = \"黄明儒\";}"
  210.                 fn
  211.     )
  212.     (write-line "  :spacer { }:spacer { }:spacer { }:spacer { }:spacer { }" fn)
  213.     (write-line        "  : edit_box {label = \"修改次数\";key = \"DDJD3\";value = \"1\";}"
  214.                 fn
  215.     )
  216.     (write-line "  }" fn)
  217.     (write-line        " : edit_box {label = \"说明\";key = \"DDJD2\";value = \"修改\";}"
  218.                 fn
  219.     )
  220.     (write-line " ok_cancel;" fn)
  221.     (write-line "}" fn)
  222.     (close fn)
  223.     (setq fn (open fname "r"))
  224.     (setq dclid (load_dialog fname))
  225.     (while (or (eq (substr (setq lin
  226.                                   (vl-string-right-trim        "\" fn)"
  227.                                                         (vl-string-left-trim "(write-line \"" (read-line fn))
  228.                                   )
  229.                            )
  230.                            1
  231.                            2
  232.                    )
  233.                    "//"
  234.                )
  235.                (eq (substr lin 1 (vl-string-search " " lin)) "")
  236.                (not (eq (substr lin (+ (vl-string-search " " lin) 1) 9) " : dialog"))
  237.            )
  238.     )
  239.     ;;以下根据情况处理
  240.     (new_dialog (substr lin 1 (vl-string-search " " lin)) dclid)
  241.     (setdata)
  242.     (action_tile "accept" "(getdata)(done_dialog 1)")
  243.     (action_tile "cancel" "(done_dialog 0)")
  244.     (setq return# (start_dialog))
  245.     (unload_dialog dclid)
  246.     (close fn)
  247.     (vl-file-delete fname)
  248.     (princ)
  249.   )

  251.   (vl-load-com)
  252.   (or *ACAD* (setq *ACAD* (vlax-get-acad-object)))
  253.   (or *DOC* (setq *DOC* (vla-get-ActiveDocument *ACAD*)))
  254.   (_StartUndo *DOC*)
  255.   (setq oldLayer (getvar "Clayer"))
  256.   (cond        ((not (tblsearch "layer" "defpoints")) (command "_.layer" "_M" "defpoints" ""))
  257.         (T (setvar 'Clayer "defpoints"))
  258.   )
  259.   (setq oldCec (getvar "CECOLOR"))
  260.   (setvar 'CECOLOR "1")

  262.   (setq SCA (* (getvar "DIMSCALE") 10))
  263.   (princ "\n修定范围")
  264.   (cond        ((setq e (HH:XD:Pline))
  265.          (command "_.revcloud" "_A" SCA "" "_o" e "")
  266.          (setq e (entlast))
  267.          (HHXDdia)                                            ;对话框
  268.          (cond
  269.            ((equal return# 1)
  270.             (setq oldCel (getvar 'CELTYPE))
  271.             (setq DDJD3 (strcat "△修改" DDJD3 "次"))
  272.             (cond ((not (tblsearch "LTYPE" DDJD3)) (HHXD:makelt DDJD3)))
  273.             (setvar 'CELTYPE DDJD3)
  274.             (princ "\n注释放置位置")
  275.             (VL-CATCH-ALL-APPLY 'HH:TextPlace (list e DDJD1 DDJD2))
  276.             (cond (oldCel (setvar 'CELTYPE oldCel)))
  277.            )
  278.          )
  279.         )
  280.   )  
  281.   (cond (oldCec (setvar 'CECOLOR oldCec)))
  282.   (cond (oldLayer (setvar 'Clayer oldLayer)))
  283.   (_EndUndo *DOC*)
  284.   (gc)
  285.   (princ "\n 黄明儒:修定云线命令 HHXD")
  286.   (princ)
  287. )
  288. (princ "\n 黄明儒:修定云线命令 HHXD")
  289. (princ)
  290. ;;-------------------------------------------画修定云线 自贡黄明儒 2014.10.18      

本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有账号？注册

x

评分

参与人数 2明经币 +2 收起 理由
lucas_3333 + 1 神马都是浮云
liuhaixin88 + 1 谢谢黄大哥分享，论坛有您而精采！

查看全部评分

"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

cfc
发表于 2024-2-7 15:51:35 | 显示全部楼层
自贡黄明儒 发表于 2014-11-4 13:43
看了9楼，12楼，问题出在少函数HH:Stringen
;;公用----单行文字角点
;;构造文字长度(abs (car (apply ...

加上这个，还是提示无函数定义_ENDUNDO。大佬能放一个完整的吗？这么好的插件不能运行，太可惜了
回复 支持 反对

使用道具 举报

zhd81617
发表于 2014-10-25 15:27:05 | 显示全部楼层
无函数定义: _ENDUNDO
回复 支持 反对

使用道具 举报

USER2128
发表于 2014-10-25 16:18:08 | 显示全部楼层
早几天看过该动画演示，一直就想着黄大侠的程序了！
回复 支持 反对

使用道具 举报

lucas_3333
发表于 2014-10-26 00:18:35 | 显示全部楼层
长老，HH:STRING:LEN 这个函数呢?

点评

自贡黄明儒
http://bbs.xdcad.net/forum.php?mod=viewthread&tid=671083&extra=page%3D1%26filter%3Dsortid%26sortid%3D1  发表于 2014-10-27 08:15
回复 支持 反对

使用道具 举报

香田里浪人
发表于 2014-10-26 17:02:43 | 显示全部楼层
黄总：2004下运行出错，错误: *error* 函数中出错无函数定义: _ENDUNDO
不知何故？

点评

自贡黄明儒
http://bbs.mjtd.com/thread-111741-1-1.html  发表于 2014-10-31 11:42
回复 支持 反对

使用道具 举报

hooboxu
发表于 2014-10-26 19:57:04 | 显示全部楼层
2007也上一样的错误
回复 支持 反对

使用道具 举报

彳余
发表于 2014-10-26 20:50:05 | 显示全部楼层
出错无函数定义
回复 支持 反对

使用道具 举报

王与韩1
发表于 2014-10-27 15:06:22 | 显示全部楼层
连接给的是XD::String:ActualWidth这个函数啊...还是找不到HH:STRING:LEN,麻烦看看

点评

自贡黄明儒
你换了名字，你还是你。XD::String:ActualWidth中Actual是什么意思？我测试时，有时是不准确的。  发表于 2014-10-27 15:12
回复 支持 反对

使用道具 举报

adc
发表于 2014-10-27 19:10:24 | 显示全部楼层
反向跟踪:
[0.53] (VL-BT)
[1.49] (*ERROR* "参数列表尾部有错: 5.58222")
[2.44] (_call-err-hook #<SUBR @148c5e38 *ERROR*> "参数列砦膊坑写? 5.58222")
[3.38] (sys-error "参数列表尾部有错: 5.58222")
:ERROR-BREAK.33 nil
[4.30] (APPLY MAPCAR (- . 5.58222))
[5.24] (HHXD:MAKELT "△修改1次")
[6.19] (C:HHXD)
[7.15] (#<SUBR @148c5ed8 -rts_top->)
[8.12] (#<SUBR @092c2334 veval-str-body> "(C:HHXD)" T #<FILE internal>)
:CALLBACK-ENTRY.6 (:CALLBACK-ENTRY)
:ARQ-SUBR-CALLBACK.3 (nil 0)
回复 支持 反对

使用道具 举报

海盗曹
发表于 2014-10-31 09:15:45 | 显示全部楼层
黄大师的程序必须学习
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-11-25 15:21 , Processed in 0.227225 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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