ZZXXQQ 版您好，您的程序很好用。
提点小建议：起始号改为默认为1，选取屏幕的某一文字（单行或多行）的 ...
程序改了，因本机上无CAD，程序未经测试。
(defun c:qub (/ os oldlayer pt num ppoint angleline texthight LINEL)
(setvar "CMDECHO" 0)
(setq os (getvar "osmode"))
(setq ort (getvar "ORTHOMODE"))
(setq oldlayer (getvar "CLAYER"))
(command "_.undo" "be")
(setvar "osmode" 0)
(setvar "ORTHOMODE" 1)
(if (and (setq numx (getint "\n起始序号<1>：") numx (if numx numx 1))
(setq pt (getpoint "\n指定球标位置 :"))) (progn
(setvar "ORTHOMODE" 0)
(setq ppoint (getpoint pt "\n标示构件点 :"))
(setvar "ORTHOMODE" 1)
(setq angleline (angle ppoint pt))
(if (and (setq s1 (entsel "\n选择文本 :"))
(setq ent (entget(car s1)))
(= (cdr(assoc 0 ent)) "TEXT"))
(setq texthight (cdr(assoc 40 ent)))
(setq texthight (getvar 'textsize))
)
(setq LINEL (- (distance PPOINT PT) (* 1.0 texthight)))
(setq num (rtos numx 2 0))
(command "LAYER" "M" "文本" "")
(command "mtext" pt "J" "MC" "H" texthight "w" 8 NUM "")
(command "LAYER" "M" "粗实线" "")
(command "CIRCLE" PT (* 1.0 texthight))
(command "LAYER" "M" "标注" "")
(command "donut" 0 "0.5" ppoint "")
(command "LINE" (polar PPOINT angleline 0.25) (polar PPOINT angleline LINEL) "")
))
(if pt
(while (setq nextpoint (getpoint pt "\n下一个球标位置 :"))
(if (< (abs (- (car nextpoint) (car pt))) (abs (- (cadr nextpoint) (cadr pt))))
(setq ptx (list (car pt) (cadr nextpoint)))
(setq ptx (list (car nextpoint) (cadr pt)))
)
(if (equal (distance ptx pt) (* 2 texthight) texthight)
(setq ptx (polar pt (angle pt ptx) (* 2 texthight)))
)
(setq NUMx (1+ NUMx))
(setq num (rtos numx 2 0))
(setvar "CLAYER" "文本")
(command "mtext" ptX "J" "MC" "H" texthight "w" 8 NUM "")
(setvar "CLAYER" "粗实线")
(command "CIRCLE" PTX (* 1.0 texthight))
(if (not (equal (distance ptx pt) (* 2 texthight) texthight)) (progn
(setvar "ORTHOMODE" 0)
(setq ppoint (getpoint ptx "\n标示构件点 :"))
(setvar "ORTHOMODE" 1)
(setvar "CLAYER" "标注")
(command "donut" 0 "0.5" ppoint "")
(setq angleline (angle ppoint ptX))
(setq LINEL (- (DISTance PPOINT PTX) (* 1.0 texthight)))
(command "LINE" (polar PPOINT angleline 0.25) (polar PPOINT angleline LINEL) "")
))
(setq pt ptx)
)
)
(command "_.undo" "e")
(setvar "ORTHOMODE" ort)
(setvar "osmode" os)
(setvar "clayer" oldlayer)
(setvar "CMDECHO" 1)
(princ)
)
(princ "***qub***国庆版")
(princ)
RE:
ZZXXQQ 发表于 2011-10-1 11:16 static/image/common/back.gif程序改了，因本机上无CAD，程序未经测试。
非常感谢ZZXXQQ版主。假后试用。祝明经人节日快乐！ ZZXXQQ 发表于 2011-10-1 11:16 static/image/common/back.gif
程序改了，因本机上无CAD，程序未经测试。
非常感谢ZZXXQQ版主！可以选字高了！程序在使用过程中发现一些小问题：
1. 是否方便把选字高放在最前面，这样就避免了再确定标注位置后再到别的地方去选字高，然后再回到原来的地方标注。
2. 可以选择字高，如果直接右键能默认之前的字高就更加完美啦！
本帖最后由 669423907 于 2011-10-4 21:49 编辑
(defun c:qq (/ os oldlayer pt num ppoint angleline texthight LINEL)
(setq la (getvar"clayer"))
(setvar"clayer""9标注")
............................
;(setvar "CLAYER" "文本")
............................
;(setvar "CLAYER" "粗实线")
............................
; (setvar "CLAYER" "标注")
...........................
(setvar "clayer"la)
(princ)
)
(princ "***qub***国庆版")
(princ)
我这样加为什么提示 ：
错误: AutoCAD 变量设置被拒绝: "clayer" nil
再次感谢ZZXXQQ版
搞定了！
改成这样：
(defun c:qqqq (/ os oldlayer pt num ppoint angleline texthight LINEL)
(setq la (getvar"clayer"))
(setvar"clayer""9标注")
; (setvar "CMDECHO" 0)
(setq os (getvar "osmode"))
(setq ort (getvar "ORTHOMODE"))
(setq oldlayer (getvar "CLAYER"))
(command "_.undo" "be")
; (setvar "osmode" 0)
; (setvar "ORTHOMODE" 1)
(if (and (setq s1 (entsel "\n选择文本 :"))
(setq ent (entget(car s1)))
(= (cdr(assoc 0 ent)) "TEXT"))
(setq texthight (cdr(assoc 40 ent)))
(setq texthight (getvar 'textsize))
)
(if (and (setq numx (getint "\n起始序号<1>") numx (if numx numx 1))
(setq pt (getpoint "\n指定球标位置 :"))) (progn
(setvar "ORTHOMODE" 0)
(setq ppoint (getpoint pt "\n标示构件点 :"))
;(setvar "ORTHOMODE" 1)
(setq angleline (angle ppoint pt))
(setq LINEL (- (distance PPOINT PT) (* 1.0 texthight)))
(setq num (rtos numx 2 0))
;(command "LAYER" "M" "文本" "")
(command "mtext" pt "J" "MC" "H" texthight "w" 8 NUM "")
;(command "LAYER" "M" "粗实线" "")
(command "CIRCLE" PT (* 1 texthight))
;(command "LAYER" "M" "标注" "")
(command "donut" 0 "0.5" ppoint "")
(command "LINE" (polar PPOINT angleline 0.25) (polar PPOINT angleline LINEL) "")
))
(if pt
(while (setq nextpoint (getpoint pt "\n下一个球标位置 :"))
(if (< (abs (- (car nextpoint) (car pt))) (abs (- (cadr nextpoint) (cadr pt))))
(setq ptx (list (car pt) (cadr nextpoint)))
(setq ptx (list (car nextpoint) (cadr pt)))
)
(if (equal (distance ptx pt) (* 2 texthight) texthight)
(setq ptx (polar pt (angle pt ptx) (* 2 texthight)))
)
(setq NUMx (1+ NUMx))
(setq num (rtos numx 2 0))
;(setvar "CLAYER" "文本")
(command "mtext" ptX "J" "MC" "H" texthight "w" 8 NUM "")
;(setvar "CLAYER" "粗实线")
(command "CIRCLE" PTX (* 1 texthight))
(if (not (equal (distance ptx pt) (* 2 texthight) texthight)) (progn
(setvar "ORTHOMODE" 0)
(setq ppoint (getpoint ptx "\n标示构件点 :"))
; (setvar "ORTHOMODE" 1)
; (setvar "CLAYER" "标注")
(command "donut" 0 "0.5" ppoint "")
(setq angleline (angle ppoint ptX))
(setq LINEL (- (DISTance PPOINT PTX) (* 1.0 texthight)))
(command "LINE" (polar PPOINT angleline 0.25) (polar PPOINT angleline LINEL) "")
))
(setq pt ptx)
)
)
(setvar "clayer"la)
; (command "_.undo" "e")
; (setvar "ORTHOMODE" ort)
; (setvar "osmode" os)
; (setvar "CMDECHO" 1)
(princ)) ZZXXQQ，我希望再改进下，先可连续定球标，（只当非连续球标时）再定标注点，这样可以考虑引线是从第一点或最后一点连出。
另，字高不用多考虑，textsize已足够，因为我在布局中用。 哈哈哈！！！小妹丁！ 建议加个判断图层有和无,无则创建和一个错误处理,否则不回归0层 小妹丁 发表于 2012-1-17 15:09 static/image/common/back.gif
ZZXXQQ，我希望再改进下，先可连续定球标，（只当非连续球标时）再定标注点，这样可以考虑引线是从第一点或 ...
改了改，先试下。
(defun c:qub (/ os ort oldlayer pt numx ang texthight nextpt ptx LINEL)
(setvar "CMDECHO" 0)
(setq os (getvar "osmode"))
(setq ort (getvar "ORTHOMODE"))
(setq oldlayer (getvar "CLAYER"))
(command "_.undo" "be")
(setvar "osmode" 0)
(setvar "ORTHOMODE" 1)
(if (and (setq numx (getint "\n起始序号<1>：") numx (if numx numx 1))
(setq pt (getpoint "\n指定球标位置 :"))) (progn
(setvar "ORTHOMODE" 0)
(setq texthight (getvar "TEXTSIZE"))
(command "LAYER" "M" "文本" "")
(command "mtext" pt "J" "MC" "H" texthight "w" 8 (itoa numx) "")
(command "LAYER" "M" "粗实线" "")
(command "CIRCLE" PT (* 1.0 texthight))
(while (setq nextpt (getpoint pt "\n下一球标位置或构件点 :"))
(if (< (abs (- (car nextpt) (car pt))) (abs (- (cadr nextpt) (cadr pt))))
(setq ptx (list (car pt) (cadr nextpt)))
(setq ptx (list (car nextpt) (cadr pt)))
)
(if (equal (distance ptx pt) (* 2 texthight) texthight) (progn
(setq ptx (polar pt (angle pt ptx) (* 2 texthight)))
(setq NUMx (1+ NUMx))
(setvar "CLAYER" "文本")
(command "mtext" ptX "J" "MC" "H" texthight "w" 8 (itoa numx) "")
(setvar "CLAYER" "粗实线")
(command "CIRCLE" PTX (* 1.0 texthight))
(setvar "ORTHOMODE" 0)
(setq pt ptx)
) (if (= (getvar "ORTHOMODE") 0) (progn
(setq ang (angle nextpt pt))
(setq LINEL (- (distance nextpt PT) (* 1.0 texthight)))
(command "LAYER" "M" "标注" "")
(command "donut" 0 "0.5" ppoint "")
(command "LINE" (polar nextpt ang 0.25) (polar nextpt ang LINEL) "")
(setvar "ORTHOMODE" 1)
) (progn
(setq NUMx (1+ NUMx))
(setvar "CLAYER" "文本")
(command "mtext" ptX "J" "MC" "H" texthight "w" 8 (itoa numx) "")
(setvar "CLAYER" "粗实线")
(command "CIRCLE" PTX (* 1.0 texthight))
(setvar "ORTHOMODE" 0)
(setq pt ptx)
)))
)
))
(command "_.undo" "e")
(setvar "ORTHOMODE" ort)
(setvar "osmode" os)
(setvar "clayer" oldlayer)
(setvar "CMDECHO" 1)
(princ)
)
(princ "***qub***春节版")
(princ)
基本上很实用了，我比较喜欢春节版的操作方式。