智能中心线

/db_自贡黄明儒_ · 发表于 2013-11-19 14:54:17

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由 /db_自贡黄明儒_ 于 2013-11-20 09:09 编辑

经过这两天的奋战和大家的鼎力相助(我就不一一道谢了)，智能中心线就差不多{:soso_e113:}

游客，如果您要查看本帖隐藏内容请回复

;;中心标记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)
)
;;2.1 从选择集中分离出特定选择集
(defun wmg-ssgetp (ss filter)
(vl-cmdf "_.select" ss "")
(ssget "p" filter)
)
;;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
)
)
;;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)))
)
;;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))
(setq PT3 (inters p0 PT3 p1s p2s nil))
(entmake (list (cons 0 "LINE") (cons 10 P0) (cons 11 PT3)))
)
;;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 pt e1st
e1st e1en
e1en pt
)
)
(if (equal (cadr lst) e2en 0.001)
nil
(setq pt e2en
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)))
)
;;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)))
)
)
)
;;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)))
)
(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)))
)
)
)
;;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)))
)
)
)
;;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)
(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日***********************************

;;中心标记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) 
  ) 
  ;;2.1 从选择集中分离出特定选择集 
  (defun wmg-ssgetp (ss filter) 
    (vl-cmdf "_.select" ss "") 
    (ssget "p" filter) 
  ) 
  ;;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 
    ) 
  ) 
  ;;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)))    
  ) 
  ;;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)) 
    (setq PT3 (inters p0 PT3 p1s p2s nil)) 
    (entmake (list (cons 0 "LINE") (cons 10 P0) (cons 11 PT3))) 
  ) 
  ;;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 pt  e1st 
     e1st e1en 
     e1en pt 
      ) 
    ) 
    (if (equal (cadr lst) e2en 0.001) 
      nil 
      (setq pt  e2en 
     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)))    
  ) 
 
  ;;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))) 
      ) 
    ) 
  ) 
  ;;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))) 
    ) 
    (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))) 
      ) 
    ) 
  ) 
  ;;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))) 
      ) 
    ) 
  ) 
  ;;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) 
  (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日***********************************

st788796 · 发表于 2013-11-19 14:56:53

椭圆的不对吧

/db_自贡黄明儒_ · 发表于 2013-11-19 15:00:51

st788796 发表于 2013-11-19 14:56
椭圆的不对吧

那就帮改改吧!

st788796 · 发表于 2013-11-19 15:08:38

本帖最后由 st788796 于 2013-11-19 15:11 编辑

/db_自贡黄明儒_ 发表于 2013-11-19 15:00
那就帮改改吧!

纯 Lisp 太罗嗦了, 一会儿上一个 API 写的

直线就不加了,这个不适合批量处理

newer · 发表于 2013-11-19 15:45:40

楼主，两根直线的那个你是怎么定义他们在一起的？

/db_自贡黄明儒_ · 发表于 2013-11-19 16:01:51

newer 发表于 2013-11-19 15:45
楼主，两根直线的那个你是怎么定义他们在一起的？

没有考虑，仅用了ssget，如果是先后画的，或者只选择了两条直线，就没有问题；其它情况可能要出错了

st788796 · 发表于 2013-11-19 16:10:13

楼主的本意是在质心处画线还是在 Box 中心？这和 ARC 部分 Ellipse 非闭合 pline 有关，闭合线也不能自相交的，情况复杂

/db_自贡黄明儒_ · 发表于 2013-11-19 16:14:10

st788796 发表于 2013-11-19 16:10
楼主的本意是在质心处画线还是在 Box 中心？这和 ARC 部分 Ellipse 非闭合 pline 有关，闭合线也不能自相 ...

我在实际工作发现，自相交闭合曲线这种情况没有出现过，考虑非自相交闭合曲线这种情况就可以。再说，即使自相交，我只求它的质心，一般情况下够用了。

st788796 · 发表于 2013-11-19 16:51:24

/db_自贡黄明儒_ 发表于 2013-11-19 16:14
我在实际工作发现，自相交闭合曲线这种情况没有出现过，考虑非自相交闭合曲线这种情况就可以。再说，即使 ...

CAD 下的质心算法目前只有面域来求，对规则图形用 XD::Pnts:Centroid 或者 XDRX_Points_Centroid 能够重合，但曲线的（如 ARC闭合后）前者求得的质心和后两个函数取模拟点求得的质心有一点点误差！

/db_自贡黄明儒_ · 发表于 2013-11-19 21:28:49

st788796 发表于 2013-11-19 16:51
CAD 下的质心算法目前只有面域来求，对规则图形用 XD:nts:Centroid 或者 XDRX_Points_Centroid 能够重 ...

ARC求质心意义不大，

st788796 · 发表于 2013-11-20 00:23:27

/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)
)

(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) 
)

混沌初开 · 发表于 2013-11-20 00:23:29

这个求中心线程序很好用！

混沌初开 · 发表于 2013-11-20 00:33:06

错误: *error* 函数中出错AutoCAD 变量设置被拒绝: "cmdecho" nil
什么原因啊？

myfrankie · 发表于 2013-11-20 09:56:49

本帖最后由 myfrankie 于 2013-11-20 09:59 编辑

错误: *error* 函数中出错AutoCAD 变量设置被拒绝: "cmdecho" nil 是怎么回事

/db_自贡黄明儒_ · 发表于 2013-11-20 10:13:26

myfrankie 发表于 2013-11-20 09:56
错误: *error* 函数中出错AutoCAD 变量设置被拒绝: "cmdecho" nil 是怎么回事

你是刚才下载的吗？

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

[研讨] 智能中心线

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分

相关帖子

点评

点评

点评

点评

点评

点评

点评

点评

点评

点评