新手自制的第一个lisp插件：坐标标注。(2022-08-06更新）

ThinkerHua · 发表于 2015-12-23 13:17: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)))
)
)
)

;;;全局变量：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 Y tbox_x tbox_y sl
cyc DimZin_Old mouse engl_t1 engl_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))))
;;;****************************************************************
;;;以下为更新后的代码，任何情况都能实现引线与文字对齐
(setq tbox_x (textbox (list
'(0 . "text")
(cons 40 fh)
(cons 1 X)
(cons 7 (getvar "textstyle"))
)
)
)
(setq 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)
;画引线：先删除，再重绘
;;;****************************************************************
;;;××××××不知如何更新多段线多个顶点值，暂如此处理××××××
;;;****************************************************************
(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)
)
)
)

;;;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         Y  tbox_x   tbox_y    sl 
       cyc      DimZin_Old  mouse   engl_t1  engl_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)))) 
;;;**************************************************************** 
;;;以下为更新后的代码，任何情况都能实现引线与文字对齐 
  (setq  tbox_x (textbox  (list 
        '(0 . "text") 
        (cons 40 fh) 
        (cons 1 X) 
        (cons 7 (getvar "textstyle")) 
      ) 
         ) 
  ) 
  (setq  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) 
          ;画引线：先删除，再重绘 
;;;**************************************************************** 
;;;××××××不知如何更新多段线多个顶点值，暂如此处理×××××× 
;;;**************************************************************** 
      (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指定文字插入点:"))
;根据坐标字符串长度计算引线水平段长度
(setq tbox (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)
)

;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指定文字插入点:")) 
 
          ;根据坐标字符串长度计算引线水平段长度 
  (setq  tbox (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) 
)

lifuq1979 · 发表于 2017-10-18 17:43:53

上下位数不一时只能左对齐，不能自动居中，影响美观

wxssh · 发表于 2023-2-3 13:49:05

ucs和wcs不一致时，标注位置错误

langxuzeng · 发表于 2023-5-19 15:21:20

感谢分享，学习一下，谢谢

知行ooo李肖坪 · 发表于 2015-12-23 14:07:46

学习中，谢谢…………

wzg356 · 发表于 2015-12-23 16:01:01

(setvar "dimzin" 1);;;数字不消零

wzg356 · 发表于 2015-12-23 16:03:34

实时预览要用grread获取鼠标坐标然后不断更新图元（引线及文字）位置

spp_wall · 发表于 2015-12-25 08:43:32

支持一下！！！！

sj800918 · 发表于 2015-12-25 10:59:19

学习中，谢谢…………

香田里浪人 · 发表于 2015-12-25 18:17:32

(setvar"dimzin"0);;保留小数位数时如果位数不足可以补零

hoongdou · 发表于 2015-12-26 13:14:51

路过。。。。。。。。。

F4164789 · 发表于 2015-12-26 14:42:26

支持楼主原创 LISP

ThinkerHua · 发表于 2016-1-18 10:48:46

wzg356 发表于 2015-12-23 16:01
(setvar "dimzin" 1);;;数字不消零

感谢你的回复，程序已经改进，还请多多指点。

账号		自动登录	找回密码
密码			注册

[讨论] 新手自制的第一个lisp插件：坐标标注。(2022-08-06更新）

本帖子中包含更多资源