动态引线标注（改版）

958620832

兄弟贴：动态引线标注 http://bbs.mjtd.com/forum.php?mod=viewthread&tid=102054
从自身需要予以改版，现公布于众。
该程序具有如下几大特点：
  1.设置缺省值，代替兄弟程序中对于档案的保存和调用，个人习惯而已。
  2.线上和线下都可以写入文字，应用范围更广 。而兄弟程序中，文字只能写在线上。
(defun bz (/ *error* name1 name2 name3)
  (defun *error* (msg) ;将描述错误的字符串存入变量msg
    (entdel name1) (entdel name2) (if name3 (entdel name3))
    (princ "错误: ")(princ msg)) ;打印错误信息
  (setq ty (getvar "TEXTSTYLE"))
  (setq kd1 (caadr (textbox (list '(0 . "text")(cons 1 txt1)(cons 40 300)(cons 41 0.7)(cons 7 ty)))))
   ;字高300，字宽高比0.7，可以自己设置，字体为当前字体
  (setq kd2 (caadr (textbox (list '(0 . "text")(cons 1 txt2)(cons 40 300)(cons 41 0.7)(cons 7 ty)))))
   ;字高300，字宽高比0.7，可以自己设置，字体为当前字体
  (setq kd (max kd1 kd2) kd (+ kd 50))
  (setq p (getpoint "\n输入基点:"))
  (setq pd t)
  (while pd
    (setq gr (grread t 4 1) mode (car gr) pt (cadr gr))
    (if (= kd3 0) (setq kd kd1))
    (if (and (listp pt) (>= (car pt) (car p))) (progn
      (setq p0 (polar pt 0 kd))
      (setq p1 (polar pt 0 (/ (- kd kd1) 2)) p1 (polar p1 (angtof "90") 50))
      (setq p2 (polar pt 0 (/ (- kd kd2) 2)) p2 (polar p2 (angtof "270") 350))))
    (if (and (listp pt) (< (car pt) (car p))) (progn
      (setq p0 (polar pt pi kd))
      (setq p1 (polar p0 0 (/ (- kd kd1) 2)) p1 (polar p1 (angtof "90") 50))
      (setq p2 (polar p0 0 (/ (- kd kd2) 2)) p2 (polar p2 (angtof "270") 350))))
    (if (= mode 5) (progn
      (if name1 (entdel name1))
      (entmake (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")'(100 . "AcDbPolyline")'(90 . 3)
        (cons 10 p)(cons 10 pt)(cons 10 p0)))
      (setq name1 (entlast))
      (if name2 (entdel name2))
      (entmake (list '(0 . "text")(cons 1 txt1)(cons 40 300)(cons 41 0.7)(cons 10 p1)(cons 7 ty)))
      ;字高300，字宽高比0.7，可以自己设置，字体为当前字体
      (setq name2 (entlast))
      (if name3 (entdel name3))
      (if (= kd3 1) (entmake (list '(0 . "text")(cons 1 txt2)(cons 40 300)(cons 41 0.7)(cons 10 p2)(cons 7 ty))))
      ;字高300，字宽高比0.7，可以自己设置，字体为当前字体
      (if (= kd3 1) (setq name3 (entlast)))))
    (if (= mode 3) (setq pd nil))
    (if (or (= mode 2) (= mode 25)) (progn (setq pd nil) (entdel name1) (entdel name2) (if name3 (entdel name3)))))
  (princ))

(defun getdata ()
  (setq txt1 (get_tile "a1"))
  (setq txt2 (get_tile "a2"))
  (if (= (get_tile "a3") "0") (setq kd3 0) (setq kd3 1)))

(defun c:yxbz ()
  ;(步骤1)建立临时对话框
  (setq tempname (vl-filename-mktemp "temp.dcl") filen (open tempname "w"))
  (foreach stream
    '("yxbz:dialog{"
      "\n  label = "动态引线标注";"
      "\n  :edit_box {key = \"a1\"; label = \"线上文字:\"; width = 40 ;}"
      "\n  :toggle {key = \"a3\"; label = \"增加线下文字\"; value = "0";}"
      "\n  :edit_box {key = \"a2\"; label = \"线下文字:\"; width = 40; is_enabled = false;}"
      "\n  ok_cancel;}")
  (princ stream filen))
  (close filen)
  (setq dclname tempname)
  ;(步骤2)加载并显示对话框
  (setq dcl_re (load_dialog dclname))
  (if (not (new_dialog "yxbz" dcl_re)) (exit))
  ;(步骤3)定义对话框控件（运用set_tile、action_tile、mode_tile、get_tile等函数）
  (if txt1 (set_tile "a1" txt1) (set_tile "a1" "动态标注"))
  (if txt2 (set_tile "a2" txt2) (set_tile "a2" "动态标注"))
  (if kd3 (set_tile "a3" (rtos kd3))) ;注意set_tile函数中赋值均为字符串（带双引号），就连关键词也要加上双引号。
  (if (= kd3 0) (mode_tile "a2" 1))
  (if (= kd3 1) (mode_tile "a2" 0))
  (action_tile "a3" "(if (= (get_tile \"a3\") \"0\") (mode_tile \"a2\" 1) (mode_tile \"a2\" 0))") ;点击时才起作用
  (action_tile "accept" "(getdata)(done_dialog 1)")
  (action_tile "cancel" "(done_dialog)")
  ;(步骤4)激活并卸载对话框，并进行对话框隐藏后的操作。
  (setq std (start_dialog))
  (unload_dialog dcl_re)
  (vl-file-delete dclname)
  (if (= std 1) (bz))
  (princ))

njut_prince

希望能增加文字大小及宽度系数的设置，在程序里面改文字大小的话和线的距离就相应的要修改，太麻烦了 。。。

958620832

xyp1964 发表于 2013-10-16 19:07
也有一个类似的：

1.有源码吗？
2.我最近因为需要才编写了这么一个程序，我编写程序的一贯宗旨是，够用，用起来很方便，就行了，没必要那么花俏。
3.我不但告诉大家有这么一个程序，还告诉大家源码，我很乐意跟大家分享，希望版主也能做到，不要吝啬。

xyp1964

也有一个类似的：

丽丽星空

很不错的程序，感谢楼主分享

冰之绝恋

楼主很厉害！

l18c19

这么好的程序，一定要下载来用下！

zmx6189

很不错，赞一个

958620832

958620832 发表于 2013-10-16 21:35
1.有源码吗？
2.我最近因为需要才编写了这么一个程序，我编写程序的一贯宗旨是，够用，用起来很方便，就 ...

程序应该有吧，能否贡献出来？

寒林清远

相当给力！