批量多段线坐标标注 节点编号 导出坐标
(defun c:getplpt();;批量多段线坐标标注节点编号导出(setq ps_cmdecho (getvar "cmdecho");;获取图层
ps_osmode(getvar "osmode") ;;获取捕捉
ps_luprec(getvar "luprec") ;;设定线性单位和坐标的显示精度。
)
(setvar "cmdecho" 0)
(setvar "osmode"0)
(setvar "luprec"0)
(setvar "dimzin"1);;控制针对主单位值的消零处理。
(setvar "pdmode" 35) ;;点样式
(setvar "pdsize" 0.3) ;;点大小
(command "-units" "2" "4" "2" "3" "" "");;;控制坐标、距离和角度的精度和显示格式。
(setq TextHeight (getdist "\n 请输入文字高度:"))
(if (null TextHeight)(setq TextHeight 0.5))
(setq chhlay (tblsearch "layer" "多段线坐标标注"))
(if (null chhlay)(command "-layer" "m" "多段线坐标标注" "c" "3" "多段线坐标标注" ""))
(princ "\n 输入引线长度 (建议")
(princ (* TextHeight 2))
(princ ")")
(princ ":")
(setq long (getreal))
(if (null long)(setq long (* TextHeight 2)))
(setq plss (ssget '((-4 . "<or")(0 . "POLYLINE")(0 . "LWPOLYLINE")(-4 . "OR>") )))
(setq sn (sslength plss))
(setq pianju (* TextHeight 0.2))
(setq num 0)
(while (< num sn)
(setq ept (entget (ssname plss num)))
(setq plnum (length ept))
(setq num1 0)
(while (< num1 plnum)
(if (= (car (nth num1 ept)) 10)
(progn
(command "layer" "s" "多段线坐标标注" "")
(setq pt(cdr (nth num1 ept)))
(setq pt1 (polar pt (+ 0 (* 0.4 pi)) long))
(setq pt2 (polar pt1 0 (* TextHeight 10)))
(command "line" pt pt1 pt2 "") ;;引线
(setq xx (strcat "Y=" (rtos (car pt) 2 4)))
(setq yy (strcat "X=" (rtos (cadr pt) 2 4)))
(setq ptx (list (+ (car pt1) 0.2) (- (- (cadr pt1) TextHeight) pianju)))
(setq pty (list (+ (car pt1) 0.2) (+ (cadr pt1) pianju)))
(command "text" pty TextHeight 0 yy)
(command "text" ptx TextHeight 0 xx)
)
)
(setq num1 (1+ num1))
)
(setq num (1+ num))
)
(defun vxs (e / i v lst)
(setq i -1)
(while
(setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
(setq lst (cons v lst))
)
(reverse lst)
)
(setq ss plss
i 0
filex (getfiled "输出文件" "d:/多线段导出坐标文件" "xls;txt;dat;csv" 1)
file(open filex "w")
)
(repeat (sslength ss)
(setq j 1
ent (entget (ssname ss i))
p (cdr (assoc 10 ent))
)
(write-line (strcat "多段线" (itoa (1+ i))" #") file)
(write-line "点号\tX\tY\tZ" file)
(entmake
(list'(0 . "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
'(62 . 6) ;;颜色
'(40 . 0.6) ;;字高
(cons 7"仿宋") ;;字体
(cons 8"多段线数量编号") ;;图层
(cons 1(strcat (itoa (1+ i)) "#多段线")) ;;文字
(cons 10 (list (car p) (- (cadr p) TextHeight)));;位置
)
)
(while (setq p (assoc 10 ent))
(setq ent (cdr (member p ent)) p (cdr p))
(entmake
(list'(0 . "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
'(62 . 7)
'(40 . 0.6)
(cons 7"黑体")
(cons 8"多段线节点编号")
(cons 1(itoa j))
(cons 10 (list (+ (car p) 0.01) (- (cadr p) 0.01)))
)
)
(entmake (list '(0 . "POINT") '(62 . 1)(cons 8"点号") (cons 10 p) ));多段线上绘制点
(write-line(strcat (itoa j) "\t" (rtos (cadr p) 2 4) "\t" (rtos (car p) 2 4) "\t" (if (caddr p)(rtos (caddr p) 2 4) "0.000"))
file
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(close file)
(startapp "notepad.exe" filex)
(setvar "CLAYER" "0")
(setvar "cmdecho" ps_cmdecho)
(setvar "osmode"ps_osmode)
(setvar "luprec"ps_luprec)
(princ"\n 批量多段线坐标标注、节点编号、坐标导出完成！谢谢使用！！！")
(prin1)
)
土土木木人 发表于 2024-6-18 08:34
优化了一下，XY可以颠倒
『建桥工具箱』提示您，请输入文字高度<3>：33
『建桥工具箱』提示您，请选择多段线：
『建桥工具箱』出现 [类型不正确 - (<ENTITY NAME: 50fcb6c8> (2.32505e+06 -936965.0 0.0))] 错误！ 土土木木人 发表于 2024-6-19 11:02
出错的时候，用(PRINC XX)读取下XX变量的值
可以用，还不错，演示图
如果能像下面这样显示就是完美了
p-3-ianlcc 发表于 2024-6-19 09:54
我是用空白的文档，自己随便画几条线进行测试
没有特别用什麽文档测试
出错的时候，用(PRINC XX)读取下XX变量的值 不错，能指定坐标原点更好，也更实用 很好→很棒！很好~很棒！！很好……很棒！！！建议优化兼容：二维多段线、三维多段线等 优化了一下，XY可以颠倒 支持！很好→很棒！很好~很棒！！很好……很棒！！！期待继续优化！ 土土木木人 发表于 2024-6-18 08:34
优化了一下，XY可以颠倒
我有测试了一下，会出现消息
p-3-ianlcc 发表于 2024-6-18 18:14
我有测试了一下，会出现消息
没遇到过，是啥版本的CAD，2024都测试可以的 土土木木人 发表于 2024-6-18 22:04
没遇到过，是啥版本的CAD，2024都测试可以的
我是在2024上使用的
出现这个讯息，而且不只一次…约四、五次之多 能不能指定坐标的原点？ bai2000 发表于 2024-6-19 06:54
能不能指定坐标的原点？
可以 :lol
页:
[1]
2