CAD动态引线标注小程序如何增加字体宽度因子设置（默认0.7））

Htian11

以下程序又KK大神提供，源码中不含字宽设置选项，工作原因，所有文字字宽0.7，不知有没有高手帮忙改进。


(defun zcx()
    (setvar "osmode" 0)
    ;(setq p2 (getpoint P1 "\n-->请指定文字位置:")
  (setq p2 (polar p1 0 10)
        a1 (car p1 )
        c1 (car p2)
        vx (* (- (strlen TXT) 0.2) (* ht 0.75))     
        le vx
    )
    (if (< c1 a1)
    (setq pp (polar p2 pi le)
          p3 (polar pp (/ pi 2) zj)
    )
  (setq pp (polar p2 0 le)
        p3 (polar p2 (/ pi 2) zj)
  ))
  (command "line" p1 p2 "")
  (setq en1 (entlast))
  (command "line" p2 pp "")
  (setq en2 (entlast))
  (command "text" P3 ht 0 TXT)
  (setq en3 (entlast))
  (setq ent1 (entget en1)
        ent2 (entget en2)
        ent3 (entget en3))
  (setq le1 (caadr (textbox ent3)))
  (setq le (* 1.2 le1)
        jl (* 0.1 le1))
  (while (= (car (setq mouse (grread t 0 0))) 5)
      (setq pt (cadr mouse))
      (if (>= (car pt)(car p1))
        (progn
;以下句子可自行简写                    
          (setq ent1 (subst (cons 11 pt)(assoc 11 ent1) ent1))
          (entmod ent1)
          (setq ent2 (subst (cons 10 pt)(assoc 10 ent2) ent2))
          (entmod ent2)
          (setq ent2 (subst (cons 11 (polar pt 0 le))(assoc 11 ent2) ent2))
          (entmod ent2)
          (setq ent3 (subst '(72 . 0) (assoc 72 ent3) ent3))
          (setq ent3 (subst (cons 10 (list (+ (car pt) jl) (+ (cadr pt) zj)))(assoc 10 ent3) ent3))
          (entmod ent3)
          )
        (progn
          (setq ent1 (subst (cons 11 pt)(assoc 11 ent1) ent1))
          (entmod ent1)
          (setq ent2 (subst (cons 10 pt)(assoc 10 ent2) ent2))
          (entmod ent2)
          (setq ent2 (subst (cons 11 (polar pt pi le))(assoc 11 ent2) ent2))
          (entmod ent2)
          (setq ent3 (subst '(72 . 2) (assoc 72 ent3) ent3))
          (setq ent3 (subst (cons 10 (list (- (car pt) jl) (+ (cadr pt) zj)))(assoc 10 ent3) ent3))
          (setq ent3 (subst (cons 11 (list (- (car pt) jl) (+ (cadr pt) zj)))(assoc 11 ent3) ent3))
          (entmod ent3)
          )
        )
    );while
  (princ)
  )

(defun c:KK()
(setq AA (getvar "clayer"))
(setq layer "文字     text")(if (not (tblsearch "layer" layer ))
  (progn (command "layer" "new" "文字     text" "s" "文字     text" "C" 212 "" "L" "Continuous" "" "LW" 0.2 "" "")
))
     (COMMAND "CLAYER" layer)
    (setvar "texteval" 1)
    (setvar "cmdecho" 0)
    (setq vv (getvar "osmode"))
     (setq ht (getreal "\n-->标注字高默认:2.5)"))
(if (= ht nil) (setq ht 2.5))
    (setq zj (/ ht 3))
    (setq n 0)
    (while (= n 0)
       (setq TXT (getstring "\n-->请输入文字:"))
     (setvar "osmode" 33)
      (if (/= txt "")
         (setq   p1 (getpoint "\n-->请指定点坐标:")
        )
        )
     (if (= txt "") (setq n 1)(zcx))
)
    (setvar "osmode" vv)
    (princ)
)

1291500406

Htian11 发表于 2019-7-8 23:06
我知道41是字体宽度，但是在源码中就没见到41，也没见到宽度1的值，这个源码跟别的不太一样，宽度不知道 ...

这个是vla-add 用 entmakex会简单很多
(defun c:bb()(vl-load-com)(setq AA (getvar "clayer"))(setq layer "文字     text")(if (not (tblsearch "layer" layer ))
(progn (command "layer" "new" "文字     text" "s" "文字     text" "C" 212 "" "L" "Continuous" "" "LW" 0.2 "" "")))
(COMMAND "CLAYER" layer)(setvar "texteval" 1)(setvar "cmdecho" 0)(setq vv (getvar "osmode"))
(setq ht (getreal "\n-->标注字高默认:2.5)") zk (getreal "\n-->标注字宽默认:0.7)"))
(if (= ht nil) (setq ht 2.5))(if (= zk nil) (setq zk 0.7))(setq zj (/ ht 3))(setq n 0)
(while (= n 0)(setq TXT (getstring "\n-->请输入文字:"))(setvar "osmode" 33)
(if (/= txt "")(setq   p1 (getpoint "\n-->请指定点坐标:")))
(if (= txt "") (setq n 1)(zcx)))(setvar "osmode" vv)(princ))
(defun zcx()(setvar "osmode" 0)
(setq p2 (polar p1 0 10) a1 (car p1 ) c1 (car p2) vx (* (- (strlen TXT) 0.2) (* ht 0.75))
le vx bb_sp(vla-get-Modelspace (vla-get-activeDocument (vlax-get-acad-object))))
(if (< c1 a1)(setq pp (polar p2 pi le)p3 (polar pp (/ pi 2) zj))
(setq pp (polar p2 0 le) p3 (polar p2 (/ pi 2) zj)))
(vla-addline bb_sp (vlax-3d-point p1) (vlax-3d-point p2))
(setq en1 (entlast))(vla-addline bb_sp (vlax-3d-point p2) (vlax-3d-point pp))
(setq en2 (entlast))(vla-addtext  bb_sp TXT (vlax-3d-point p3) ht)
(entmod (subst (cons 41 zk) (assoc 41 (entget (entlast)))(entget (entlast))))
(setq en3 (entlast))(setq ent1 (entget en1)ent2 (entget en2) ent3 (entget en3))
(setq le1 (caadr (textbox ent3)))(setq le (* 1.2 le1) jl (* 0.1 le1))
(while (= (car (setq mouse (grread t 0 0))) 5)(setq pt (cadr mouse))
(if (>= (car pt)(car p1))(progn (setq ent1 (subst (cons 11 pt)(assoc 11 ent1) ent1))
(entmod ent1)(setq ent2 (subst (cons 10 pt)(assoc 10 ent2) ent2))
(entmod ent2)(setq ent2 (subst (cons 11 (polar pt 0 le))(assoc 11 ent2) ent2))
(entmod ent2)(setq ent3 (subst '(72 . 0) (assoc 72 ent3) ent3))
(setq ent3 (subst (cons 10 (list (+ (car pt) jl) (+ (cadr pt) zj)))(assoc 10 ent3) ent3))
(entmod ent3))(progn(setq ent1 (subst (cons 11 pt)(assoc 11 ent1) ent1))
(entmod ent1)(setq ent2 (subst (cons 10 pt)(assoc 10 ent2) ent2))
(entmod ent2)(setq ent2 (subst (cons 11 (polar pt pi le))(assoc 11 ent2) ent2))
(entmod ent2)(setq ent3 (subst '(72 . 2) (assoc 72 ent3) ent3))
(setq ent3 (subst (cons 10 (list (- (car pt) jl) (+ (cadr pt) zj)))(assoc 10 ent3) ent3))
(setq ent3 (subst (cons 11 (list (- (car pt) jl) (+ (cadr pt) zj)))(assoc 11 ent3) ent3))
(entmod ent3))))(princ))

Htian11

1291500406 发表于 2019-7-8 23:18
这个是vla-add 用 entmakex会简单很多
(defun c:bb()(vl-load-com)(setq AA (getvar "clayer"))(setq l ...

这个比源码精简太多了，而且更容易调试修改

Htian11

1291500406 发表于 2019-7-8 23:18
这个是vla-add 用 entmakex会简单很多
(defun c:bb()(vl-load-com)(setq AA (getvar "clayer"))(setq l ...

大佬啊，厉害了，向您 学习！

Htian11

求大佬指点

t18-13nil

很简单，(entget(car(entsel)))查看组码，改了再查一次，看哪个数据变了就改哪个

Htian11

t18-13nil 发表于 2019-7-7 17:59
很简单，(entget(car(entsel)))查看组码，改了再查一次，看哪个数据变了就改哪个

我不知道怎么用语句加进去，求教

Htian11

t18-13nil 发表于 2019-7-7 17:59
很简单，(entget(car(entsel)))查看组码，改了再查一次，看哪个数据变了就改哪个

我不知道怎么用语句加进去，求教

烟盒迷唇

添加都不会，还得加强学习呀

1291500406

41是字体宽度

Htian11

1291500406 发表于 2019-7-8 12:20
41是字体宽度

我知道41是字体宽度，但是在源码中就没见到41，也没见到宽度1的值，这个源码跟别的不太一样，宽度不知道在哪里有体现

Htian11

烟盒迷唇 发表于 2019-7-8 11:00
添加都不会，还得加强学习呀

我对lisp是懂个皮毛都不算，怎么添加，毕竟用到的不多，求指教