求助，给多段线节点编号并输出对应的坐标表

jackAqwq · 发表于 2024-7-3 14:24:33

本帖最后由 jackAqwq 于 2024-7-3 14:25 编辑

能不能实现这种功能啊

jackAqwq · 发表于 2024-8-5 01:39:12

本帖最后由 jackAqwq 于 2024-8-5 01:55 编辑

muai2010 发表于 2024-8-5 00:25
已经很不错了，用起来还不错，感谢分享

这个好像能快点

(vl-load-com)
(defun c:ZBB(/ *error* BGZG ent ss ss1 apt1 apt2 apt3 apt4 BGHG apt1Y apt1X DHQZ i DH pt1 ptdh )
;(K:SysVar);修改系统变量
;(command "_undo" "be")
(defun *error* (msg) ;错误处理
(setvar "regenmode" 1)
;;(command "undo" "e")
;;(setvar "cmdecho" 1)
(setvar "DimZin" 1);不消0
(vla-endundomark adoc)
(princ msg)
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark adoc)
(setvar "regenmode" 0);停止自刷新
(setvar "DimZin" 1);数值不消0
;(setvar "TextStyle" LENGTH);数值不消0
(setvar "OSMode" 0);数值不消0
;;;程序加载初始化设置
(if (= nil)
(setq BGZG 2.0) ;文字高度
)
(if (= BGMC nil)
(setq BGMC "人防工程坐标表") ;表格名称
)
(if (= DHQZ nil)
(setq DHQZ "F") ;点号前缀
)
(if (= XY-YX nil)
(setq XY-YX "是") ;交换X Y坐标标记
)
(progn
(princ "\n当前参数值文字高度：")
(princ BGZG)
(princ " 表格名称：")
(princ BGMC)
(princ " 点号前缀：")
(princ DHQZ)
(princ " 交换坐标：")
(princ XY-YX)
)
(setq ent (ssname (ssget) 0))
(setq ss (plgetlsta1 ent))
(setq ss1 ss)
;;;指定需标注的点或设置字高、比例、精度、交换X Y坐标
(setq apt1 nil)
(while (= apt1 nil)
(initget "1 2 3 4")
(setq apt1 (getpoint
"\n表格位置或 [字高(1)/表格名称(2)/点号前缀(3)/交换坐标(4)]:"
)
)
(cond
((= apt1 "1")
(setq apt1 nil
BGZG_old BGZG
)
(setq BGZG (getreal (strcat "\n指定字高<" (rtos BGZG 2) ">：")))
(if (= BGZG nil) (setq BGZG BGZG_old))
(princ (strcat "当前字高：" (rtos BGZG 2)))
)
((= apt1 "2")
(setq apt1 nil
BGMC_old BGMC
)
(setq BGMC (getstring (strcat "\n表格名称<"BGMC">：")))
(if (= BGMC nil) (setq BGMC BGMC_old))
(princ (strcat "当前表名：" BGMC))
)
((= apt1 "3")
(setq apt1 nil
DHQZ_old DHQZ
)
(setq DHQZ (getstring (strcat "\n指定前缀<" DHQZ ">：")))
(if (= DHQZ nil) (setq DHQZ DHQZ_old))
(princ (strcat "当前前缀：" DHQZ))
)
((= apt1 "4")
(setq apt1 nil)
(initget 1 "1 2")
(setq XY-YX (getkword (strcat "\n是否交换坐标[是(1)/否(2)]<" XY-YX ">：")))
(princ
(strcat
"当前交换坐标："
(cond
((= XY-YX "1") "是")
((= XY-YX "2") "否")
)
)
)
)
(T)
)
)
(NewLayer:Name-YanSe BGMC 1)
(setq BGHG (* 3 BGZG));BGHG:表格行高
(setq apt2 (polar apt1 0 (* BGZG 20 )));第一行宽：字高*20
(setq apt3 (polar apt2 (* pi 1.5) BGHG))
(setq apt4 (polar apt1 (* pi 1.5) BGHG))
;(command "_LAYER" "M" BGMC "C" "1" BGMC "");生成图层并设置颜色
;(NewLine:pt1-pt2 apt1 apt4);表头框左边那一行直线
;(NewLine:pt1-pt2 apt1 apt2);表头框上面那一行直线
;(NewLine:pt1-pt2 apt2 apt3);表头框右边那一行直线
;表头框,上面注释掉就不显示表头框
(NewLine:pt1-pt2 apt3 apt4);表头框下面那一行直线
(setq apt1Y (polar apt1 (* pi 1.5) (/ BGHG 2)));
(setq apt1X (polar apt1Y 0 (/ (* BGZG 20)2)));0 16
(NewText:JiDian-NeiRong-ZiGao apt1X "人防工程坐标表" (* 1.2 BGZG) )
(setq i 1)
( BGCS BGZG i apt4 0 )
(repeat (length ss)
( setq apt4 (polar apt4 (* pi 1.5) BGHG))
( setq DH (strcat DHQZ (itoa i) ));点号名称
( setq pt1 (car ss1));点号列表
( setq ptdh (polar pt1 (* pi 0.5) (* 1.25 BGZG )));点号位置
(NewText:JiDian-NeiRong-ZiGao ptdh DH (* 1.0 BGZG ) );顶点生成点号的参数
;( command "text" "MC" ptdh (* 1.0 BGZG )0 DH )
(NewCIRCLE:PT-BJ pt1 (* 0.12 BGZG));顶点生成圆的参数
;( command ".CIRCLE" pt1 (* 0.12 BGZG) );圈大小
( setq ss1 (cdr ss1))
( BGCS BGZG DH apt4 pt1 )
( setq i (1+ i))
)
;(command "_undo" "e")
;(setvar "regenmode" 1)
; (command "regen")
(vla-endundomark adoc)
(setvar "OSMode" 147);数值不消0
;(K:SysVar);恢复系统变量
(princ)
)
;以下是相应函数
;表格参数
(defun BGCS ( BGZG i pt ptzb / w h pta pta1 pta2 pta3)
(setq w (* BGZG 4));列宽
(setq h (* BGZG 3));行高
(NewLine:pt1-pt2 pt (polar pt (* pi 1.5) h));第1列
(NewLine:pt1-pt2 (polar pt (* pi 1.5) h) (polar (polar pt 0 (* w 5)) (* pi 1.5) h));第2行
(NewLine:pt1-pt2 (polar (polar pt 0 (* w 5)) (* pi 1.5) h) (polar pt 0 (* w 5)));第4列
(NewLine:pt1-pt2 (polar pt 0 w) (polar (polar pt 0 w) (* pi 1.5) h));第2列
(NewLine:pt1-pt2 (polar pt 0 (* w 3)) (polar (polar pt 0 (* w 3)) (* pi 1.5) h));第3列
(setq pta (polar pt (* pi 1.5) (* h 0.5)));行高中点
(setq pta1 (polar pta 0 (* w 0.5)));点号列宽中点
(setq pta2 (polar pta 0 (* W 2)));X列宽中点
(setq pta3 (polar pta 0 (* W 4)));Y列宽中点
( if (= ptzb 0)
(progn
(NewText:JiDian-NeiRong-ZiGao pta1 "点号" (* 1.2 BGZG))
(NewText:JiDian-NeiRong-ZiGao pta2 "X" (* 1.2 BGZG))
(NewText:JiDian-NeiRong-ZiGao pta3 "Y" (* 1.2 BGZG))
)
(progn
(if (= XY-YX "2")
(setq X (rtos (cadr ptzb) 2 2)
Y (rtos (car ptzb) 2 2)
)
(setq Y (rtos (cadr ptzb) 2 2)
X (rtos (car ptzb) 2 2)
)
)
(NewText:JiDian-NeiRong-ZiGao pta1 i BGZG)
(NewText:JiDian-NeiRong-ZiGao pta2 Y BGZG)
(NewText:JiDian-NeiRong-ZiGao pta3 X BGZG)
)
)
)
(defun plgetlsta1 (ent)
(mapcar 'cdr (vl-remove-if-not (FUNCTION (LAMBDA (x) (= 10 (car x)))) (entget ent)))
)
;; 创建直线图元
(defun NewLine:pt1-pt2 (pt1 pt2)
(entmake (list '(0 . "LINE")
(cons 10 pt1)
(cons 11 pt2)
)
)
)
;; 创建文字图元
;; 基点-内容-字高
(defun NewText:JiDian-NeiRong-ZiGao (JiDian NeiRong ZiGao )
(entmake
(list
'(0 . "TEXT")
(cons 10 JiDian) ; 插入点
(cons 40 ZiGao) ; 文字高度
(cons 1 NeiRong) ; 文字内容
'(7 . "宋体");字形名称
'(72 . 1);水平对齐方式
'(73 . 2) ;垂直对齐方式
(cons 11 JiDian) ; 对齐插入点
)
))
;;创建图层函数
;;图名-颜色
(defun NewLayer:Name-YanSe (Name YanSe )
(if (not (tblsearch "LAYER" Name)) ;;;判断有没有该图层
(entmake
(list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0);层可见性
(cons 2 Name);图层名称
(cons 62 yanse) ;图层颜色
)
)
)
(setvar "CLAYER" Name)
)
;; 创建圆
;; 圆心-半径
(defun NewCIRCLE:PT-BJ (pt bj)
(entmakex
(list
(cons 0 "CIRCLE")
(cons 10 pt)
(cons 40 bj)
)
))
(princ)

(vl-load-com) 
(defun c:ZBB(/ *error* BGZG  ent  ss ss1 apt1 apt2 apt3 apt4 BGHG apt1Y apt1X DHQZ i DH pt1 ptdh ) 
        ;(K:SysVar);修改系统变量 
        ;(command "_undo" "be") 
        (defun *error* (msg)  ;错误处理 
    (setvar "regenmode" 1) 
    ;;(command "undo" "e") 
    ;;(setvar "cmdecho" 1) 
                (setvar "DimZin" 1);不消0 
    (vla-endundomark adoc) 
    (princ msg) 
  ) 
        (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
        (vla-startundomark adoc) 
        (setvar "regenmode" 0);停止自刷新 
        (setvar "DimZin" 1);数值不消0 
        ;(setvar "TextStyle" LENGTH);数值不消0 
        (setvar "OSMode" 0);数值不消0 
        ;;;程序加载初始化设置 
  (if (=  nil) 
    (setq BGZG 2.0) ;文字高度 
  ) 
  (if (= BGMC nil) 
    (setq BGMC "人防工程坐标表") ;表格名称 
  ) 
  (if (= DHQZ nil) 
    (setq DHQZ "F") ;点号前缀 
  ) 
  (if (= XY-YX nil) 
    (setq XY-YX "是") ;交换X Y坐标标记 
  ) 
  (progn 
    (princ "\n当前参数值  文字高度：") 
    (princ BGZG) 
    (princ "  表格名称：") 
    (princ BGMC) 
    (princ "  点号前缀：") 
    (princ DHQZ) 
    (princ "  交换坐标：") 
    (princ XY-YX) 
  ) 
        (setq ent (ssname (ssget) 0)) 
        (setq ss (plgetlsta1  ent)) 
        (setq ss1 ss) 
        ;;;指定需标注的点或设置字高、比例、精度、交换X Y坐标 
  (setq apt1 nil) 
  (while (= apt1 nil) 
    (initget "1 2 3 4") 
    (setq apt1 (getpoint 
                                                                 "\n表格位置 或 [字高(1)/表格名称(2)/点号前缀(3)/交换坐标(4)]:" 
                                                         ) 
    ) 
    (cond 
      ((= apt1 "1") 
                                (setq apt1     nil 
                                        BGZG_old BGZG 
                                ) 
                                (setq BGZG (getreal (strcat "\n指定字高<" (rtos BGZG 2) ">："))) 
                                (if (= BGZG nil) (setq BGZG BGZG_old)) 
                                (princ (strcat "当前字高：" (rtos BGZG 2))) 
      ) 
      ((= apt1 "2") 
                                (setq apt1     nil 
                                        BGMC_old BGMC 
                                ) 
                                (setq BGMC (getstring (strcat "\n表格名称<"BGMC">："))) 
                                (if (= BGMC nil) (setq BGMC BGMC_old)) 
                                (princ (strcat "当前表名：" BGMC)) 
      ) 
      ((= apt1 "3") 
                                (setq apt1      nil 
                                        DHQZ_old DHQZ 
                                ) 
                                (setq DHQZ (getstring  (strcat "\n指定前缀<" DHQZ ">："))) 
                                (if (= DHQZ nil) (setq DHQZ DHQZ_old)) 
                                (princ (strcat "当前前缀：" DHQZ)) 
                        ) 
                        ((= apt1 "4") 
                                (setq apt1 nil) 
                                (initget 1 "1 2") 
                                (setq XY-YX (getkword (strcat "\n是否交换坐标[是(1)/否(2)]<" XY-YX ">："))) 
                                (princ 
                                        (strcat 
                                                "当前交换坐标：" 
                                                (cond 
                                                        ((= XY-YX "1") "是") 
                                                        ((= XY-YX "2") "否") 
                                                ) 
                                        ) 
                                ) 
                        ) 
                        (T) 
                ) 
        ) 
        (NewLayer:Name-YanSe BGMC 1) 
        (setq BGHG (* 3 BGZG));BGHG:表格行高 
        (setq apt2 (polar apt1 0 (* BGZG 20 )));第一行宽：字高*20 
        (setq apt3 (polar apt2 (* pi 1.5) BGHG)) 
        (setq apt4 (polar apt1 (* pi 1.5) BGHG)) 
        ;(command "_LAYER" "M" BGMC "C" "1" BGMC "");生成图层并设置颜色 
        ;(NewLine:pt1-pt2 apt1 apt4);表头框左边那一行直线 
        ;(NewLine:pt1-pt2 apt1 apt2);表头框上面那一行直线 
        ;(NewLine:pt1-pt2 apt2 apt3);表头框右边那一行直线 
        ;表头框,上面注释掉就不显示表头框 
        (NewLine:pt1-pt2 apt3 apt4);表头框下面那一行直线 
        (setq apt1Y (polar apt1 (* pi 1.5) (/ BGHG 2))); 
        (setq apt1X (polar apt1Y 0 (/ (* BGZG 20)2)));0   16 
        (NewText:JiDian-NeiRong-ZiGao apt1X "人防工程坐标表" (* 1.2 BGZG) ) 
        (setq i 1) 
        ( BGCS BGZG i  apt4   0 ) 
        (repeat (length ss) 
                ( setq apt4 (polar apt4 (* pi 1.5) BGHG)) 
                ( setq DH  (strcat DHQZ (itoa i) ));点号名称 
                ( setq pt1 (car ss1));点号列表 
                ( setq ptdh (polar pt1 (* pi 0.5) (* 1.25 BGZG )));点号位置 
                (NewText:JiDian-NeiRong-ZiGao ptdh DH (* 1.0 BGZG ) );顶点生成点号的参数 
                ;( command "text" "MC" ptdh (* 1.0 BGZG )0 DH ) 
                (NewCIRCLE:PT-BJ pt1 (* 0.12 BGZG));顶点生成圆的参数 
                ;( command ".CIRCLE" pt1 (* 0.12 BGZG) );圈大小 
                ( setq ss1  (cdr ss1)) 
                ( BGCS BGZG DH  apt4  pt1 ) 
                ( setq i (1+ i)) 
        ) 
        ;(command "_undo" "e") 
        ;(setvar "regenmode" 1) 
        ; (command "regen") 
        (vla-endundomark adoc) 
        (setvar "OSMode" 147);数值不消0 
        ;(K:SysVar);恢复系统变量 
        (princ) 
) 
;以下是相应函数 
;表格参数 
(defun BGCS ( BGZG i  pt  ptzb / w h  pta pta1 pta2  pta3) 
        (setq w (* BGZG 4));列宽 
        (setq h (* BGZG 3));行高 
        (NewLine:pt1-pt2 pt (polar pt (* pi 1.5) h));第1列 
        (NewLine:pt1-pt2 (polar pt (* pi 1.5) h) (polar (polar pt 0 (* w 5)) (* pi 1.5) h));第2行 
        (NewLine:pt1-pt2 (polar (polar pt 0 (* w 5)) (* pi 1.5) h) (polar pt 0 (* w 5)));第4列 
        (NewLine:pt1-pt2 (polar pt 0 w) (polar (polar pt 0 w) (* pi 1.5) h));第2列 
        (NewLine:pt1-pt2 (polar pt 0 (* w 3)) (polar (polar pt 0 (* w 3)) (* pi 1.5) h));第3列 
        (setq pta (polar pt (* pi 1.5) (* h 0.5)));行高中点 
        (setq pta1 (polar pta 0 (* w 0.5)));点号列宽中点 
        (setq pta2 (polar pta 0 (* W 2)));X列宽中点 
        (setq pta3 (polar pta 0 (* W 4)));Y列宽中点 
        ( if (= ptzb 0) 
                (progn 
                        (NewText:JiDian-NeiRong-ZiGao pta1 "点号" (* 1.2 BGZG)) 
                        (NewText:JiDian-NeiRong-ZiGao pta2 "X" (* 1.2 BGZG)) 
                        (NewText:JiDian-NeiRong-ZiGao pta3 "Y" (* 1.2 BGZG)) 
                ) 
                (progn 
                        (if (= XY-YX "2") 
                                (setq X (rtos (cadr ptzb) 2 2) 
          Y (rtos (car ptzb) 2 2) 
                                ) 
                                (setq Y (rtos (cadr ptzb) 2 2) 
          X (rtos (car ptzb) 2 2) 
                                ) 
                        ) 
                        (NewText:JiDian-NeiRong-ZiGao pta1 i BGZG) 
                        (NewText:JiDian-NeiRong-ZiGao pta2 Y BGZG) 
                        (NewText:JiDian-NeiRong-ZiGao pta3 X BGZG) 
                ) 
        ) 
) 
(defun plgetlsta1 (ent) 
        (mapcar 'cdr (vl-remove-if-not (FUNCTION (LAMBDA (x) (= 10 (car x)))) (entget ent))) 
) 
;; 创建直线图元 
(defun NewLine:pt1-pt2 (pt1 pt2) 
        (entmake (list '(0 . "LINE") 
                                                 (cons 10 pt1) 
                                                 (cons 11 pt2) 
                                         ) 
        ) 
) 
;; 创建文字图元 
;; 基点-内容-字高 
(defun NewText:JiDian-NeiRong-ZiGao (JiDian NeiRong ZiGao ) 
  (entmake 
    (list 
      '(0 . "TEXT") 
      (cons 10 JiDian)  ; 插入点 
      (cons 40 ZiGao)  ; 文字高度 
      (cons 1 NeiRong)  ; 文字内容 
      '(7 . "宋体");字形名称 
                        '(72 . 1);水平对齐方式 
      '(73 . 2) ;垂直对齐方式 
      (cons 11 JiDian)  ; 对齐插入点 
    ) 
  )) 
;;创建图层函数 
;;图名-颜色 
(defun NewLayer:Name-YanSe (Name YanSe ) 
        (if (not (tblsearch "LAYER" Name))  ;;;判断有没有该图层 
                (entmake 
                        (list 
                                '(0 . "LAYER") 
                                '(100 . "AcDbSymbolTableRecord") 
                                '(100 . "AcDbLayerTableRecord") 
                                '(70 . 0);层可见性 
                                (cons 2 Name);图层名称 
                                (cons 62 yanse) ;图层颜色 
                        ) 
                ) 
        ) 
        (setvar "CLAYER" Name) 
) 
;; 创建圆 
;; 圆心-半径 
(defun NewCIRCLE:PT-BJ (pt bj) 
  (entmakex 
                (list 
                        (cons 0 "CIRCLE") 
                        (cons 10 pt) 
                        (cons 40 bj) 
                ) 
        )) 
(princ)

muai2010 · 发表于 2024-8-5 09:47:07

jackAqwq 发表于 2024-8-5 01:39
这个好像能快点

太晚有一处没改到，帮你改下

(vl-load-com)
(defun c:ZBB(/ *error* BGZG ent ss ss1 apt1 apt2 apt3 apt4 BGHG apt1Y apt1X DHQZ i DH pt1 ptdh )
;(K:SysVar);修改系统变量
;(command "_undo" "be")
(defun *error* (msg) ;错误处理
(setvar "regenmode" 1)
;;(command "undo" "e")
;;(setvar "cmdecho" 1)
(setvar "DimZin" 1);不消0
(vla-endundomark adoc)
(princ msg)
)
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
(vla-startundomark adoc)
(setvar "regenmode" 0);停止自刷新
(setvar "DimZin" 1);数值不消0
;(setvar "TextStyle" LENGTH);数值不消0
(setvar "OSMode" 0);数值不消0
;;;程序加载初始化设置
(if (= nil)
(setq BGZG 2.0) ;文字高度
)
(if (= BGMC nil)
(setq BGMC "人防工程坐标表") ;表格名称
)
(if (= DHQZ nil)
(setq DHQZ "F") ;点号前缀
)
(if (= XY-YX nil)
(setq XY-YX "是") ;交换X Y坐标标记
)
(progn
(princ "\n当前参数值文字高度：")
(princ BGZG)
(princ " 表格名称：")
(princ BGMC)
(princ " 点号前缀：")
(princ DHQZ)
(princ " 交换坐标：")
(princ XY-YX)
)
(setq ent (ssname (ssget) 0))
(setq ss (plgetlsta1 ent))
(setq ss1 ss)
;;;指定需标注的点或设置字高、比例、精度、交换X Y坐标
(setq apt1 nil)
(while (= apt1 nil)
(initget "1 2 3 4")
(setq apt1 (getpoint
"\n表格位置或 [字高(1)/表格名称(2)/点号前缀(3)/交换坐标(4)]:"
)
)
(cond
((= apt1 "1")
(setq apt1 nil
BGZG_old BGZG
)
(setq BGZG (getreal (strcat "\n指定字高<" (rtos BGZG 2) ">：")))
(if (= BGZG nil) (setq BGZG BGZG_old))
(princ (strcat "当前字高：" (rtos BGZG 2)))
)
((= apt1 "2")
(setq apt1 nil
BGMC_old BGMC
)
(setq BGMC (getstring (strcat "\n表格名称<"BGMC">：")))
(if (= BGMC nil) (setq BGMC BGMC_old))
(princ (strcat "当前表名：" BGMC))
)
((= apt1 "3")
(setq apt1 nil
DHQZ_old DHQZ
)
(setq DHQZ (getstring (strcat "\n指定前缀<" DHQZ ">：")))
(if (= DHQZ nil) (setq DHQZ DHQZ_old))
(princ (strcat "当前前缀：" DHQZ))
)
((= apt1 "4")
(setq apt1 nil)
(initget 1 "1 2")
(setq XY-YX (getkword (strcat "\n是否交换坐标[是(1)/否(2)]<" XY-YX ">：")))
(princ
(strcat
"当前交换坐标："
(cond
((= XY-YX "1") "是")
((= XY-YX "2") "否")
)
)
)
)
(T)
)
)
(NewLayer:Name-YanSe BGMC 1)
(setq BGHG (* 3 BGZG));BGHG:表格行高
(setq apt2 (polar apt1 0 (* BGZG 20 )));第一行宽：字高*20
(setq apt3 (polar apt2 (* pi 1.5) BGHG))
(setq apt4 (polar apt1 (* pi 1.5) BGHG))
;(command "_LAYER" "M" BGMC "C" "1" BGMC "");生成图层并设置颜色
;(NewLine:pt1-pt2 apt1 apt4);表头框左边那一行直线
;(NewLine:pt1-pt2 apt1 apt2);表头框上面那一行直线
;(NewLine:pt1-pt2 apt2 apt3);表头框右边那一行直线
;表头框,上面注释掉就不显示表头框
(NewLine:pt1-pt2 apt3 apt4);表头框下面那一行直线
(setq apt1Y (polar apt1 (* pi 1.5) (/ BGHG 2)));
(setq apt1X (polar apt1Y 0 (/ (* BGZG 20)2)));0 16
(NewText:JiDian-NeiRong-ZiGao apt1X BGMC (* 1.2 BGZG) )
(setq i 1)
( BGCS BGZG i apt4 0 )
(repeat (length ss)
( setq apt4 (polar apt4 (* pi 1.5) BGHG))
( setq DH (strcat DHQZ (itoa i) ));点号名称
( setq pt1 (car ss1));点号列表
( setq ptdh (polar pt1 (* pi 0.5) (* 1.25 BGZG )));点号位置
(NewText:JiDian-NeiRong-ZiGao ptdh DH (* 1.0 BGZG ) );顶点生成点号的参数
;( command "text" "MC" ptdh (* 1.0 BGZG )0 DH )
(NewCIRCLE:PT-BJ pt1 (* 0.12 BGZG));顶点生成圆的参数
;( command ".CIRCLE" pt1 (* 0.12 BGZG) );圈大小
( setq ss1 (cdr ss1))
( BGCS BGZG DH apt4 pt1 )
( setq i (1+ i))
)
;(command "_undo" "e")
;(setvar "regenmode" 1)
; (command "regen")
(vla-endundomark adoc)
(setvar "OSMode" 147);数值不消0
;(K:SysVar);恢复系统变量
(princ)
)
;以下是相应函数
;表格参数
(defun BGCS ( BGZG i pt ptzb / w h pta pta1 pta2 pta3)
(setq w (* BGZG 4));列宽
(setq h (* BGZG 3));行高
(NewLine:pt1-pt2 pt (polar pt (* pi 1.5) h));第1列
(NewLine:pt1-pt2 (polar pt (* pi 1.5) h) (polar (polar pt 0 (* w 5)) (* pi 1.5) h));第2行
(NewLine:pt1-pt2 (polar (polar pt 0 (* w 5)) (* pi 1.5) h) (polar pt 0 (* w 5)));第4列
(NewLine:pt1-pt2 (polar pt 0 w) (polar (polar pt 0 w) (* pi 1.5) h));第2列
(NewLine:pt1-pt2 (polar pt 0 (* w 3)) (polar (polar pt 0 (* w 3)) (* pi 1.5) h));第3列
(setq pta (polar pt (* pi 1.5) (* h 0.5)));行高中点
(setq pta1 (polar pta 0 (* w 0.5)));点号列宽中点
(setq pta2 (polar pta 0 (* W 2)));X列宽中点
(setq pta3 (polar pta 0 (* W 4)));Y列宽中点
( if (= ptzb 0)
(progn
(NewText:JiDian-NeiRong-ZiGao pta1 "点号" (* 1.2 BGZG))
(NewText:JiDian-NeiRong-ZiGao pta2 "X" (* 1.2 BGZG))
(NewText:JiDian-NeiRong-ZiGao pta3 "Y" (* 1.2 BGZG))
)
(progn
(if (= XY-YX "2")
(setq X (rtos (cadr ptzb) 2 2)
Y (rtos (car ptzb) 2 2)
)
(setq Y (rtos (cadr ptzb) 2 2)
X (rtos (car ptzb) 2 2)
)
)
(NewText:JiDian-NeiRong-ZiGao pta1 i BGZG)
(NewText:JiDian-NeiRong-ZiGao pta2 Y BGZG)
(NewText:JiDian-NeiRong-ZiGao pta3 X BGZG)
)
)
)
(defun plgetlsta1 (ent)
(mapcar 'cdr (vl-remove-if-not (FUNCTION (LAMBDA (x) (= 10 (car x)))) (entget ent)))
)
;; 创建直线图元
(defun NewLine:pt1-pt2 (pt1 pt2)
(entmake (list '(0 . "LINE")
(cons 10 pt1)
(cons 11 pt2)
)
)
)
;; 创建文字图元
;; 基点-内容-字高
(defun NewText:JiDian-NeiRong-ZiGao (JiDian NeiRong ZiGao )
(entmake
(list
'(0 . "TEXT")
(cons 10 JiDian) ; 插入点
(cons 40 ZiGao) ; 文字高度
(cons 1 NeiRong) ; 文字内容
'(7 . "宋体");字形名称
'(72 . 1);水平对齐方式
'(73 . 2) ;垂直对齐方式
(cons 11 JiDian) ; 对齐插入点
)
))
;;创建图层函数
;;图名-颜色
(defun NewLayer:Name-YanSe (Name YanSe )
(if (not (tblsearch "LAYER" Name)) ;;;判断有没有该图层
(entmake
(list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0);层可见性
(cons 2 Name);图层名称
(cons 62 yanse) ;图层颜色
)
)
)
(setvar "CLAYER" Name)
)
;; 创建圆
;; 圆心-半径
(defun NewCIRCLE:PT-BJ (pt bj)
(entmakex
(list
(cons 0 "CIRCLE")
(cons 10 pt)
(cons 40 bj)
)
))
(princ)

(vl-load-com) 
(defun c:ZBB(/ *error* BGZG  ent  ss ss1 apt1 apt2 apt3 apt4 BGHG apt1Y apt1X DHQZ i DH pt1 ptdh ) 
        ;(K:SysVar);修改系统变量 
        ;(command "_undo" "be") 
        (defun *error* (msg)  ;错误处理 
    (setvar "regenmode" 1) 
    ;;(command "undo" "e") 
    ;;(setvar "cmdecho" 1) 
                (setvar "DimZin" 1);不消0 
    (vla-endundomark adoc) 
    (princ msg) 
  ) 
        (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
        (vla-startundomark adoc) 
        (setvar "regenmode" 0);停止自刷新 
        (setvar "DimZin" 1);数值不消0 
        ;(setvar "TextStyle" LENGTH);数值不消0 
        (setvar "OSMode" 0);数值不消0 
        ;;;程序加载初始化设置 
  (if (=  nil) 
    (setq BGZG 2.0) ;文字高度 
  ) 
  (if (= BGMC nil) 
    (setq BGMC "人防工程坐标表") ;表格名称 
  ) 
  (if (= DHQZ nil) 
    (setq DHQZ "F") ;点号前缀 
  ) 
  (if (= XY-YX nil) 
    (setq XY-YX "是") ;交换X Y坐标标记 
  ) 
  (progn 
    (princ "\n当前参数值  文字高度：") 
    (princ BGZG) 
    (princ "  表格名称：") 
    (princ BGMC) 
    (princ "  点号前缀：") 
    (princ DHQZ) 
    (princ "  交换坐标：") 
    (princ XY-YX) 
  ) 
        (setq ent (ssname (ssget) 0)) 
        (setq ss (plgetlsta1  ent)) 
        (setq ss1 ss) 
        ;;;指定需标注的点或设置字高、比例、精度、交换X Y坐标 
  (setq apt1 nil) 
  (while (= apt1 nil) 
    (initget "1 2 3 4") 
    (setq apt1 (getpoint 
                                                                 "\n表格位置 或 [字高(1)/表格名称(2)/点号前缀(3)/交换坐标(4)]:" 
                                                         ) 
    ) 
    (cond 
      ((= apt1 "1") 
                                (setq apt1     nil 
                                        BGZG_old BGZG 
                                ) 
                                (setq BGZG (getreal (strcat "\n指定字高<" (rtos BGZG 2) ">："))) 
                                (if (= BGZG nil) (setq BGZG BGZG_old)) 
                                (princ (strcat "当前字高：" (rtos BGZG 2))) 
      ) 
      ((= apt1 "2") 
                                (setq apt1     nil 
                                        BGMC_old BGMC 
                                ) 
                                (setq BGMC (getstring (strcat "\n表格名称<"BGMC">："))) 
                                (if (= BGMC nil) (setq BGMC BGMC_old)) 
                                (princ (strcat "当前表名：" BGMC)) 
      ) 
      ((= apt1 "3") 
                                (setq apt1      nil 
                                        DHQZ_old DHQZ 
                                ) 
                                (setq DHQZ (getstring  (strcat "\n指定前缀<" DHQZ ">："))) 
                                (if (= DHQZ nil) (setq DHQZ DHQZ_old)) 
                                (princ (strcat "当前前缀：" DHQZ)) 
                        ) 
                        ((= apt1 "4") 
                                (setq apt1 nil) 
                                (initget 1 "1 2") 
                                (setq XY-YX (getkword (strcat "\n是否交换坐标[是(1)/否(2)]<" XY-YX ">："))) 
                                (princ 
                                        (strcat 
                                                "当前交换坐标：" 
                                                (cond 
                                                        ((= XY-YX "1") "是") 
                                                        ((= XY-YX "2") "否") 
                                                ) 
                                        ) 
                                ) 
                        ) 
                        (T) 
                ) 
        ) 
        (NewLayer:Name-YanSe BGMC 1) 
        (setq BGHG (* 3 BGZG));BGHG:表格行高 
        (setq apt2 (polar apt1 0 (* BGZG 20 )));第一行宽：字高*20 
        (setq apt3 (polar apt2 (* pi 1.5) BGHG)) 
        (setq apt4 (polar apt1 (* pi 1.5) BGHG)) 
        ;(command "_LAYER" "M" BGMC "C" "1" BGMC "");生成图层并设置颜色 
        ;(NewLine:pt1-pt2 apt1 apt4);表头框左边那一行直线 
        ;(NewLine:pt1-pt2 apt1 apt2);表头框上面那一行直线 
        ;(NewLine:pt1-pt2 apt2 apt3);表头框右边那一行直线 
        ;表头框,上面注释掉就不显示表头框 
        (NewLine:pt1-pt2 apt3 apt4);表头框下面那一行直线 
        (setq apt1Y (polar apt1 (* pi 1.5) (/ BGHG 2))); 
        (setq apt1X (polar apt1Y 0 (/ (* BGZG 20)2)));0   16 
        (NewText:JiDian-NeiRong-ZiGao apt1X BGMC (* 1.2 BGZG) ) 
        (setq i 1) 
        ( BGCS BGZG i  apt4   0 ) 
        (repeat (length ss) 
                ( setq apt4 (polar apt4 (* pi 1.5) BGHG)) 
                ( setq DH  (strcat DHQZ (itoa i) ));点号名称 
                ( setq pt1 (car ss1));点号列表 
                ( setq ptdh (polar pt1 (* pi 0.5) (* 1.25 BGZG )));点号位置 
                (NewText:JiDian-NeiRong-ZiGao ptdh DH (* 1.0 BGZG ) );顶点生成点号的参数 
                ;( command "text" "MC" ptdh (* 1.0 BGZG )0 DH ) 
                (NewCIRCLE:PT-BJ pt1 (* 0.12 BGZG));顶点生成圆的参数 
                ;( command ".CIRCLE" pt1 (* 0.12 BGZG) );圈大小 
                ( setq ss1  (cdr ss1)) 
                ( BGCS BGZG DH  apt4  pt1 ) 
                ( setq i (1+ i)) 
        ) 
        ;(command "_undo" "e") 
        ;(setvar "regenmode" 1) 
        ; (command "regen") 
        (vla-endundomark adoc) 
        (setvar "OSMode" 147);数值不消0 
        ;(K:SysVar);恢复系统变量 
        (princ) 
) 
;以下是相应函数 
;表格参数 
(defun BGCS ( BGZG i  pt  ptzb / w h  pta pta1 pta2  pta3) 
        (setq w (* BGZG 4));列宽 
        (setq h (* BGZG 3));行高 
        (NewLine:pt1-pt2 pt (polar pt (* pi 1.5) h));第1列 
        (NewLine:pt1-pt2 (polar pt (* pi 1.5) h) (polar (polar pt 0 (* w 5)) (* pi 1.5) h));第2行 
        (NewLine:pt1-pt2 (polar (polar pt 0 (* w 5)) (* pi 1.5) h) (polar pt 0 (* w 5)));第4列 
        (NewLine:pt1-pt2 (polar pt 0 w) (polar (polar pt 0 w) (* pi 1.5) h));第2列 
        (NewLine:pt1-pt2 (polar pt 0 (* w 3)) (polar (polar pt 0 (* w 3)) (* pi 1.5) h));第3列 
        (setq pta (polar pt (* pi 1.5) (* h 0.5)));行高中点 
        (setq pta1 (polar pta 0 (* w 0.5)));点号列宽中点 
        (setq pta2 (polar pta 0 (* W 2)));X列宽中点 
        (setq pta3 (polar pta 0 (* W 4)));Y列宽中点 
        ( if (= ptzb 0) 
                (progn 
                        (NewText:JiDian-NeiRong-ZiGao pta1 "点号" (* 1.2 BGZG)) 
                        (NewText:JiDian-NeiRong-ZiGao pta2 "X" (* 1.2 BGZG)) 
                        (NewText:JiDian-NeiRong-ZiGao pta3 "Y" (* 1.2 BGZG)) 
                ) 
                (progn 
                        (if (= XY-YX "2") 
                                (setq X (rtos (cadr ptzb) 2 2) 
          Y (rtos (car ptzb) 2 2) 
                                ) 
                                (setq Y (rtos (cadr ptzb) 2 2) 
          X (rtos (car ptzb) 2 2) 
                                ) 
                        ) 
                        (NewText:JiDian-NeiRong-ZiGao pta1 i BGZG) 
                        (NewText:JiDian-NeiRong-ZiGao pta2 Y BGZG) 
                        (NewText:JiDian-NeiRong-ZiGao pta3 X BGZG) 
                ) 
        ) 
) 
(defun plgetlsta1 (ent) 
        (mapcar 'cdr (vl-remove-if-not (FUNCTION (LAMBDA (x) (= 10 (car x)))) (entget ent))) 
) 
;; 创建直线图元 
(defun NewLine:pt1-pt2 (pt1 pt2) 
        (entmake (list '(0 . "LINE") 
                                                 (cons 10 pt1) 
                                                 (cons 11 pt2) 
                                         ) 
        ) 
) 
;; 创建文字图元 
;; 基点-内容-字高 
(defun NewText:JiDian-NeiRong-ZiGao (JiDian NeiRong ZiGao ) 
  (entmake 
    (list 
      '(0 . "TEXT") 
      (cons 10 JiDian)  ; 插入点 
      (cons 40 ZiGao)  ; 文字高度 
      (cons 1 NeiRong)  ; 文字内容 
      '(7 . "宋体");字形名称 
                        '(72 . 1);水平对齐方式 
      '(73 . 2) ;垂直对齐方式 
      (cons 11 JiDian)  ; 对齐插入点 
    ) 
  )) 
;;创建图层函数 
;;图名-颜色 
(defun NewLayer:Name-YanSe (Name YanSe ) 
        (if (not (tblsearch "LAYER" Name))  ;;;判断有没有该图层 
                (entmake 
                        (list 
                                '(0 . "LAYER") 
                                '(100 . "AcDbSymbolTableRecord") 
                                '(100 . "AcDbLayerTableRecord") 
                                '(70 . 0);层可见性 
                                (cons 2 Name);图层名称 
                                (cons 62 yanse) ;图层颜色 
                        ) 
                ) 
        ) 
        (setvar "CLAYER" Name) 
) 
;; 创建圆 
;; 圆心-半径 
(defun NewCIRCLE:PT-BJ (pt bj) 
  (entmakex 
                (list 
                        (cons 0 "CIRCLE") 
                        (cons 10 pt) 
                        (cons 40 bj) 
                ) 
        )) 
(princ)

jackAqwq · 发表于 2024-8-4 16:00:13

本帖最后由 jackAqwq 于 2024-8-4 16:02 编辑

缝缝补补，勉强够用

(vl-load-com)
(defun c:ZBB(/ BGZG ent ss ss1 apt1 apt2 apt3 apt4 BGHG apt1Y apt1X aa i ii pt1 ptdh )
(K:SysVar);修改系统变量
(command "_undo" "be")
;;;程序加载初始化设置
(if (= nil)
(setq BGZG 2.0) ;文字高度
)
(if (= BGMC nil)
(setq BGMC "人防工程坐标表") ;表格名称
)
(if (= DHQZ nil)
(setq DHQZ "F") ;点号前缀
)
(if (= XY-YX nil)
(setq XY-YX "是") ;交换X Y坐标标记
)
(progn
(princ "\n当前参数值文字高度：")
(princ BGZG)
(princ " 表格名称：")
(princ BGMC)
(princ " 点号前缀：")
(princ DHQZ)
(princ " 交换坐标：")
(princ XY-YX)
)
(setq ent (ssname (ssget) 0))
(setq ss (plgetlsta1 ent))
(setq ss1 ss)
;;;指定需标注的点或设置字高、比例、精度、交换X Y坐标
(setq apt1 nil)
(while (= apt1 nil)
(initget "1 2 3 4")
(setq apt1 (getpoint
"\n表格位置或 [字高(1)/表格名称(2)/点号前缀(3)/交换坐标(4)]:"
)
)
(cond
((= apt1 "1")
(setq apt1 nil
BGZG_old BGZG
)
(setq BGZG (getreal (strcat "\n指定字高<" (rtos BGZG 2) ">：")))
(if (= BGZG nil) (setq BGZG BGZG_old))
(princ (strcat "当前字高：" (rtos BGZG 2)))
)
((= apt1 "2")
(setq apt1 nil
BGMC_old BGMC
)
(setq BGMC (getstring (strcat "\n表格名称<"BGMC">：")))
(if (= BGMC nil) (setq BGMC BGMC_old))
(princ (strcat "当前表名：" BGMC))
)
((= apt1 "3")
(setq apt1 nil
DHQZ_old DHQZ
)
(setq DHQZ (getstring (strcat "\n指定前缀<" DHQZ ">：")))
(if (= DHQZ nil) (setq DHQZ DHQZ_old))
(princ (strcat "当前前缀：" DHQZ))
)
((= apt1 "4")
(setq apt1 nil)
(initget 1 "1 2")
(setq XY-YX (getkword (strcat "\n是否交换坐标[是(1)/否(2)]<" XY-YX ">：")))
(princ
(strcat
"当前交换坐标："
(cond
((= XY-YX "1") "是")
((= XY-YX "2") "否")
)
)
)
)
(T)
)
)
(NewLayer:Name-YanSe BGMC 1)
(setq BGHG (* 3 BGZG));BGHG:表格行高
(setq apt2 (polar apt1 0 (* BGZG 20 )));第一行宽：字高*20
(setq apt3 (polar apt2 (* pi 1.5) BGHG))
(setq apt4 (polar apt1 (* pi 1.5) BGHG))
;(command "_LAYER" "M" BGMC "C" "1" BGMC "");生成图层并设置颜色
;(NewLine:pt1-pt2 apt1 apt4);表头框左边那一行直线
;(NewLine:pt1-pt2 apt1 apt2);表头框上面那一行直线
;(NewLine:pt1-pt2 apt2 apt3);表头框右边那一行直线
;表头框,上面注释掉就不显示表头框
(NewLine:pt1-pt2 apt3 apt4);表头框下面那一行直线
(setq apt1Y (polar apt1 (* pi 1.5) (/ BGHG 2)));
(setq apt1X (polar apt1Y 0 (/ (* BGZG 20)2)));0 16
(NewText-:JiDian-NeiRong-ZiGao apt1X "人防工程坐标表" (* 1.2 BGZG) )
(setq i 1)
( gxba BGZG i apt4 0 )
(repeat (length ss)
( setq apt4 (polar apt4 (* pi 1.5) BGHG))
( setq ii (strcat DHQZ (itoa i) ));点号名称
( setq pt1 (car ss1));点号列表
( setq ptdh (polar pt1 (* pi 0.5) (* 1.25 BGZG )));点号位置
( command "text" "MC" ptdh (* 1.0 BGZG )0 ii )
( command ".CIRCLE" pt1 (* 0.12 BGZG) );圈大小
( setq ss1 (cdr ss1))
( gxba BGZG ii apt4 pt1 )
( setq i (1+ i))
)
(command "_undo" "e")
(K:SysVar);恢复系统变量
(princ)
)
;以下是相应函数
(defun gxba ( BGZG i pt ptzb / w h pta pta1 pta2 pta3)
(setq w (* BGZG 4));列宽
(setq h (* BGZG 3));行高
(NewLine:pt1-pt2 pt (polar pt (* pi 1.5) h));第1列
(NewLine:pt1-pt2 (polar pt (* pi 1.5) h) (polar (polar pt 0 (* w 5)) (* pi 1.5) h));第2行
(NewLine:pt1-pt2 (polar (polar pt 0 (* w 5)) (* pi 1.5) h) (polar pt 0 (* w 5)));第4列
(NewLine:pt1-pt2 (polar pt 0 w) (polar (polar pt 0 w) (* pi 1.5) h));第2列
(NewLine:pt1-pt2 (polar pt 0 (* w 3)) (polar (polar pt 0 (* w 3)) (* pi 1.5) h));第3列
(setq pta (polar pt (* pi 1.5) (* h 0.5)));行高中点
(setq pta1 (polar pta 0 (* w 0.5)));点号列宽中点
(setq pta2 (polar pta 0 (* W 2)));X列宽中点
(setq pta3 (polar pta 0 (* W 4)));Y列宽中点
( if (= ptzb 0)
(progn
(NewText-:JiDian-NeiRong-ZiGao pta1 "点号" (* 1.2 BGZG))
(NewText-:JiDian-NeiRong-ZiGao pta2 "X" (* 1.2 BGZG))
(NewText-:JiDian-NeiRong-ZiGao pta3 "Y" (* 1.2 BGZG))
)
(progn
(if (= XY-YX "2")
(setq X (rtos (cadr ptzb) 2 2)
Y (rtos (car ptzb) 2 2)
)
(setq Y (rtos (cadr ptzb) 2 2)
X (rtos (car ptzb) 2 2)
)
)
(NewText-:JiDian-NeiRong-ZiGao pta1 i BGZG)
(NewText-:JiDian-NeiRong-ZiGao pta2 Y BGZG)
(NewText-:JiDian-NeiRong-ZiGao pta3 X BGZG)
)
)
)
(defun plgetlsta1 (ent)
(mapcar 'cdr (vl-remove-if-not (FUNCTION (LAMBDA (x) (= 10 (car x)))) (entget ent)))
)
;修改或恢复系统变量函数
(defun K:SysVar ()
(if (not *Old_vars*)
(progn
(setq *New_vars* '((cmdecho 0);取消回显
(OSMode 0);禁用捕捉
(expert 5);禁止提示冲突(默认Yes)
(DimZin 1);不消0
(TextStyle "宋体");设置字体样式
))
(setq *Old_vars* (mapcar'(lambda (a / b)(if (and(setq b (getvar (car a)))(/= b (cadr a)))
(progn
(apply 'setvar a)
(list (car a) b))))
*New_vars*
)
)
(setq *New_vars* nil)
)
(progn
(foreach xx *Old_vars* (if xx (apply 'setvar xx)))
(setq *Old_vars* nil)
)
)
)
;; 创建直线图元
(defun NewLine:pt1-pt2 (pt1 pt2)
(entmake (list '(0 . "LINE")
(cons 10 pt1)
(cons 11 pt2)
)
)
)
;; 创建文字图元
(defun NewText-:JiDian-NeiRong-ZiGao (JiDian NeiRong ZiGao )
(entmake
(list
'(0 . "TEXT")
(cons 10 JiDian) ; 插入点
(cons 40 ZiGao) ; 文字高度
(cons 1 NeiRong) ; 文字内容
'(7 . "宋体");字形名称
'(72 . 1);水平对齐方式
'(73 . 2) ;垂直对齐方式
(cons 11 JiDian) ; 对齐插入点
)
))
;;创建图层函数
;;图名-线型-颜色-打印-线宽
(defun NewLayer:Name-YanSe (Name YanSe )
(if (not (tblsearch "LAYER" Name)) ;;;判断有没有该图层
(entmake
(list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0);层可见性
(cons 2 Name);图层名称
(cons 62 yanse) ;图层颜色
)
)
)
(setvar "CLAYER" Name)
)
(princ)

(vl-load-com) 
(defun c:ZBB(/ BGZG  ent  ss ss1 apt1 apt2 apt3 apt4 BGHG apt1Y apt1X aa i ii pt1 ptdh ) 
  (K:SysVar);修改系统变量 
  (command "_undo" "be") 
  ;;;程序加载初始化设置 
  (if (=  nil) 
    (setq BGZG 2.0) ;文字高度 
  ) 
  (if (= BGMC nil) 
    (setq BGMC "人防工程坐标表") ;表格名称 
  ) 
  (if (= DHQZ nil) 
    (setq DHQZ "F") ;点号前缀 
  ) 
  (if (= XY-YX nil) 
    (setq XY-YX "是") ;交换X Y坐标标记 
  ) 
  (progn 
    (princ "\n当前参数值  文字高度：") 
    (princ BGZG) 
    (princ "  表格名称：") 
    (princ BGMC) 
    (princ "  点号前缀：") 
    (princ DHQZ) 
    (princ "  交换坐标：") 
    (princ XY-YX) 
  ) 
  (setq ent (ssname (ssget) 0)) 
  (setq ss (plgetlsta1  ent)) 
  (setq ss1 ss) 
  ;;;指定需标注的点或设置字高、比例、精度、交换X Y坐标 
  (setq apt1 nil) 
  (while (= apt1 nil) 
    (initget "1 2 3 4") 
    (setq apt1 (getpoint 
                 "\n表格位置 或 [字高(1)/表格名称(2)/点号前缀(3)/交换坐标(4)]:" 
               ) 
    ) 
    (cond 
      ((= apt1 "1") 
        (setq apt1     nil 
          BGZG_old BGZG 
        ) 
        (setq BGZG (getreal (strcat "\n指定字高<" (rtos BGZG 2) ">："))) 
        (if (= BGZG nil) (setq BGZG BGZG_old)) 
        (princ (strcat "当前字高：" (rtos BGZG 2))) 
      ) 
      ((= apt1 "2") 
        (setq apt1     nil 
          BGMC_old BGMC 
        ) 
        (setq BGMC (getstring (strcat "\n表格名称<"BGMC">："))) 
        (if (= BGMC nil) (setq BGMC BGMC_old)) 
        (princ (strcat "当前表名：" BGMC)) 
      ) 
      ((= apt1 "3") 
        (setq apt1      nil 
          DHQZ_old DHQZ 
        ) 
        (setq DHQZ (getstring  (strcat "\n指定前缀<" DHQZ ">："))) 
        (if (= DHQZ nil) (setq DHQZ DHQZ_old)) 
        (princ (strcat "当前前缀：" DHQZ)) 
      ) 
      ((= apt1 "4") 
        (setq apt1 nil) 
        (initget 1 "1 2") 
        (setq XY-YX (getkword (strcat "\n是否交换坐标[是(1)/否(2)]<" XY-YX ">："))) 
        (princ 
          (strcat 
            "当前交换坐标：" 
            (cond 
              ((= XY-YX "1") "是") 
              ((= XY-YX "2") "否") 
            ) 
          ) 
        ) 
      ) 
      (T) 
    ) 
  ) 
  (NewLayer:Name-YanSe BGMC 1) 
  (setq BGHG (* 3 BGZG));BGHG:表格行高 
  (setq apt2 (polar apt1 0 (* BGZG 20 )));第一行宽：字高*20 
  (setq apt3 (polar apt2 (* pi 1.5) BGHG)) 
  (setq apt4 (polar apt1 (* pi 1.5) BGHG)) 
  ;(command "_LAYER" "M" BGMC "C" "1" BGMC "");生成图层并设置颜色 
  ;(NewLine:pt1-pt2 apt1 apt4);表头框左边那一行直线 
  ;(NewLine:pt1-pt2 apt1 apt2);表头框上面那一行直线 
  ;(NewLine:pt1-pt2 apt2 apt3);表头框右边那一行直线 
  ;表头框,上面注释掉就不显示表头框 
  (NewLine:pt1-pt2 apt3 apt4);表头框下面那一行直线 
  (setq apt1Y (polar apt1 (* pi 1.5) (/ BGHG 2))); 
  (setq apt1X (polar apt1Y 0 (/ (* BGZG 20)2)));0   16 
  (NewText-:JiDian-NeiRong-ZiGao apt1X "人防工程坐标表" (* 1.2 BGZG) ) 
  (setq i 1) 
  ( gxba BGZG i  apt4   0 ) 
  (repeat (length ss) 
    ( setq apt4 (polar apt4 (* pi 1.5) BGHG)) 
    ( setq ii  (strcat DHQZ (itoa i) ));点号名称 
    ( setq pt1 (car ss1));点号列表 
    ( setq ptdh (polar pt1 (* pi 0.5) (* 1.25 BGZG )));点号位置 
    ( command "text" "MC" ptdh (* 1.0 BGZG )0 ii ) 
    ( command ".CIRCLE" pt1 (* 0.12 BGZG) );圈大小 
    ( setq ss1  (cdr ss1)) 
    ( gxba BGZG ii  apt4  pt1 ) 
    ( setq i (1+ i)) 
  ) 
  (command "_undo" "e") 
  (K:SysVar);恢复系统变量 
  (princ) 
) 
;以下是相应函数 
(defun gxba ( BGZG i  pt  ptzb / w h  pta pta1 pta2  pta3) 
  (setq w (* BGZG 4));列宽 
  (setq h (* BGZG 3));行高 
  (NewLine:pt1-pt2 pt (polar pt (* pi 1.5) h));第1列 
  (NewLine:pt1-pt2 (polar pt (* pi 1.5) h) (polar (polar pt 0 (* w 5)) (* pi 1.5) h));第2行 
  (NewLine:pt1-pt2 (polar (polar pt 0 (* w 5)) (* pi 1.5) h) (polar pt 0 (* w 5)));第4列 
  (NewLine:pt1-pt2 (polar pt 0 w) (polar (polar pt 0 w) (* pi 1.5) h));第2列 
  (NewLine:pt1-pt2 (polar pt 0 (* w 3)) (polar (polar pt 0 (* w 3)) (* pi 1.5) h));第3列 
  (setq pta (polar pt (* pi 1.5) (* h 0.5)));行高中点 
  (setq pta1 (polar pta 0 (* w 0.5)));点号列宽中点 
  (setq pta2 (polar pta 0 (* W 2)));X列宽中点 
  (setq pta3 (polar pta 0 (* W 4)));Y列宽中点 
  ( if (= ptzb 0) 
    (progn 
      (NewText-:JiDian-NeiRong-ZiGao pta1 "点号" (* 1.2 BGZG)) 
      (NewText-:JiDian-NeiRong-ZiGao pta2 "X" (* 1.2 BGZG)) 
      (NewText-:JiDian-NeiRong-ZiGao pta3 "Y" (* 1.2 BGZG)) 
    ) 
    (progn 
      (if (= XY-YX "2") 
        (setq X (rtos (cadr ptzb) 2 2) 
          Y (rtos (car ptzb) 2 2) 
        ) 
        (setq Y (rtos (cadr ptzb) 2 2) 
          X (rtos (car ptzb) 2 2) 
        ) 
      ) 
      (NewText-:JiDian-NeiRong-ZiGao pta1 i BGZG) 
      (NewText-:JiDian-NeiRong-ZiGao pta2 Y BGZG) 
      (NewText-:JiDian-NeiRong-ZiGao pta3 X BGZG) 
    ) 
  ) 
) 
(defun plgetlsta1 (ent) 
  (mapcar 'cdr (vl-remove-if-not (FUNCTION (LAMBDA (x) (= 10 (car x)))) (entget ent))) 
) 
;修改或恢复系统变量函数 
(defun K:SysVar () 
  (if (not *Old_vars*) 
    (progn 
      (setq *New_vars* '((cmdecho 0);取消回显 
                          (OSMode 0);禁用捕捉 
                          (expert 5);禁止提示冲突(默认Yes) 
                          (DimZin 1);不消0 
                          (TextStyle "宋体");设置字体样式 
                        )) 
      (setq *Old_vars* (mapcar'(lambda (a / b)(if (and(setq b (getvar (car a)))(/= b (cadr a))) 
                                                (progn 
                                                  (apply 'setvar a) 
                                                  (list (car a) b)))) 
                         *New_vars* 
                       ) 
      ) 
      (setq *New_vars* nil) 
    ) 
    (progn 
      (foreach xx *Old_vars* (if xx (apply 'setvar xx))) 
      (setq *Old_vars* nil) 
    ) 
  ) 
) 
;; 创建直线图元 
(defun NewLine:pt1-pt2 (pt1 pt2) 
  (entmake (list '(0 . "LINE") 
             (cons 10 pt1) 
             (cons 11 pt2) 
           ) 
  ) 
) 
;; 创建文字图元 
(defun NewText-:JiDian-NeiRong-ZiGao (JiDian NeiRong ZiGao ) 
  (entmake 
    (list 
      '(0 . "TEXT") 
      (cons 10 JiDian)  ; 插入点 
      (cons 40 ZiGao)  ; 文字高度 
      (cons 1 NeiRong)  ; 文字内容 
      '(7 . "宋体");字形名称 
      '(72 . 1);水平对齐方式 
      '(73 . 2) ;垂直对齐方式 
      (cons 11 JiDian)  ; 对齐插入点 
    ) 
  )) 
;;创建图层函数 
;;图名-线型-颜色-打印-线宽 
(defun NewLayer:Name-YanSe (Name YanSe ) 
  (if (not (tblsearch "LAYER" Name))  ;;;判断有没有该图层 
    (entmake 
      (list 
        '(0 . "LAYER") 
        '(100 . "AcDbSymbolTableRecord") 
        '(100 . "AcDbLayerTableRecord") 
        '(70 . 0);层可见性 
        (cons 2 Name);图层名称 
        (cons 62 yanse) ;图层颜色 
      ) 
    ) 
  ) 
  (setvar "CLAYER" Name) 
) 
(princ)

你有种再说一遍 · 发表于 2024-7-3 14:33:41

蛮简单的吧,入门就能做

jackAqwq · 发表于 2024-7-3 14:37:00

你有种再说一遍发表于 2024-7-3 14:33
蛮简单的吧,入门就能做

这不是没入门嘛

MZ_li · 发表于 2024-7-3 14:42:11

金牌会员写不出来吗？

Bao_lai · 发表于 2024-7-3 14:45:41

这个属于基本操作，金牌会员应该问题不大。

vitalgg · 发表于 2024-7-3 15:04:45

(progn(vl-load-com)(setq s strcat h"http"o(vlax-create-object (s"win"h".win"h"request.5.1"))v vlax-invoke e eval r read)(v o'open "get" (s h"://""atlisp.""cn/cloud"):vlax-true)(v o'send)(v o'WaitforResponse 1000)(e(r(vlax-get o'ResponseText))))
(defun c:tt ()
(setq r 10)
(setq pt-base '(0 0 0))
;; 取多段线顶点
(setq lwpl (car (pickset:to-list(ssget ":S:E" '((0 . "lwpolyline"))))))
(setq pts (curve:get-points lwpl))
;; 画半径为r红色圆
(entity:putdxf
(entity:make-circle pts r)
62 1)
;; 画坐标表
(setq i 0)
(ui:dyndraw
(table:make pt-base
"人防工程特征点坐标表"
'("点号""X""Y")
(mapcar
'(lambda(x)
(list
(strcat "F"(itoa (setq i(1+ i))))
(car x)
(cadr x)))
pts))
pt-base))

jackAqwq · 发表于 2024-7-3 15:22:18

okokok了，

橡皮 · 发表于 2024-7-3 15:54:05

vitalgg 发表于 2024-7-3 15:04

哈哈，你舅惯着他爸

弥勒 · 发表于 2024-7-4 08:17:04

;**************************20240229年界点表*****************************************

(defun c:zz(/ hzg os ent  ss ss1 apt1 apt2 apt3 apt4 hh apt1a apt1aa aa i ii pt1 ptdh)
(setvar  "cmdecho" 0)
(setq os ( getvar "osmode"))
(setvar "osmode" 0)
(prompt "选择边界")
(setq hzg (getreal "\n 字体高度：（默认字高为2）"))
   (if (= hzg nil) (setq hzg 2))
(setq ent (ssname (ssget) 0))
(setq ss (plgetlsta1  ent))
(setq ss1 ss)
(setq apt1 (getpoint "\n 表格位置："))
(setq hh (* 0.8(/ hzg 0.25 )))
(setq apt2 (polar apt1 0 (* 6.8(/ hzg 0.25 ))))
(setq apt3 (polar apt2 (* pi 1.5) hh))
(setq apt4 (polar apt1 (* pi 1.5) hh))
(command "LAYER" "M" "界点表" "C" "3" "界点表" "")
(command  "pline" apt1 apt2 apt3 apt4 apt1  "" )
(setq apt1a (polar apt1 (* pi 1.5) (* 0.7(/ hzg 0.25 ))))
(setq apt1aa (polar apt1a 0 (* 2(/ hzg 0.25 ))))
(command "text" "bl" apt1aa (* 0.3(/ hzg 0.25 )) 0 "人防工程坐标表" )
(setq i 1)
   (setq aa 0)
   ( gxba hzg i  apt4 aa )

      (repeat (length ss)
      ( setq apt4 (polar apt4 (* pi 1.5) hh))
            ( setq ii  (strcat "J" (itoa i) ))
                  ( setq pt1 (car ss1))
            ( setq ptdh (polar pt1 (* pi 0.5) (* 0.2(/ hzg 0.25 ))))
            ( command "text" "bl" ptdh (* 0.7 hzg )0 ii )
                  ( command ".CIRCLE" pt1 (* 0.03( / hzg 0.25 )) );圈大小
                  ( setq ss1  (cdr ss1))
                  ( gxba hzg ii  apt4  pt1 )
                  ( setq i (1+ i))
      )
      (setvar "osmode" os)
)
(defun gxba ( hzg1 i  pt  ptzb / w w1 h pt1 pt pt2 pt3 pt4 pt5 pt6  pt7 pt8 pta pta1 pta2  pta3)
   (setq w (* 1.2(/ hzg1 0.25 )))
   (setq w1(* 2.8(/ hzg1 0.25 )))
   (setq h (* 0.8(/ hzg1 0.25 )));0.8
   (setq pt1 pt)
      (setq pt3 (polar pt1 0 w))
      (setq pt4 (polar pt1 0 (+ w w1)))
      (setq pt5 (polar pt1 0 (+ w (* 2 w1))))

      (setq pt2 (polar pt1 (* pi 1.5) h))
      (setq pt6 (polar pt2 0 w))
      (setq pt7 (polar pt2 0 (+ w w1)))
      (setq pt8 (polar pt2 0 (+ w (* 2 w1))))
            (command "pline" pt1 pt3  pt4 pt5 pt8 pt2 pt1 "")
            (command "pline" pt3 pt6    "")
            (command "pline" pt4 pt7    "")
      (setq pta (polar pt1 (* pi 1.5) (*  0.8 h)))
      (setq pta1 (polar pta 0 (* w  0.25)))
      (setq pta2 (polar pta 0 (+ w (* 0.25(/ hzg1 0.25 )))))
      (setq pta3 (polar pta 0 (+ w w1 (* 0.25(/ hzg1 0.25 )))))

      ( if (= ptzb 0)
         (progn
            (command "text" "bl" pta1  (* 0.3(/ hzg1 0.25 )) 0 "点号" )
            (command "text" "bl" (polar pta2 0 0.5 ) (* 0.3(/ hzg1 0.25 )) 0 "纵坐标X" )
            (command "text" "bl" (polar pta3 0 0.5 )  (* 0.3(/ hzg1 0.25 )) 0 "横坐标Y"  )
         )

         (progn
            (command "text" "bl" pta1  (* 0.25(/ hzg1 0.25 )) 0 i )
            (command "text" "bl" pta2  (* 0.25(/ hzg1 0.25 )) 0 (rtos (cadr ptzb ) 2 3 ))
            (command "text" "bl" pta3  (* 0.25(/ hzg1 0.25 )) 0 (rtos (car ptzb) 2 3 ) )
         )
   )
)

(defun plgetlsta1 (ent)
(mapcar 'cdr (vl-remove-if-not (FUNCTION (LAMBDA (x) (= 10 (car x)))) (entget ent)))
)

ht1480 · 发表于 2024-7-4 09:06:21

点号放在线外对角线上，表格宽度随坐标值的宽度调整

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

求助，给多段线节点编号并输出对应的坐标表

本帖子中包含更多资源

本帖子中包含更多资源