设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 1275|回复: 7

修定云线

[复制链接]

签到天数: 1329 天

连续签到: 2 天

[LV.10]以坛为家III

已领礼包: 604个

财富等级: 财运亨通

发表于 2014-10-25 14:42:41 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有帐号?立即注册

x
本帖最后由 /db_自贡黄明儒_ 于 2014-10-27 08:14 编辑

;;未知函数见我的其它贴子;;http://bbs.xdcad.net/forum.php?m ... sortid%26sortid%3D1
;;界面简洁
;;实际上,圆形和矩形是难包罗修改对象的
  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)
  198.    
  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.   )

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

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

评分

参与人数 1D豆 +5 贡献 +1 收起 理由
炫翔 + 5 + 1 很给力!经验;技术要点;资料分享奖!

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!

签到天数: 991 天

连续签到: 1 天

[LV.10]以坛为家III

点击这里给我发消息

已领礼包: 1726个

财富等级: 堆金积玉

发表于 2014-10-25 16:59:39 | 显示全部楼层
(defun HH:isClosed (obj)
  (or (vlax-curve-isclosed e)
      (equal (vlax-curve-getstartpoint e)
             (vlax-curve-getendpoint e)
             1e-5
      )
  )
)

参数OBJ 为 E

评分

参与人数 1D豆 +2 收起 理由
/db_自贡黄明儒_ + 2 我原来 居然没发现

查看全部评分

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 14 天

连续签到: 1 天

[LV.3]偶尔看看II

发表于 2014-11-8 02:27:24 | 显示全部楼层
我这里运行程序后能生成云线,不能生成注释呀
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 122 天

连续签到: 3 天

[LV.7]常住居民III

已领礼包: 193个

财富等级: 日进斗金

发表于 2014-11-8 08:13:24 | 显示全部楼层
好程序,顶一个
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 998 天

连续签到: 71 天

[LV.10]以坛为家III

已领礼包: 2833个

财富等级: 家财万贯

发表于 2016-12-30 22:04:47 | 显示全部楼层
不能生成注释,是怎么回事呢?
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 4 天

连续签到: 1 天

[LV.2]偶尔看看I

发表于 2017-2-10 13:29:51 | 显示全部楼层
本帖最后由 JeffKOP 于 2017-2-10 14:23 编辑

找了黄大师的其他帖子,补上了几个必要函数。终于可以完美使用了。

若水GIF截图_2017年2月10日13点37分56秒 (1).gif

修定云线.lsp

11.96 KB, 下载次数: 52, 下载积分: D豆 -1 , 活跃度 1

完善黄大师的

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 172 天

连续签到: 1 天

[LV.7]常住居民III

已领礼包: 312个

财富等级: 日进斗金

发表于 2017-2-19 19:21:39 | 显示全部楼层
比cad自带的功能强多了
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

签到天数: 39 天

连续签到: 30 天

[LV.5]常住居民I

已领礼包: 56个

财富等级: 招财进宝

发表于 5 天前 | 显示全部楼层
能自定义云线圆弧大小就更完美了
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2018-8-15 04:07 , Processed in 0.208018 second(s), 45 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

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