新手自制的第一个lisp插件：坐标标注。(2022-08-06更新）
本帖最后由 ThinkerHua 于 2022-8-6 09:33 编辑2022-08-06更新：
心血来潮做了一些略微改进。
1、原程序执行过程中按esc提前结束，有可能导致下次无法正常运行，已修复。
2、原程序预览时，多段线是不断删除重绘实现预览的，现在改为更新数据实现。
3、添加了一个简单的错误处理函数，在某些情况下需要主动结束程序时，输出自定义错误信息。
;;;全局变量：fh为文字高度, sc为标注比例, pre为坐标值精度, exc为交换X Y坐标标记
(princ "启动命令：ZB")
(princ "功能：坐标标注")
(princ "作者：Thinker(ThinkerHua@hotmail.com)")
(defun c:zb (/ pa pb pc ta tb X Y tbox_x tbox_y sl DimZin_Old mouse engl_t1 engl_t2 engl_pl
err_msg fh_old sc_old pre_old
)
;;;pa pb pc为引线(多段线)顶点, ta tb为文字基点
;;;X Y为坐标, tbox_x tbox_y为判断文字对象长度用临时坐标存储器
;;;sl为文字对象长度(亦即引线水平段长)
;;;DimZin_Old为环境变量临时存储器
;;;mouse为动态预览时grread返回值（获取坐标用）
;;;engl_t1 engl_t2 engl_pl为文字、引线的资料串行（动态预览时不断更新）
;;;fh_old sc_old pre_old为对应全局变量的临时存储器
;;;错误处理函数
(defun *Error* (msg)
(if (= msg "quit / exit abort")
(if (/= err_msg nil) (princ err_msg)) ;主动退出时，输出自定义错误信息
(progn (princ (strcat "\nError：" msg));其他错误发生时，输出错误信息
(setq *Error* nil)
)
)
)
;;;计算文字插入点和引线末点函数
(defun poi_calc (sl)
(if (>= (car pb) (car pa))
;插入位置在标注点右侧
(setq ta (list (car pb) (+ (cadr pb) (/ fh 2)) 0)
tb (list (car pb) (- (cadr pb) (/ fh 2)) 0)
pc (list (+ (car pb) sl) (cadr pb) 0)
)
;插入位置在标注点左侧
(setq ta (list (- (car pb) sl) (+ (cadr pb) (/ fh 2)) 0)
tb (list (car ta) (- (cadr pb) (/ fh 2)) 0)
pc (list (car ta) (cadr pb) 0)
)
)
)
;;;程序加载初始化设置
(if (= fh nil)
(setq fh 2.5)
)
(if (= sc nil)
(setq sc 0.001)
)
(if (= pre nil)
(setq pre 3)
)
(if (= exc nil)
(setq exc "Y")
)
(progn
(princ "\n当前参数值字高=")
(princ fh)
(princ "比例=")
(princ sc)
(princ "精度=")
(princ pre)
(princ "交换X Y坐标=")
(princ exc)
)
;;;指定需标注的点或设置字高、比例、精度、交换X Y坐标
(setq pa nil)
(while (= pa nil)
(initget "F S P E")
(setq pa (getpoint
"\n指定要标注的坐标点 或 [字高(F)/比例(S)/精度(P)/交换X Y坐标(E)]:"
)
)
(cond
((= pa "F")
(setq pa nil
fh_old fh
)
(setq fh (getreal (strcat "\n指定字高<" (rtos fh 2) ">：")))
(if (= fh nil) (setq fh fh_old))
(princ (strcat "当前字高=" (rtos fh 2)))
)
((= pa "S")
(setq pa nil
sc_old sc
)
(setq sc (getreal (strcat "\n指定比例<" (rtos sc 2) ">：")))
(if (= sc nil) (setq sc sc_old))
(princ (strcat "当前比例=" (rtos sc 2)))
)
((= pa "P")
(setq pa nil
pre_old pre
)
(setq pre (getint (strcat "\n指定精度<" (rtos pre 2 0) ">：")))
(if (= pre nil) (setq pre pre_old))
(princ (strcat "当前精度=" (rtos pre 2 0)))
)
((= pa "E")
(setq pa nil)
(initget 1 "Y N")
(setq exc (getkword (strcat "\n是否交换X Y坐标[是(Y)/否(N)]<" exc ">：")))
(princ
(strcat "当前交换坐标="
(cond
((= exc "Y") "是")
((= exc "N") "否")
)
)
)
)
((= pa nil) (progn (setq err_msg "取消") (quit)))
(T)
)
)
;;;获取坐标值
(setq DimZin_Old (getvar "DimZin"))
(setvar "DimZin" 1) ;小数末尾0不消除
(if (= exc "N")
(setq Y (rtos (* (cadr pa) sc) 2 pre)
X (rtos (* (car pa) sc) 2 pre)
)
(setq X (rtos (* (cadr pa) sc) 2 pre)
Y (rtos (* (car pa) sc) 2 pre)
)
)
(setvar "DimZin" DimZin_Old) ;恢复环境变量
(setq X (strcat "X=" X)
Y (strcat "Y=" Y)
tbox_x (textbox
(list
'(0 . "text")
(cons 40 fh)
(cons 1 X)
(cons 7 (getvar "textstyle"))
)
)
tbox_y (textbox
(list
'(0 . "text")
(cons 40 fh)
(cons 1 Y)
(cons 7 (getvar "textstyle"))
)
)
)
;;;根据坐标字符串长度计算引线水平段长度
(if (>= (car (cadr tbox_x)) (car (cadr tbox_y)))
(setq sl (car (cadr tbox_x)))
(setq sl (car (cadr tbox_y)))
)
;;;临时指定文字插入点并计算各个插入点初始值，在程序运行中不断更新
(setq pb pa)
(poi_calc sl)
(princ "\n指定文字插入点：")
;;;临时输出文字
(prin_mtxt ta x fh 7)
(setq engl_t1 (entget (entlast)))
(prin_mtxt tb y fh 1)
(setq engl_t2 (entget (entlast)))
;;;临时画引线
(prin_pl pa pb pc)
(setq engl_pl (entget (entlast)))
;;;实时预览
(while (= (car (setq mouse (grread t 13 0))) 5)
(setq pb (cadr mouse))
(poi_calc sl)
(progn
(setq engl_t1 (subst (cons 10 ta) (assoc 10 engl_t1) engl_t1))
(entmod engl_t1)
(setq engl_t2 (subst (cons 10 tb) (assoc 10 engl_t2) engl_t2))
(entmod engl_t2)
(setq engl_pl (update_point_list_of_LWPOLYLINE
engl_pl
(list (cons '10 pa) (cons '10 pb) (cons '10 pc))
)
)
(entmod engl_pl)
)
)
(prin1)
)
;;;绘制文字函数
(defun prin_mtxt (point txt fh position)
(entmake
(list
'(0 . "MText")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
(list 10 (car point) (cadr point))
(cons 40 fh)
(cons 71 position)
(cons 1 txt)
(cons 7 (getvar "textstyle"))
)
)
)
;;;绘制引线函数
(defun prin_pl (p1 p2 p3)
(entmake
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 3)
(cons 10 p1)
(cons 10 p2)
(cons 10 p3)
)
)
)
;;;更新LWPOLYLINE顶点列表
(defun update_point_list_of_LWPOLYLINE (pline point_list / new_pline new_point sub_list)
;这里假设传入的point_list是符合标准的列表
;如果传入的point_list不符合标准，将造成错误，甚至程序崩溃
;有必要的话，应当事先将point_list清洗，剔除不标准数据
(setq new_pline nil)
(foreach sub_list pline
(if (and (= 10 (car sub_list)) (/= point_list nil))
(setq new_point(car point_list)
point_list (cdr point_list)
new_pline(append new_pline (list new_point))
)
(setq new_pline (append new_pline (list sub_list)))
)
)
)
2016.01.15更新：
1、增加是否交换X Y坐标选项。
2、按网友的回复，使小数不消零。(感谢@wzg356@香田里浪人)
3、解决特殊情况引线和文字不对齐的问题。
4、文字改为使用多行文字，（X坐标为左下对齐，Y坐标为左上对齐）。且现在文字样式为当前文字样式（前一版为Standard）。
5、添加了预览功能。（感谢@wzg356）
6、对程序进行了模块化的改写。
本次更新，仍然有些不足之处：
1、原先设想中，引线（多段线）是和文本一样不断更新数据以实现预览。但至今仍不知道如何处理，所以暂行的处理方式是，预览中，不断的删除重绘。
2、尚无错误处理机制。
;;;2016.01.15更新
;;;pa pb pc为引线(多段线)顶点,ta tb为文字基点(均为全局变量)
;;;fh为文字高度,sc为标注比例,pre为坐标值精度,exc为交换X Y坐标标记(均为全局变量)
;;;X Y为坐标,tbox_x tbox_y为判断文字对象长度用临时坐标存储器
;;;sl为文字对象长度(亦即引线水平段长)
;;;cyc为循环标记,DimZin_Old为环境变量临时存储器
;;;mouse为动态预览时grread返回值（获取坐标用）
;;;engl_t1,engl_t2,engl_pl为文字、引线的资料串行（动态预览时不断更新）
(defun c:zb (/ X Ytbox_x tbox_y sl
cyc DimZin_Oldmouse engl_t1engl_t2
engl_pl
)
;;;程序加载初始化设置
(if (= fh nil)
(setq fh 2.5)
)
(if (= sc nil)
(setq sc 0.001)
)
(if (= pre nil)
(setq pre 3)
)
(if (= exc nil)
(setq exc "Y")
)
(progn
(princ "******作者：Thinker(ThinkerHua@hotmail.com)******")
(princ "\n当前参数值 字高：")
(princ fh)
(princ " 比例：")
(princ sc)
(princ " 精度：")
(princ pre)
(princ " 交换X Y坐标：")
(princ exc)
)
(setq DimZin_Old (getvar "DimZin"))
(setvar "DimZin" 1)
;;;指定需标注的点或设置字高、比例、精度、交换X Y坐标
(while (and (= cyc nil) (/= (type pa) 'str))
(initget "F S P E")
(setq
pa
(getpoint
"\n指定要标注的坐标点或[字高(F)/比例(S)/精度(P)/交换X Y坐标(E)]:"
)
)
(cond
((= pa "F")
(progn (setq fh (getreal "\n指定字高："))
(setq pa nil)
)
)
((= pa "S")
(progn (setq sc (getreal "\n指定比例："))
(setq pa nil)
)
)
((= pa "P")
(progn (setq pre (getint "\n指定精度："))
(setq pa nil)
)
)
((= pa "E")
(progn (initget 1 "Y N")
(setq exc (getkword "\n是否交换X Y坐标[是(Y)/否(N)]<Y>:"))
(setq pa nil)
)
)
((= pa nil)
)
(T (setq cyc T))
)
)
(setq cyc nil)
;;;获取坐标值
(if (= exc "N")
(progn (setq Y (rtos (* (cadr pa) sc) 2 pre))
(setq X (rtos (* (car pa) sc) 2 pre))
)
(progn (setq X (rtos (* (cadr pa) sc) 2 pre))
(setq Y (rtos (* (car pa) sc) 2 pre))
)
)
(setq X (strcat "X=" X))
(setq Y (strcat "Y=" Y))
(setvar "DimZin" DimZin_Old)
;;;根据坐标字符串长度计算引线水平段长度
;;;****************************************************************
;;;2015.12.31 本段代码在极端情况下不能实现引线与文字对齐
;;;例如X=11111.111,Y=88888.888 ,原因是各字符不等宽
;;;一般情况均适用，且理论上执行速度比更新后的代码快
;;;(setq tbox (textbox (list
;;; '(0 . "text")
;;; (cons 40 fh)
;;; (cons 1
;;; (if (>= (strlen X) (strlen Y))
;;; X
;;; Y
;;; )
;;; )
;;; )
;;; )
;;;)
;;;(setq sl (- (car (cadr tbox)) (car (car tbox))))
;;;****************************************************************
;;;以下为更新后的代码，任何情况都能实现引线与文字对齐
(setqtbox_x (textbox(list
'(0 . "text")
(cons 40 fh)
(cons 1 X)
(cons 7 (getvar "textstyle"))
)
)
)
(setqtbox_y (textbox(list
'(0 . "text")
(cons 40 fh)
(cons 1 Y)
(cons 7 (getvar "textstyle"))
)
)
)
(if (>= (car (cadr tbox_x)) (car (cadr tbox_y)))
(setq sl (car (cadr tbox_x)))
(setq sl (car (cadr tbox_y)))
)
;;;临时指定文字插入点并计算各个插入点初始值，在程序运行中不断更新
(setq pb pa)
(poi_calc sl)
(princ "\n指定文字插入点：")
;;;输出文字
(prin_mtxt ta x fh 7)
(setq engl_t1 (entget (entlast)))
(prin_mtxt tb y fh 1)
(setq engl_t2 (entget (entlast)))
;;;画引线
(prin_pl pa pb pc)
(setq engl_pl (entget (entlast)))
;;;实时预览
(while (= (car (setq mouse (grread t 13 0))) 5)
(setq pb (cadr mouse))
(poi_calc sl)
(progn
(setq engl_t1 (subst (cons 10 ta) (assoc 10 engl_t1) engl_t1))
(entmod engl_t1)
(setq engl_t2 (subst (cons 10 tb) (assoc 10 engl_t2) engl_t2))
(entmod engl_t2)
;画引线：先删除，再重绘
;;;****************************************************************
;;;××××××不知如何更新多段线多个顶点值，暂如此处理××××××
;;;****************************************************************
(entdel (cdr (car engl_pl)))
(prin_pl pa pb pc)
(setq engl_pl (entget (entlast)))
)
)
(prin1)
)
;;;计算文字插入点和引线末点函数
(defun poi_calc(sl)
(if (>= (car pb) (car pa))
;插入位置在标注点右侧
(setq ta (list (car pb) (+ (cadr pb) (/ fh 2)) 0)
tb (list (car pb) (- (cadr pb) (/ fh 2)) 0)
pc (list (+ (car pb) sl) (cadr pb) 0)
)
;插入位置在标注点左侧
(setq ta (list (- (car pb) sl) (+ (cadr pb) (/ fh 2)) 0)
tb (list (car ta) (- (cadr pb) (/ fh 2)) 0)
pc (list (car ta) (cadr pb) 0)
)
)
)
;;;绘制文字函数
(defun prin_mtxt (point txt fh position)
(entmake (list
'(0 . "MText")
'(100 . "AcDbEntity")
'(100 . "AcDbMText")
(list 10 (car point) (cadr point))
(cons 40 fh)
(cons 71 position)
(cons 1 txt)
(cons 7 (getvar "textstyle"))
)
)
)
;;;绘制引线函数
(defun prin_pl (p1 p2 p3)
(entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 3)
(cons 10 p1)
(cons 10 p2)
(cons 10 p3)
)
)
)
2015.12.23原始内容
从网上下载的网蜂坐标标注插件，总是会出现使用中不能捕捉、使用完后捕捉设置被更改的BUG。
于是便着手自制一个插件，没有以上的问题。但有些不足及没有完全理解之处：
1、不足：不能实时预览；当坐标值小数位数小于指定精度时，不能自动以0补位。
2、没有完全理解之处：list组建群码，没有明白为什么有些要加一个撇 ' ，有些要加一个点 . ，有些要用cons。（下面源码中所用均为拿来主义）
希望各位前辈多多指点。下面贴上源码：
;2015.12.23
;pa pb pc为引线(多段线)顶点
;ta tb为文字基点,X Y为坐标,tbox为判断文字对象长度用临时坐标存储器，sl为文字对象长度(亦即引线水平段长度)
;fh为文字高度,sc为标注比例,pre为坐标值精度(全局变量)
;b为循环标记
(defun c:zb (/ pa pb pc ta tb X Y tb sl b)
;程序加载初始化设置
(if (= fh nil)
(setq fh 2.5)
)
(if (= sc nil)
(setq sc 0.001)
)
(if (= pre nil)
(setq pre 3)
)
(progn
(princ "\n当前参数值：字高")
(princ fh)
(princ " 比例")
(princ sc)
(princ " 精度")
(princ pre)
)
;指定需标注的点或设置字高、比例、精度
(while (and (= b nil) (/= (type pa) 'str))
(initget "F S P")
(setq pa (getpoint "\n指定坐标点或[字高(F)/比例(S)/精度(P)]:"))
(cond ((= pa "F")
(progn (setq fh (getreal "\n指定字高："))
(setq pa nil)
)
)
((= pa "S")
(progn (setq sc (getreal "\n指定比例："))
(setq pa nil)
)
)
((= pa "P")
(progn (setq pre (getint "\n指定精度："))
(setq pa nil)
)
)
(T (setq b t))
)
)
(setq b nil)
;获取坐标值
(setq X (rtos (* (cadr pa) sc) 2 pre))
(setq Y (rtos (* (car pa) sc) 2 pre))
(setq X (strcat "X=" X))
(setq Y (strcat "Y=" Y))
;指定引线折点
(setq pb (getpoint "\n指定文字插入点:"))
;根据坐标字符串长度计算引线水平段长度
(setqtbox (textbox (list
'(0 . "text")
(cons 40 fh)
(cons 1
(if (>= (strlen X) (strlen Y))
X
Y
)
)
'(50 . 0)
)
)
)
(setq sl (- (car (cadr tbox)) (car (car tbox))))
;计算文字插入点和引线末点
(if (>= (car pb) (car pa))
;插入位置在标注点右侧
(setq ta (list (car pb) (+ (cadr pb) (/ fh 2)) 0)
tb (list (car ta) (- (cadr pb) (* 3 (/ fh 2))) 0)
pc (list (+ (car pb) sl) (cadr pb) 0)
)
;插入位置在标注点左侧
(setq ta (list (- (car pb) sl) (+ (cadr pb) (/ fh 2)) 0)
tb (list (car ta) (- (cadr pb) (* 3 (/ fh 2))) 0)
pc (list (car ta) (cadr pb) 0)
)
)
;输出文字
(entmake (list
'(0 . "text")
(list 10 (car ta) (cadr ta))
(cons 40 fh)
(cons 1 X)
'(50 . 0)
)
)
(entmake (list
'(0 . "text")
(list 10 (car tb) (cadr tb))
(cons 40 fh)
(cons 1 Y)
'(50 . 0)
)
)
;画引线
(entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 3)
(cons 10 pa)
(cons 10 pb)
(cons 10 pc)
)
)
(prin1)
)
上下位数不一时只能左对齐，不能自动居中，影响美观 ucs和wcs不一致时，标注位置错误 感谢分享，学习一下，谢谢 学习中，谢谢………… (setvar "dimzin" 1);;;数字不消零 实时预览要用grread获取鼠标坐标然后不断更新图元（引线及文字）位置 支持一下！！！！ 学习中，谢谢………… (setvar"dimzin"0);;保留小数位数时如果位数不足可以补零 路过。。。。。。。。。 支持楼主原创 LISP wzg356 发表于 2015-12-23 16:01 static/image/common/back.gif
(setvar "dimzin" 1);;;数字不消零
感谢你的回复，程序已经改进，还请多多指点。