智能中心线
本帖最后由 /db_自贡黄明儒_ 于 2013-11-20 09:09 编辑经过这两天的奋战和大家的鼎力相助(我就不一一道谢了)，智能中心线就差不多{:soso_e113:}
**** Hidden Message *****
<P>
;;中心标记CenterMark By 自贡黄明儒 2013年11月9日***********************************
(defun C:CM (/ *MSP* CIRC CLAYER1 CMDECHO1 E1EN E1ST E2EN E2ST ELLI EN1 EN2 FIL FILTERLST LIN LWP N P0 REG SS VARTXTLST X Y)
;;1 错误处理
(defun *error* (msg)
(setvar "cmdecho" cmdecho1)
(setvar "clayer" clayer1)
(vl-bt)
(if *DOC*
(_EndUndo *DOC*) ;块内图元增减
)
(while (not (equal (getvar "cmdnames") "")) (command nil))
(princ "\n 出错啦!")
(princ)
)</P>
<P>;;2.1 从选择集中分离出特定选择集
(defun wmg-ssgetp (ss filter)
(vl-cmdf "_.select" ss "")
(ssget "p" filter)
)</P>
<P>;;2.2 分离选择集
;; (optimizeCode ss vartxtlst filterlst)
(defun optimizeCode (ss vartxtlst filterlst)
(mapcar (function (lambda (x y) (set x (wmg-ssgetp ss y))))
(mapcar 'read vartxtlst)
filterlst
)
)</P>
<P>;;3 面域质心
(defun HH:REGION (en / CEN LL LST OBJ PX1 PX2 PY1 PY2 R UR)
(setq obj (vlax-ename->vla-object en))
(setq cen (vlax-safearray->list (vlax-variant-value (vla-get-Centroid obj))))
(vla-getboundingbox obj'll 'ur)
(setq lst (mapcar 'vlax-safearray->list (list ll ur)))
(setq r (/ (distance (car lst) (cadr lst)) 2.0))
(setq px1 (mapcar '- cen (list r 0 0)))
(setq px2 (mapcar '+ cen (list r 0 0)))
(entmake (list (cons 0 "LINE") (cons 10 px1) (cons 11 px2)))
(setq py1 (mapcar '- cen (list 0 r 0)))
(setq py2 (mapcar '+ cen (list 0 r 0)))
(entmake (list (cons 0 "LINE") (cons 10 py1) (cons 11 py2)))
)</P>
<P>;;4.1 两线不平行时，画角平分线
(defun HH:Bisect (en1 en2 / P1E P1S P2E P2S PT1 PT2 PT3 X Y)
(if (> (distance p0 e1st) (distance p0 e1en))
(setq p1s e1st
p1e e1en
)
(setq p1s e1en
p1e e1st
)
)
(if (> (distance p0 e2st) (distance p0 e2en))
(setq p2s e2st
p2e e2en
)
(setq p2s e2en
p2e e2en
)
)
(setq PT1 (polar p0 (angle p0 p1s) 10))
(setq PT2 (polar p0 (angle p0 p2s) 10))
(setq PT3 (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) PT1 PT2))</P>
<P> (setq PT3 (inters p0 PT3 p1s p2s nil))
(entmake (list (cons 0 "LINE") (cons 10 P0) (cons 11 PT3)))
)</P>
<P>;;4.2 两线平行时，画梯形腰线
(defun HH:waist (en1 en2 / P0 P3 X Y)
;|(setq lst (list (list (distance e1st e2st) e1st e2st)
(list (distance e1st e2en) e1st e2en)
(list (distance e1en e2st) e1en e2st)
(list (distance e1en e2en) e1en e2en)
)
)
;http://www.xdcad.net/forum/thread-670556-1-4.html HH:ssPts:Sort定义
(setq lst (car (mapcar 'cdr (HH:ssPts:Sort lst "X" 0.0001)))) ;最远两点
(if (equal (car lst) e1st 0.001)
nil
(setq pte1st
e1st e1en
e1en pt
)
)
(if (equal (cadr lst) e2en 0.001)
nil
(setq pte2en
e2en e2st
e2st Pt
)
)|;
(if (inters e1st e2st e1en e2en)
(progn
(setq P0 (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) e1st e2en))
(setq P3 (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) e1en e2st))
)
(progn
(setq P0 (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) e1st e2st))
(setq P3 (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) e1en e2en))
)
)
(entmake (list (cons 0 "LINE") (cons 10 P0) (cons 11 P3)))
)</P>
<P>
;;5 圆、弧时，如果中心点没有相互垂直的两条线，画十字中心线
(defun HH:circleCross (en / ANG1 ANG2 E1EN E1ST E2EN E2ST EN1 EN2 ENT P10 PX1 PX2 PY1 PY2
R SS)
(setq ent (entget en))
(setq p10 (cdr (assoc 10 ent)))
(setq r (* (cdr (assoc 40 ent)) 1.25))
(if (and (setq ss (ssget "_C"
p10
p10
(list '(-4 . "<or") '(0 . "LINE") '(-4 . "<and")
'(0 . "LWPOLYLINE") '(90 . 2)
'(-4 . "and>") '(-4 . "or>")
)
)
)
(cond ((equal (sslength ss) 2)
(setq en1 (ssname ss 0))
(setq en2 (ssname ss 1))
(setq e1st (vlax-curve-getStartPoint en1))
(setq e1en (vlax-curve-getendPoint en1))
(setq e2st (vlax-curve-getStartPoint en2))
(setq e2en (vlax-curve-getendPoint en2))
(setq ang1 (angle e1st e1en))
(setq ang2 (angle e2st e2en))
(equal (rem (- ang1 ang2) (/ pi 2)) 0)
)
((> (sslength ss) 2) T)
(T nil)
)
)
nil
(progn
(setq px1 (mapcar '- p10 (list r 0 0)))
(setq px2 (mapcar '+ p10 (list r 0 0)))
(entmake (list (cons 0 "LINE") (cons 10 px1) (cons 11 px2)))
(setq py1 (mapcar '- p10 (list 0 r 0)))
(setq py2 (mapcar '+ p10 (list 0 r 0)))
(entmake (list (cons 0 "LINE") (cons 10 py1) (cons 11 py2)))
)
)
)</P>
<P>;;6 是平行四边形时画中心线，其它封闭曲线在质心处画十字线
(defun HH:CenMark (en / CEN LL LST OBJ OBJN P1 P2 PX1 PX2 PY1 PY2 R UR X Y)
;;133.2 [功能] 缩放一个点
;;scale 'pnt' from a base point of 'p1' by a factor of fact
(defun scale_pnt (pnt p1 fact /)
(polar p1 (angle p1 pnt) (* fact (distance p1 pnt)))
)</P>
<P> (if (and
(setq lst (entget en))
(setq lst (mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10)) lst)
)
)
(equal (length lst) 4)
(not (inters (car lst) (cadr lst) (caddr lst) (cadddr lst) nil))
(not (inters (cadr lst) (caddr lst) (cadddr lst) (car lst) nil))
)
(progn
(setq cen (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) (car lst) (caddr lst)))
(setq p1 (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) (car lst) (cadddr lst)))
(setq p1 (scale_pnt p1 cen 1.25))
(setq p2 (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) (cadr lst) (caddr lst)))
(setq p2 (scale_pnt p2 cen 1.25))
(entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
(setq p1 (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) (car lst) (cadr lst)))
(setq p1 (scale_pnt p1 cen 1.25))
(setq p2 (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) (caddr lst) (cadddr lst)))
(setq p2 (scale_pnt p2 cen 1.25))
(entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
)
(progn
(setq obj (vlax-ename->vla-object en))
;;(setq objN (vla-copy obj))
(or *DOC*
(setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(setq *MSP* (vla-get-Modelspace *DOC*))
(vlax-invoke *MSP* 'addregion (list obj))
(setq objN (vlax-ename->vla-object (entlast)))
(setq cen (vlax-safearray->list (vlax-variant-value (vla-get-Centroid objN))))
(vla-getboundingbox objN 'll 'ur)
(setq lst (mapcar 'vlax-safearray->list (list ll ur)))
(vla-delete objN)
(setq r (/ (distance (car lst) (cadr lst)) 2.0))
(setq px1 (mapcar '- cen (list r 0 0)))
(setq px2 (mapcar '+ cen (list r 0 0)))
(entmake (list (cons 0 "LINE") (cons 10 px1) (cons 11 px2)))
(setq py1 (mapcar '- cen (list 0 r 0)))
(setq py2 (mapcar '+ cen (list 0 r 0)))
(entmake (list (cons 0 "LINE") (cons 10 py1) (cons 11 py2)))
)
)
)</P>
<P>;;7 椭圆中心标记
;;用highflybir的程序改造一下
(defun HH:ELLIPSEMark (ent / DXF MAJ P1 P10 P2 P3 P4 PTB PTD SS fil)
(setq fil (list '(-4 . "<or") '(0 . "LINE") '(-4 . "<and")
'(0 . "LWPOLYLINE") '(90 . 2) '(-4 . "and>")
'(-4 . "or>")
)
)
(setq dxf (entget ent))
(setq p10 (cdr (assoc 10 dxf)))
(if (and (setq ss (ssget "_C" p10 p10 fil)) (> (sslength ss) 1))
nil
(progn
(setq maj (cdr (assoc 11 dxf)))
(setq ptb (vlax-curve-getPointAtParam ent (* pi 0.5)))
(setq ptd (vlax-curve-getPointAtParam ent (* pi 1.5)))
(setq p1 (mapcar '- ptd maj))
(setq p2 (mapcar '+ ptd maj))
(setq p3 (mapcar '+ ptb maj))
(setq p4 (mapcar '- ptb maj))
(entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p3)))
(entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 p4)))
)
)
)</P>
<P>;;8本程序主程序
(setq fil (list '(-4 . "<or") '(0 . "CIRCLE") '(0 . "ARC") '(0 . "ELLIPSE") '(0 . "LINE")'(0 . "REGION")
'(-4 . "<and") '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 1) '(90 . 2) '(-4 . "or>")
'(-4 . "and>") '(-4 . "or>"))
)
(if (cadr (ssgetfirst))
(setq ss (ssget "_P" fil))
(setq ss (ssget fil))
)
(vl-load-com)
(or *DOC*
(setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(_StartUndo *DOC*)
(setq cmdecho1 (getvar "cmdecho"))
(setq clayer1 (getvar "clayer"))
(setvar "cmdecho" 0)</P>
<P>(vl-cmdf "_layer" "make" "中心线" "Color" 6 "" "L" "ACAD_ISO10W100" "" "")
(setq vartxtlst (list "CIRC" "ELLI" "LIN" "LWP" "REG"))
(setq filterlst (list (list '(0 . "CIRCLE,ARC"))
(list '(0 . "ELLIPSE"))
(list '(-4 . "<or") '(0 . "LINE") '(-4 . "<and")
'(0 . "LWPOLYLINE") '(90 . 2)
'(-4 . "and>")'(-4 . "or>")
)
(list '(0 . "LWPOLYLINE") '(70 . 1))
(list '(0 . "REGION"))
)
)
(optimizeCode ss vartxtlst filterlst)
(setvar "cmdecho" cmdecho1)
(if CIRC
(repeat (setq n (sslength CIRC))
(HH:circleCross (ssname CIRC (setq n (1- N))))
)
)
(if ELLI
(repeat (setq n (sslength ELLI))
(HH:ELLIPSEMark (ssname ELLI (setq n (1- N))))
)
)
(if LWP
(repeat (setq n (sslength LWP))
(HH:CenMark (ssname LWP (setq n (1- N))))
)
)
(if REG
(repeat (setq n (sslength REG))
(HH:REGION (ssname REG (setq n (1- N))))
)
)
;|(if LIN
(progn (setq lst (HH:ssPts:Sort LIN "xy" 0.0001))
(while (> (length lst) 1)
(setq en1 (car lst))
(setq en2 (cadr lst))
(setq lst (cddr lst))
(setq e1st (vlax-curve-getStartPoint en1))
(setq e1en (vlax-curve-getendPoint en1))
(setq e2st (vlax-curve-getStartPoint en2))
(setq e2en (vlax-curve-getendPoint en2))
(setq p0 (inters e1st e1en e2st e2en nil))
(if p0
(HH:Bisect en1 en2)
(HH:waist en1 en2)
)
)
)
)|;
(if LIN
(while (> (sslength LIN) 1)
(setq en1 (ssname LIN 0))
(setq en2 (ssname LIN 1))
(ssdel en1 LIN)
(ssdel en2 LIN)
(setq e1st (vlax-curve-getStartPoint en1))
(setq e1en (vlax-curve-getendPoint en1))
(setq e2st (vlax-curve-getStartPoint en2))
(setq e2en (vlax-curve-getendPoint en2))
(setq p0 (inters e1st e1en e2st e2en nil))
(if p0
(HH:Bisect en1 en2)
(HH:waist en1 en2)
)
)
)
(setvar "clayer" clayer1)
(_EndUndo *DOC*)
(gc)
(princ)
)
;;中心标记CenterMark By 自贡黄明儒 2013年11月9日***********************************</P> 椭圆的不对吧 st788796 发表于 2013-11-19 14:56
椭圆的不对吧
那就帮改改吧!
本帖最后由 st788796 于 2013-11-19 15:11 编辑
/db_自贡黄明儒_ 发表于 2013-11-19 15:00
那就帮改改吧!
纯 Lisp 太罗嗦了, 一会儿上一个 API 写的
直线就不加了,这个不适合批量处理
楼主，两根直线的那个你是怎么定义他们在一起的？
newer 发表于 2013-11-19 15:45
楼主，两根直线的那个你是怎么定义他们在一起的？
没有考虑，仅用了ssget，如果是先后画的，或者只选择了两条直线，就没有问题；其它情况可能要出错了 楼主的本意是在 质心 处画线还是在 Box 中心？这和 ARC 部分 Ellipse 非闭合 pline 有关，闭合线也不能自相交的，情况复杂 st788796 发表于 2013-11-19 16:10
楼主的本意是在 质心 处画线还是在 Box 中心？这和 ARC 部分 Ellipse 非闭合 pline 有关，闭合线也不能自相 ...
我在实际工作发现，自相交闭合曲线这种情况没有出现过，考虑非自相交闭合曲线这种情况就可以。再说，即使自相交，我只求它的质心，一般情况下够用了。 /db_自贡黄明儒_ 发表于 2013-11-19 16:14
我在实际工作发现，自相交闭合曲线这种情况没有出现过，考虑非自相交闭合曲线这种情况就可以。再说，即使 ...
CAD 下的质心算法目前只有面域来求，对规则图形用 XD::Pnts:Centroid 或者 XDRX_Points_Centroid 能够重合，但曲线的（如 ARC闭合后）前者求得的质心和后两个函数取模拟点求得的质心有一点点误差！
st788796 发表于 2013-11-19 16:51
CAD 下的质心算法目前只有面域来求，对规则图形用 XD:nts:Centroid 或者 XDRX_Points_Centroid 能够重 ...
ARC求质心意义不大， /db_自贡黄明儒_ 发表于 2013-11-19 21:28
ARC求质心意义不大，
还没有调试
(defun c:tt (/ _pi2 mkmark other_center polyline_center ss)
(setq _pi2 (/ pi 2))
(defun mkmark (p an xl yl / hxl hyl p1 p2 p3 p4)
(setq hxl (* 1.4 xl)
hyl (* 1.4 yl)
p1(polar p an hxl)
p2(polar p (+ an pi) hxl)
p3(polar p (+ an _pi2) hyl)
p4(polar p (- an _pi2) hyl)
)
(xdrx_line_make p1 p2)
(xdrx_entity_setlayer (entlast) "中心线")
(xdrx_line_make p3 p4)
(xdrx_entity_setlayer (entlast) "中心线")
)
(defun Polyline_center (e / info pts p1 p2 p3 p4 sp radius)
(setq info (xdrx_curve_info e)
pts(xdrx_geom_searchoutline e)
)
(cond
((XD::Polyline:IsRectang e)
(mapcar 'set '(p1 p2 p3 p4) pts)
(mkmark (cdr (assoc "Centroid" info))
(angle p1 p2)
(* (distance p1 p2) 0.5)
(* (distance p2 p3) 0.5)
)
)
((XD::Polyline:IsPolygon e)
(setq pcen (assoc (xdrx_curve_info e))
sp (xdrx_curve_getstartpoint e)
radius (distance sp pcen)
)
(mkmark Pcen
(angle pcen sp)
radius
radius
)
)
(t (other_center e))
)
)
(defun other_center (e / info centroid box)
(setq info (xdrx_curve_info e)
centroid (cdr (assoc "Centroid" info))
box (mapcar 'abs (apply 'mapcar (cons '- (assoc "Box" info))))
)
(mkmark centroid
centroid
0.
(* 0.5 (car box))
(* 0.5 car box)
)
)
;;main program
(if (setq ss (ssget '((0 . "*polyline,arc,circle,ellipse"))))
(progn
(xdrx_layer_make "中心线" 6 "ACAD_ISO10W100")
(mapcar '(lambda (x / typ radius majoraxis)
(setq typ (xdrx_getpropertyvalue x "IsA"))
(cond
((wcmatch typ "AcDbCircle,AcDbArc")
(setq radius (xdrx_getpropertyvalue x "Radius"))
(mkmark (xdrx_getpropertyvalue x "Center")
0.
radius
radius
)
)
((= typ "AcDbEllipse")
(setq
majoraxis (xdrx_getpropertyvalue x "MajorAxis")
)
(mkmark (xdrx_getpropertyvalue x "Center")
(angle '(0. 0.) Majoraxis)
(xdrx_vector_length Majoraxis)
(xdrx_vector_length
(xdrx_getpropertyvalue x "MinorAxis")
)
)
)
((= typ "AcDbPolyline")
(polyline_center x)
)
(t (other_center x))
)
)
(xdrx_pickset->ents ss)
)
)
)
(princ)
) 这个求中心线程序很好用！ 错误: *error* 函数中出错AutoCAD 变量设置被拒绝: "cmdecho" nil
什么原因啊？ 本帖最后由 myfrankie 于 2013-11-20 09:59 编辑
错误: *error* 函数中出错AutoCAD 变量设置被拒绝: "cmdecho" nil是怎么回事
myfrankie 发表于 2013-11-20 09:56
错误: *error* 函数中出错AutoCAD 变量设置被拒绝: "cmdecho" nil是怎么回事
你是刚才下载的吗？