增加一个手动选择插入点
本帖最后由 wyy81061 于 2024-12-20 11:10 编辑各位大佬帮帮看看，现在的功能只能实现根据多段线颜色生成文字后对齐，但是这个文字的位置不是固定的，我想要增加一个功能，就是根据我鼠标点击的位置做为基准点生成文字
(defun c:XX8 ()
(vl-load-com)
;; 定义颜色与文字的映射表
(setq color-text-map '(
(1 . "48B1") ;; 洋红
(2 . "96B1") ;; 红色
(3 . "72B1") ;; 绿色
(4 . "144B1");; 青色
(5 . "36B1") ;; 蓝色
(6 . "12B1") ;; 黄色
(7 . "24B1") ;; 白色
))
;; 获取用户选择的多段线
(setq selection (ssget '((0 . "LWPOLYLINE"))))
(if selection
(progn
(setq horizontal-lines '())
(setq vertical-lines '())
;; 遍历多段线，分类为横向和竖向
(repeat (sslength selection)
(setq ent (ssname selection 0))
(setq obj (vlax-ename->vla-object ent))
;; 获取顶点
(setq vertices (mapcar 'cdr (vl-remove-if-not
'(lambda (x) (= (car x) 10))
(entget ent))))
;; 判断方向
(if (> (abs (- (car (car vertices)) (car (last vertices))))
(abs (- (cadr (car vertices)) (cadr (last vertices)))))
(setq horizontal-lines (cons ent horizontal-lines))
(setq vertical-lines (cons ent vertical-lines))
)
(ssdel ent selection)
)
;; 处理横向多段线
(if horizontal-lines
(progn
;; 以最左边的线为基准
(setq base-line (car (vl-sort horizontal-lines
'(lambda (a b)
(< (car (vlax-curve-getStartPoint a))
(car (vlax-curve-getStartPoint b)))))))
(setq base-center (vlax-curve-getPointAtParam base-line
(vlax-curve-getParamAtDist base-line
(/ (vlax-curve-getDistAtParam base-line
(vlax-curve-getEndParam base-line)) 2))))
;; 遍历横向多段线
(foreach ent horizontal-lines
(setq obj (vlax-ename->vla-object ent))
(setq color (vla-get-color obj))
(setq text (cdr (assoc color color-text-map)))
(if text
(progn
(setq line-center (list (car base-center) (cadr (vlax-curve-getPointAtParam ent
(vlax-curve-getParamAtDist ent
(/ (vlax-curve-getDistAtParam ent
(vlax-curve-getEndParam ent)) 2))))))
(entmake (list
(cons 0 "TEXT")
(cons 10 line-center)
(cons 40 2.5)
(cons 41 0.7)
(cons 7 "宋体")
(cons 1 text)
(cons 50 0)
(cons 62 color)
(cons 72 4)
(cons 73 2)
(cons 11 line-center)
))
)
)
)
)
)
;; 处理竖向多段线
(if vertical-lines
(progn
;; 以最上方的线为基准
(setq base-line (car (vl-sort vertical-lines
'(lambda (a b)
(> (cadr (vlax-curve-getStartPoint a))
(cadr (vlax-curve-getStartPoint b)))))))
(setq base-center (vlax-curve-getPointAtParam base-line
(vlax-curve-getParamAtDist base-line
(/ (vlax-curve-getDistAtParam base-line
(vlax-curve-getEndParam base-line)) 2))))
;; 遍历竖向多段线
(foreach ent vertical-lines
(setq obj (vlax-ename->vla-object ent))
(setq color (vla-get-color obj))
(setq text (cdr (assoc color color-text-map)))
(if text
(progn
(setq line-center (list (car (vlax-curve-getPointAtParam ent
(vlax-curve-getParamAtDist ent
(/ (vlax-curve-getDistAtParam ent
(vlax-curve-getEndParam ent)) 2))))
(cadr base-center)))
(entmake (list
(cons 0 "TEXT")
(cons 10 line-center)
(cons 40 2.5)
(cons 41 0.7)
(cons 7 "宋体")
(cons 1 text)
(cons 50 (/ pi 2))
(cons 62 color)
(cons 72 4)
(cons 73 2)
(cons 11 line-center)
))
)
)
)
)
)
)
(princ "\n未选择任何多段线！")
)
(princ)
)
有一个简单办法，生成后，用(command "_.move" ss ''" pt pause) 本帖最后由 llsheng_73 于 2024-12-20 12:58 编辑
(setq line-center(list(car base-center)
(cadr(vlax-curve-getPointAtParam ent(vlax-curve-getParamAtDist ent(/(vlax-curve-getDistAtParam ent(vlax-curve-getEndParam ent))2))))))
改成(setq line-center(getpoint"\n指定基准点"))
不过这程序需要优化的地方太多，比如纵线和横线分开后，处理时绝大部分代码重复。这就完全可以考虑根据直接线的起止点计算方向，50组就使用这个方向，这样代码不必重复，甚至不需要判断是纵线还是横线
llsheng_73 发表于 2024-12-20 12:50
(setq line-center(list(car base-center)
(cadr(vlax-curve-getPointAtParam ent( ...
(defun c:XX7 ()
(vl-load-com)
;; 定义颜色与文字的映射表
(setq color-text-map '(
(1 . "48B1") ;; 洋红
(2 . "96B1") ;; 红色
(3 . "72B1") ;; 绿色
(4 . "144B1");; 青色
(5 . "36B1") ;; 蓝色
(6 . "12B1") ;; 黄色
(7 . "24B1") ;; 白色
))
;; 提示用户选择一条多段线
(setq selected-polyline (car (entsel "\n请选择一条多段线：")))
(if selected-polyline
(progn
(setq polyline-obj (vlax-ename->vla-object selected-polyline))
;; 获取点击点
(setq clicked-point (getpoint "\n请选择插入文字的位置："))
;; 获取多段线的起点和终点
(setq start-point (vlax-curve-getStartPoint polyline-obj))
(setq end-point (vlax-curve-getEndPoint polyline-obj))
;; 判断多段线方向
(if (> (abs (- (car start-point) (car end-point)))
(abs (- (cadr start-point) (cadr end-point))))
(setq orientation 'horizontal)
(setq orientation 'vertical)
)
;; 获取多段线颜色并生成文字
(setq color (vla-get-color polyline-obj))
(setq text (cdr (assoc color color-text-map)))
(if text
(progn
;; 根据方向调整文字插入点
(setq text-point
(if (eq orientation 'horizontal)
(list (car clicked-point)
(cadr start-point))
(list (car start-point)
(cadr clicked-point))))
;; 创建文字
(entmake (list
(cons 0 "TEXT")
(cons 10 text-point)
(cons 40 2.5)
(cons 41 0.7)
(cons 7 "宋体")
(cons 1 text)
(cons 50 (if (eq orientation 'horizontal) 0 (/ pi 2)))
(cons 62 color)
(cons 72 4)
(cons 73 2)
(cons 11 text-point)
))
;; 添加“管”字，判断是否需要
(if (or (eq orientation 'horizontal)
(eq orientation 'vertical))
(progn
(setq pipe-point
(if (eq orientation 'horizontal)
(list (car clicked-point)
(+ (cadr start-point) 4))
(list (- (car start-point) 4)
(cadr clicked-point))))
(entmake (list
(cons 0 "TEXT")
(cons 10 pipe-point)
(cons 40 2.5)
(cons 41 0.7)
(cons 7 "宋体")
(cons 1 "管")
(cons 50 (if (eq orientation 'horizontal) 0 (/ pi 2)))
(cons 62 color)
(cons 72 4)
(cons 73 2)
(cons 11 pipe-point)
))
)
)
)
(princ "\n未找到对应颜色的文字映射！")
)
)
(princ "\n未选择任何多段线！")
)
(princ)
)
我原来写的就是对单个多段线的，后面想批量处理，刚开始弄，很多还不清楚，大佬能不能帮忙改进下 wyy81061 发表于 2024-12-20 14:14
我原来写的就是对单个多段线的，后面想批量处理，刚开始弄，很多还不清楚，大佬能不能帮忙改进下
我上面那个CAD文件里有具体的效果 xyp1964 发表于 2024-12-21 01:10
我原先的就是这种，主要是我那CAD里的有些多段线是L型，而且还是每一档都要插入文字，这种情况下想自动确定文字插入点也太难了，所以我才想手动选择插入点，虽然麻烦点，但是起码能够实现 自贡黄明儒 发表于 2024-12-20 11:35
有一个简单办法，生成后，用(command "_.move" ss ''" pt pause)
黄大师能不能帮忙提供个完整的？刚开始弄还不熟悉，折腾半天还是没弄好
页:
[1]