(defun c:xianlong_text ()
;;标注线段长度
(if (/= (getvar "DIMZIN") 0)
(setvar "DIMZIN" 0)) ;保留小数位数不消零
(setq textzg
(getreal
(strcat "\n请输入注记字高:<" (rtos (getvar "textsize") 2 2) ">")))
(if (= textzg nil)
(setq textzg (getvar "textsize"))
(setvar "textsize" textzg))
(setq xian_s (ssget (list (cons 0 "*LINE"))))
(setq textlay (getvar "CLAYER")
textthk 0.0
textkuan1.0
textqxie0.0
textcolor nil
textstyle "STANDARD"
textlcr 1
textdmh 2)
(if (/= nil xian_s)
(progn
(setq xian_slen (sslength xian_s))
(setq xian_l 0)
(repeat xian_slen
(setq pline_ename (ssname xian_s xian_l))
(setq pline_list (vertexs pline_ename))
(if (/= nil pline_list)
(progn
(setq pt_num 0
textpt2 nil
textpt1 nil)
(repeat (length pline_list)
(cond
;;记录注记第一点
((= pt_num 0)
(setq textpt1 (list (nth 0 (nth pt_num pline_list))
(nth 1 (nth pt_num pline_list))
0.0)))
;;记录注记第二点,注记距离
((> pt_num 0)
(progn
(setq textpt2(list (nth 0 (nth pt_num pline_list))
(nth 1 (nth pt_num pline_list))
0.0)
xianlen(distance textpt1 textpt2)
textnr (rtos xianlen 2 2)
textpt10 (mapcar
'*
(list 0.5 0.5 0.0)
(list
(+ (nth 0 textpt1) (nth 0 textpt2))
(+ (nth 1 textpt1) (nth 1 textpt2))
0.0))
textpt11 textpt10)
(if (and (> (angle textpt1 textpt2) (* 0.517 pi))
(<= (angle textpt1 textpt2) (* 1.517 pi)))
(setq textro (+ (angle textpt1 textpt2) pi))
(setq textro (angle textpt1 textpt2)))
(emaketext textlay textnr textthk textpt10 textzg textro
textkuan textqxie textcolor textstyle textlcr
textdmh textpt11)
(setq textpt1 textpt2
textpt2 nil)))
(t nil))
(setq pt_num (1+ pt_num)))))
(setq xian_l (1+ xian_l))))))
(defun vertexs (pline_ename / plist pline_list n)
;;返回多段线的各顶点
;;语法:(vertexs pline_ename)
;;pline_ename :(LINE POLYLINE LWPOLYLINE)实体的图元名
;;返回:各顶点形成的点列表
;;加载(vl-load-com)环境
(vl-load-com)
(setq acadobject1 (vlax-get-acad-object)
acaddocument1 (vla-get-activedocument acadobject1)
mspace1 (vla-get-modelspace acaddocument1))
(setq pline_list nil)
(cond
;;当实体为LINE
((= (cdr (assoc 0 (entget pline_ename))) "LINE")
(progn (setq pline_list
(append pline_list
(list (cdr (assoc 10 (entget pline_ename)))
(cdr (assoc 11 (entget pline_ename))))))))
;;当实体为LWPOLYLINE或POLYLINE
((or (= (cdr (assoc 0 (entget pline_ename))) "LWPOLYLINE")
(= (cdr (assoc 0 (entget pline_ename))) "POLYLINE"))
(progn (setq obj (vlax-ename->vla-object pline_ename))
(setq
plist (vlax-safearray->list (vlax-variant-value (vla-get-coordinates obj))))
(setq n 0)
(cond ((= (cdr (assoc 0 (entget pline_ename))) "LWPOLYLINE")
(progn (repeat (/ (length plist) 2)
(setq pline_list
(append pline_list
(list (list (atof (rtos (nth n plist) 2 3))
(atof (rtos (nth (1+ n) plist) 2 3))))))
(setq n (+ n 2)))))
((= (cdr (assoc 0 (entget pline_ename))) "POLYLINE")
(progn (repeat (/ (length plist) 3)
(setq pline_list
(append pline_list
(list (list (atof (rtos (nth n plist) 2 3))
(atof (rtos (nth (1+ n) plist) 2 3))
(atof (rtos (nth (+ n 2) plist) 2 3))))))
(setq n (+ n 3))))))))
(t (setq pline_list nil)))
(if (and (or (= (cdr (assoc 0 (entget pline_ename))) "LWPOLYLINE")
(= (cdr (assoc 0 (entget pline_ename))) "POLYLINE"))
(or (= (cdr (assoc 70 (entget pline_ename))) 129)
(= (cdr (assoc 70 (entget pline_ename))) 1)))
(setq pline_list (append pline_list (list (nth 0 pline_list)))))
pline_list)
(defun emaketext(textlay textnr textthk textpt10 textzg textro textkuan textqxie
textcolor textstyle textlcr textdmh textpt11)
;|(emaketext textlay textnr textthk textpt10 textzg textro textkuan
textqxie textcolor textstyle textlcr textdmh textpt11)|;
;;用entmake方法添加文字注记实体
;; textlay--注记图层textnr---注记内容 textthk---注记厚值
;; textzg---注记字高textro---注记旋转方向 textkuan---注记宽度系数
;; textqxie---注记倾斜角度 textstyle---注记文字样式
;; textcolor---注记颜色
;; textlcr--注记左中右对齐方式(0,1,2,3,4,5,nil)
;; textdmh--注记上中下对齐方式(3,2,1,nil)
;; textpt10---注记点坐标10 textpt11---注记点坐标11
;;(vla-get-alignment(vlax-ename->vla-object (car(entsel))))
(vl-load-com)
(setq acadobject1 (vlax-get-acad-object)
acaddocument1 (vla-get-activedocument acadobject1)
mspace1 (vla-get-modelspace acaddocument1))
;;注记位置textpt10和字高textzg
(setq textst_name nil)
(setq insertionpnt (vlax-make-safearray vlax-vbdouble '(0 . 2)))
(if (= (length textpt10) 2)
(setq textpt10 (list (nth 0 textpt10) (nth 1 textpt10) 0.0)))
(vlax-safearray-fill insertionpnt textpt10)
(setq textobj (vla-addtext mspace1 textnr insertionpnt textzg))
;; textlcr--注记左中右对齐方式(0,1,2,3,4,5,nil)
;; textdmh--注记上中下对齐方式(3,2,1,nil)
(cond
;;基准线中1
((and (= textlcr 1) (= textdmh nil)) (vla-put-alignment textobj acalignmentCenter))
;;基准线右2
((and (= textlcr 2) (= textdmh nil)) (vla-put-alignment textobj acalignmentRight))
;;对齐3
((and (= textlcr 3) (= textdmh nil)) (vla-put-alignment textobj acalignmentAligned))
;;中央4
((and (= textlcr 4) (= textdmh nil)) (vla-put-alignment textobj acalignmentMiddle))
;;调整5
((and (= textlcr 5) (= textdmh nil)) (vla-put-alignment textobj acalignmentFit))
;;左上6
((and (= textlcr 0) (= textdmh 3)) (vla-put-alignment textobj acalignmentTopLeft))
;;中上7
((and (= textlcr 1) (= textdmh 3)) (vla-put-alignment textobj acalignmentTopCenter))
;;右上8
((and (= textlcr 2) (= textdmh 3)) (vla-put-alignment textobj acalignmentTopRight))
;;左中9
((and (= textlcr 0) (= textdmh 2))
(vla-put-alignment textobj acalignmentMiddleLeft))
;;中中10
((and (= textlcr 1) (= textdmh 2))
(vla-put-alignment textobj acalignmentMiddleCenter))
;;右中11
((and (= textlcr 2) (= textdmh 2))
(vla-put-alignment textobj acalignmentMiddleRight))
;;左下12
((and (= textlcr 0) (= textdmh 1))
(vla-put-alignment textobj acalignmentBottomLeft))
;;中下13
((and (= textlcr 1) (= textdmh 1))
(vla-put-alignment textobj acalignmentBottomCenter))
;;右下14
((and (= textlcr 2) (= textdmh 1))
(vla-put-alignment textobj acalignmentBottomRight))
;;默认基准线左0
(t (vla-put-alignment textobj acalignmentLeft)))
(if (or (/= textlcr nil) (/= textdmh nil))
(vla-put-textalignmentpoint textobj insertionpnt))
;;注记颜色textcolor
(if (/= nil textcolor)
(vla-put-color textobj textcolor)
(vla-put-color textobj acbylayer))
;;注记字型样式textstyle
(if (/= (type textstyle) nil)
(progn (if (and (/= textstyle (vla-get-stylename textobj))
(/= (tblsearch "style" textstyle) nil))
(vla-put-stylename textobj textstyle))))
;;注记厚度textthk
(if (and (/= (type textthk) 'REAL) (/= (type textthk) 'INT))
(setq textthk 0.0))
(vla-put-thickness textobj textthk)
;;注记旋转角度textro
(if (/= nil textro)
(vla-put-rotation textobj textro)
(vla-put-rotation textobj 0.0))
;;注记图层textlay
(if (= (tblsearch "layer" textlay) nil)
(progn (setq layersel (vla-get-layers acaddocument1))
(setq layerobj (vla-add layersel textlay))))
(vla-put-layer textobj textlay)
;;注记的宽度系数textkuan
(if (/= textkuan nil)
(vla-put-ScaleFactor TextObj textkuan)
(vla-put-ScaleFactor TextObj 1.0))
;;注记的倾斜系数textqxie
(if (/= textqxie nil)
(vla-put-ObliqueAngle TextObj textqxie)
(vla-put-ObliqueAngle TextObj 0.0))
;;注记的扩展属性textkzsx
(setq textst_name (vlax-vla-object->ename TextObj))
textst_name)
好久不来了，长假休息期间来看看，顺便整理些源码供大家参考，希望对大家有帮助。
这段代码包含了以下几个功能
1 批量标注线段长度
2 对选择的线实体获取坐标列表
3 VLA-ADDTEXT方法添加注记实体时如何设置注记图层、颜色、字高、字宽、对齐方式等属性
支持楼主更新，学习学习
njcknfy 发表于 2014-10-7 15:10 static/image/common/back.gif
好久不来了，长假休息期间来看看，顺便整理些源码供大家参考，希望对大家有帮助。
这段代码包含了以下几 ...
支持楼主
你能给我看看这段代码吗？
我的功能是连接等高线，并使连接后的等高线进行拟合
先谢谢楼主了
(Defun C:cjlj1 (/ Ss1 ss2 Pt1 Pt2 p1 p2)
(vl-load-com)
(Setvar "Cmdecho" 0)
(Setq Pt1 (Getvar "Vsmin"))
(Setq Pt2 (Getvar "Vsmax"))
(Setq Ss1 (Entsel "\n 选择1线:"))
(Setq Ss2 (Entsel "\n 选择2线:"))
(Setq p1s (vlax-curve-getstartpoint (car ss1)))
(Setq p1d (vlax-curve-getendpoint (car ss1)))
(Setq p2d (vlax-curve-getendpoint (car ss2)))
(Setq p2s (vlax-curve-getstartpoint (car ss2)))
(setq Z1(car(assoc 38 (entget (car ss1)))))
(setq Z2(car(assoc 38 (entget (car ss2)))))
(setq d1 (distance p1s p2s)
d2 (distance p1s p2d)
d3 (distance p1d p2s)
d4 (distance p1d p2d)
)
(cond
((equal d1 (min d1 d2 d3 d4) 1e-5) (setq p1 p1s p2 p2s))
((equal d2 (min d1 d2 d3 d4) 1e-5) (setq p1 p1s p2 p2d))
((equal d3 (min d1 d2 d3 d4) 1e-5) (setq p1 p1d p2 p2s))
(T (setq p1 p1d p2 p2d))
)
(if (= z1 z2)
(progn
(Vl-Cmdf "pline" p1 p2 "")
(Vl-Cmdf ".Pedit" Ss1 "Yes" "J" "C" Pt1 Pt2 "" "")
(Vl-Cmdf ".Pedit" Ss1 "Yes" "s" Pt1 Pt2 "" "")
)
)
(Setvar "Cmdecho" 1)
(Princ)
)
楼主什么时候还能来啊
好贴必须顶
mrhvslisp 发表于 2011-5-9 09:24 static/image/common/back.gif
楼主很厉害，
看下我这个，修改等高线的，楼主用CASS应该经常用到吧。
我自己尝试着写了点，但是效果不好 ...
能说说你的思路吗
004 发表于 2012-9-9 14:11 static/image/common/back.gif
把cass重写了得了。每个人写一点，高手写点复杂的不就成了。。
好提议 呵呵 权当练习了呵呵
njcknfy 发表于 2004-10-16 18:03 static/image/common/back.gif
提供一段将LINE线转换为LWPOLYLINE的LSP原程序,大家交流交流
直接获取起点终点坐标，生成新的多断线，删除直线不就得了？？
支持………………
楼主，能不能给一个批量刷房屋结构层数的lsp，做地籍时要在地籍-输入房屋结构层数里面去输很麻烦