标注系列【源码】，回馈明经
本帖最后由 ebigsong 于 2012-4-25 21:50 编辑最近开始学习lisp，感谢明经，给了很大的帮助，发点自己写的源码，主要就是引注，标注，然后生成组。就当做回馈明经的用户吧。高手就不要看了，见笑。
;;;pn.lsp
;;;根据选择的出户管，进行标注
;;;输入：选择出户管，点取标注的点位，输入管道种类，编号
;;;输出：出户管标注
;;;最后编辑时间：2012.4.8
(defun *error* (msg)exit)
(defun C:pn()
(setq r 500) ;设置标注圆直径
(setq pn_layer "W_DIM");设置标注图层
(setq txt_style "hztxt");设置标注样式
(setq g_yesorno 1);设置是否编组，0-不编组，1-编组
(setq u_yesorno 0);设置是否将编号大写，0-否，1-大写
(setq txt_size (* r 0.6)) ;设置标注文字高度
(setq txt_off1 (/ r 8)) ;设置标注文字上移尺寸
(setq txt_off2 (/ r 4)) ;设置标注文字下移移动尺寸
(setvar"cmdecho"0)
(setq var_os (getvar "osmode"));记录捕捉
(setq var_old_layer (getvar "clayer"));记录当前图层
;判断图层是否存在
(if (= nil (tblsearch "layer" pn_layer)) (command "layer" "m" pn_layer ""))
;提示选择出户管，获得选择点
(setq inspt (osnap (cadr (entsel "\n选择出户管")) "nea"))
(while inspt
(progn
(setvar "clayer" pn_layer);设置当前图层
(setvar "osmode" 0);取消捕捉
;插入出户标注圆
(command "circle" inspt r)
;选择最后一个图元名
(setq obj_c (entlast))
;移动出户标注图块pn_b.dwg
(command "move" obj_c "" inspt pause)
;获取第二次输入的点
(setq inspt1 (getvar 'lastpoint))
;绘制连接线
(setq ang (*(/ (angle inspt inspt1) pi) 180))
(setq dis (- (distance inspt1 inspt) r))
;连接字符串
(command "line" inspt (strcat "@" (rtos dis) "<" (rtos ang)) "")
(setq obj_line (entlast))
;绘制圆的分隔线
(command "line" inspt1 (strcat "@" (rtos (* r 2)) ",0") "")
(setq obj_line2 (entlast))
(command "move" obj_line2 "" inspt1 (strcat "@-" (rtos r) ",0"))
;提示输入出户管标志,自动转成大写
(setq txt_name (getstring "\n出户管名称: "))
(if (/= u_yesorno 0)
(setq txt_name (strcase txt_name))
)
;提示输入出户管编号
(setq txt_no (getint "\n出户管编号: "))
;输入名称和编号
(command "text" "J" "bc" inspt1 txt_size "0" txt_name)
;选择最后一个图元名
(setq obj_na (entlast))
(command "move" obj_na "" inspt1 (strcat "@0," (rtos txt_off1)))
(command "text" "J" "tc" inspt1 txt_size "0" txt_no)
;选择最后一个图元名
(setq obj_no (entlast))
(command "move" obj_no "" inspt1 (strcat "@0,-" (rtos txt_off2)))
(if (= g_yesorno 1) ;编组
(progn
(setq obj_together (ssadd obj_no (ssadd obj_na (ssadd obj_line2 (ssadd obj_c (ssadd obj_line))))))
;生成匿名组
(command "-group" "c" "*" "出户管标注" obj_together "")
)
)
(setvar "osmode" var_os);恢复捕捉
(setvar "clayer" var_old_layer);恢复当前图层
(princ)
;提示选择出户管，获得选择点
(setq inspt (osnap (cadr (entsel "\n选择出户管")) "nea"))
);end progn
);end while
(princ)
)
;;;pn1.lsp
;;;为选择的对象添加带圈的编号
;;;输入：选择对象，点取编号点，输入编号
;;;输出：生成带圈的编号
;;;2012.4.8
(defun *error* (msg)exit)
(defun C:pn1()
(setq r 600) ;设置标注圆直径
(setq pn_layer "W_DIM");设置标注图层
(setq txt_style "hztxt");设置标注样式
(setq g_yesorno 1);设置是否编组
(setq txt_size (/ r 1.5)) ;设置标注文字高度
(setvar"cmdecho"0)
(setq var_os (getvar "osmode"));记录捕捉
(setq var_old_layer (getvar "clayer"));记录当前图层
;判断图层是否存在
(if (= nil (tblsearch "layer" pn_layer)) (command "layer" "m" pn_layer ""))
;提示选择出户管，获得选择点
(setq inspt (osnap (cadr (entsel "\n选择标注点")) "nea"))
(while inspt
(progn
(setvar "clayer" pn_layer);设置当前图层
(setvar "osmode" 0);取消捕捉
;插入标注圆
(command "circle" inspt r)
;选择最后一个图元名
(setq obj_c (entlast))
;移动标注圆
(command "move" obj_c "" inspt pause)
;获取第二次输入的点
(setq inspt1 (getvar 'lastpoint))
;绘制连接线
(setq ang (*(/ (angle inspt inspt1) pi) 180))
(setq dis (- (distance inspt1 inspt) r))
;连接字符串
(command "line" inspt (strcat "@" (rtos dis) "<" (rtos ang)) "")
(setq obj_line (entlast))
;提示输入编号
(setq txt_name (getstring "\n编号: "))
;输入编号
(command "text" "J" "mc" inspt1 txt_size "0" txt_name)
;选择最后一个图元名
(setq obj_na (entlast))
(if (= g_yesorno 1) ;编组
(progn
(setq obj_together (ssadd obj_na(ssadd obj_c (ssadd obj_line))))
;生成匿名组
(command "-group" "c" "*" "引注" obj_together "")
)
)
(setvar "osmode" var_os);恢复捕捉
(setvar "clayer" var_old_layer);恢复当前图层
(princ)
;提示选择对象
(setq inspt (osnap (cadr (entsel "\n选择标注点")) "nea"))
);end progn
);end while
(princ)
)
;;;pn2.lsp
;;;从选择的点引出带圈的编号
;;;输入：选择引出点，选择标注点，输入编号
;;;输出：从引出点带圈的编号
(defun *error* (msg)exit)
(defun C:pn2()
(setq r 600) ;设置标注圆直径
(setq pn_layer "W_DIM");设置标注图层
(setq txt_style "hztxt");设置标注样式
(setq g_yesorno 1);设置是否编组
(setq txt_size (/ r 1.5)) ;设置标注文字高度
(setvar"cmdecho"0)
(setq var_os (getvar "osmode"));记录捕捉
(setq var_old_layer (getvar "clayer"));记录当前图层
;判断图层是否存在
(if (= nil (tblsearch "layer" pn_layer)) (command "layer" "m" pn_layer ""))
;提示选择出户管，获得选择点
(setq inspt (getpoint "\n选择标注点"))
(while inspt
(progn
(setvar "clayer" pn_layer);设置当前图层
(setvar "osmode" 0);取消捕捉
;插入出户标注圆
(command "circle" inspt r)
;选择最后一个图元名
(setq obj_c (entlast))
;移动出户标注图块pn_b.dwg
(command "move" obj_c "" inspt pause)
;获取第二次输入的点
(setq inspt1 (getvar 'lastpoint))
;绘制连接线
(setq ang (*(/ (angle inspt inspt1) pi) 180))
(setq dis (- (distance inspt1 inspt) r))
;连接字符串
(command "line" inspt (strcat "@" (rtos dis) "<" (rtos ang)) "")
(setq obj_line (entlast))
;提示输入编号
(setq txt_name (getstring "\n编号: "))
;输入编号
(command "text" "J" "mc" inspt1 txt_size "0" txt_name)
;选择最后一个图元名
(setq obj_na (entlast))
(if (= g_yesorno 1) ;编组
(progn
(setq obj_together (ssadd obj_na(ssadd obj_c (ssadd obj_line))))
;生成匿名组
(command "-group" "c" "*" "引注" obj_together "")
)
)
(setvar "osmode" var_os);恢复捕捉
(setvar "clayer" var_old_layer);恢复当前图层
(princ)
;提示选择出户管，获得选择点
(setq inspt (getpoint "\n选择标注点"))
);end progn
);end while
(princ)
)
;;;pn3.lsp
;;;给选择的对象添加文字标注
;;;输入：选择对象和标注的点位，输入标注文字
;;;输出：生成引线及标注文字。
;;;最后修改时间：2012.4.8
;(defun *error* (msg)exit)
(defun C:pn3()
(setq r 50)
(setq lg_layer "W_DIM");设置标注图层
(setq txt_style "hztxt");立管标注样式
(setq g_yesorno 1);设置是否编组，0-不编组，1-编组
(setq txt_size (* r 6)) ;设置标注文字高度
(setq txt_off1 (* r 1)) ;设置标注文字上移尺寸
(setq txt_off2 (* r 2)) ;设置标注文字左右移尺寸
(setvar"cmdecho"0)
(setq var_os (getvar "osmode"));记录捕捉
(setq var_old_layer (getvar "clayer"));记录当前图层
;判断图层是否存在
(if (= nil (tblsearch "layer" lg_layer)) (command "layer" "m" lg_layer ""))
;提示选择对象，获得选择点
(setq inspt (osnap (cadr (entsel "\n选择标注对象")) "nea"))
(while inspt
(progn
(setvar "clayer" lg_layer);设置当前图层
(setvar "osmode" 0);取消捕捉
(setq inspt1 (getpoint inspt "\n点取标注位置"))
;绘制连接线
(command "line" inspt inspt1 "")
(setq obj_line (entlast))
(setq txt (getstring "\n标注内容: "))
(setq ang (*(/ (angle inspt inspt1) pi) 180))
(if (or (<= ang 90) (>= ang 270))
(progn
;输入名称和编号
(command "text" "J" "bl" inspt1 txt_size "0" txt)
;选择最后一个图元名
(setq obj_txt (entlast))
(command "move" obj_txt "" inspt1 (strcat "@" (rtos txt_off2) "," (rtos txt_off1)))
;绘制标注底线
(setq txtb (textbox (entget obj_txt)))
;得到文字长度
(setq txt_l (- (caadr txtb) (caar txtb)))
(command "line" inspt1 (strcat "@" (rtos (+ txt_l (* txt_off2 2))) ",0") "")
(setq obj_line2 (entlast))
)
(progn
;输入名称和编号
(command "text" "J" "br" inspt1 txt_size "0" txt)
;选择最后一个图元名
(setq obj_txt (entlast))
(command "move" obj_txt "" inspt1 (strcat "@-" (rtos txt_off2) "," (rtos txt_off1)))
;绘制标注底线
(setq txtb (textbox (entget obj_txt)))
;得到文字长度
(setq txt_l (- (caadr txtb) (caar txtb)))
(command "line" inspt1 (strcat "@-" (rtos (+ txt_l (* txt_off2 2))) ",0") "")
(setq obj_line2 (entlast))
)
)
(if (= g_yesorno 1) ;编组
(progn
;建立选择集
(setq obj_together (ssadd obj_txt (ssadd obj_line2 (ssadd obj_line))))
;生成匿名组
(command "-group" "c" "*" "对象标注" obj_together "")
)
)
(setvar "osmode" var_os);恢复捕捉
(setvar "clayer" var_old_layer);恢复当前图层
(princ)
;提示选择对象，获得选择点
(setq inspt (osnap (cadr (entsel "\n选择标注对象")) "nea"))
);end progn
);end while
(princ)
)
text 改用 entmakex 之后
;绘制标注底线
(setq txtb (textbox (entget obj_txt)))
就出错。
(defun C:pn3()
(setq scale (getvar "dimscale"));获得全局比例
;;;(setq lg_layer "W_DIM");设置标注图层
;;; (setq txt_style "hztxt");立管标注样式
(setq g_yesorno 1);设置是否编组，0-不编组，1-编组
;;;(setq txt_size (* scale 6)) ;设置标注文字高度
(setq txt_off1 (* scale 1)) ;设置标注文字上移尺寸
(setq txt_off2 (* scale 2)) ;设置标注文字左右移尺寸
(setvar"cmdecho"0)
(setq var_os (getvar "osmode"));记录捕捉
(setq var_old_layer (getvar "clayer"));记录当前图层
;判断图层是否存在
;;;(if (= nil (tblsearch "layer" lg_layer)) (command "layer" "m" lg_layer ""))
;提示选择对象，获得选择点
(setq inspt (osnap (cadr (entsel "\n选择标注对象")) "nea"))
(while inspt
(progn
;;; (setvar "clayer" lg_layer);设置当前图层
(setvar "osmode" 0);取消捕捉
(setq inspt1 (getpoint inspt "\n点取标注位置"))
;绘制连接线
(command "line" inspt inspt1 "")
(setq obj_line (entlast))
(setq txt_name (getstring "\n标注内容: "))
(setq ang (*(/ (angle inspt inspt1) pi) 180))
(if (or (<= ang 90) (>= ang 270))
(progn
;输入名称和编号
;;;(command "text" "J" "bl" inspt1 txt_size "0" txt_name)
(entmakeX (list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
'(70 . 0)
'(71 . 7) ;;左对齐-下对齐
'(72 . 1)
'(73 . 2)
(cons 40 (* scale 6))
(cons 1txt_name)
(cons 10 inspt1)
)
)
;选择最后一个图元名
(setq obj_txt (entlast))
(command "move" obj_txt "" inspt1 (strcat "@" (rtos txt_off2) "," (rtos txt_off1)))
;绘制标注底线
(setq txtb (textbox (entget obj_txt)));;;#### 这个如何改？####################
;得到文字长度
(setq txt_l (- (caadr txtb) (caar txtb)))
(command "line" inspt1 (strcat "@" (rtos (+ txt_l (* txt_off2 2))) ",0") "")
(setq obj_line2 (entlast))
)
(progn
;输入名称和编号
;;;(command "text" "J" "br" inspt1 txt_size "0" txt_name)
(entmakeX (list '(0 . "MTEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
'(70 . 0)
'(71 . 9) ; 右对齐-下对齐
'(72 . 1)
'(73 . 2)
(cons 40 (* scale 6))
(cons 1txt_name)
(cons 10 inspt1)
)
)
;选择最后一个图元名
(setq obj_txt (entlast))
(command "move" obj_txt "" inspt1 (strcat "@-" (rtos txt_off2) "," (rtos txt_off1)))
;绘制标注底线
(setq txtb (textbox (entget obj_txt)));;;#### 这个如何改？####################
;得到文字长度
(setq txt_l (- (caadr txtb) (caar txtb)))
(command "line" inspt1 (strcat "@-" (rtos (+ txt_l (* txt_off2 2))) ",0") "")
(setq obj_line2 (entlast))
)
)
(if (= g_yesorno 1) ;编组
(progn
;建立选择集
(setq obj_together (ssadd obj_txt (ssadd obj_line2 (ssadd obj_line))))
;生成匿名组
(command "-group" "c" "*" "对象标注" obj_together "")
)
)
(setvar "osmode" var_os);恢复捕捉
(setvar "clayer" var_old_layer);恢复当前图层
(princ)
;提示选择对象，获得选择点
(setq inspt (osnap (cadr (entsel "\n选择标注对象")) "nea"))
);end progn
);end while
(princ)
)
很需要这类插件，对工作提供很大便利
非常感谢楼主的无私分享 虽然不同行，还是有用，非常感谢提供源码 感谢楼主分享，下载试用 感谢分享，学习了。 蛮实用的标注程序~
感谢分享~ 多谢楼主分享这么好的程序！！！ 多谢楼主分享这么好的程序！！！ 给排水专业的福音 非常感谢提供源码 虽然不同行，还是有用，非常感谢提供源码 很需要这类插件，对工作提供很大便利
非常感谢楼主的无私分享