智能中心线

coco08

;;中心标记CenterMark By 自贡黄明儒 2013年11月9日***********************************
(defun C:CM1 (/ *MSP* CIRC CLAYER1 CMDECHO1 E1EN E1ST E2EN E2ST ELLI EN1 EN2 FIL FILTERLST LIN LWP N P0 REG SS VARTXTLST X Y)
  ;;0 错误处理;;编组开始;
(command "_.undo" "be")
(defun _StartUndo (*DOC*)
  (_EndUndo *DOC*)
  (vla-StartUndoMark *DOC*)
)
;;结束编组;
(if (= 8 (logand (getvar "undoctl") 8)) (command "_.undo" "_e"))
(defun _EndUndo (*DOC*)
  (if (= 8 (logand 8 (getvar 'UNDOCTL)))
    (vla-EndUndoMark *DOC*)
  )
)
  (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>  ;;1 两点之中点
  (defun mid (p1 p2 / X Y)
    (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) p1 p2)
  )</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 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))
    (Ptline (mapcar '- cen (list r 0 0)) (mapcar '+ cen (list r 0 0)))   
    (Ptline (mapcar '- cen (list 0 r 0)) (mapcar '+ cen (list 0 r 0)))
  )</P>
<P>  ;;4.1 两线不平行时，画角平分线
  (defun HH:Bisect (en1 en2 / PT1 PT2 PT3 X Y)
    (if (< (distance p0 e1st) (distance p0 e1en))
      (setq e1st e1en)
    )
    (if (< (distance p0 e2st) (distance p0 e2en))
      (setq e2st e2en)
    )
    (setq PT1 (polar p0 (angle p0 e1st) 10))
    (setq PT2 (polar p0 (angle p0 e2st) 10))
    (setq PT3 (mid PT1 PT2))
    (setq PT3 (inters p0 PT3 e1st e2st nil))
    (Ptline p0 PT3)
  )</P>
<P>  ;;4.2 两线平行时，画腰线(找对称中心线)----------请帮忙加上延长线系数*1.25，谢谢
  (defun HH:waist (en1 en2 / P0 P3 X Y)   
    (if (inters e1st e2st e1en e2en)
      (setq P0 (mid e1st e2en)
     P3 (mid e1en e2st)
      )
      (setq P0 (mid e1st e2st)
     P3 (mid e1en e2en)
      )
    )
(Ptline p0 p3)
      )</P>
<P>  ;;5 圆、弧时，如果中心点没有相互垂直的两条线，画十字中心线
  (defun HH:circleCross (en / ANG1 ANG2 E1EN E1ST E2EN E2ST EN1 EN2 ENT P10 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
(Ptline (mapcar '- p10 (list r 0 0)) (mapcar '+ p10 (list r 0 0)))
(Ptline (mapcar '- p10 (list 0 r 0)) (mapcar '+ p10 (list 0 r 0)))
      )
    )
  )</P>
<P>  ;;6 是平行四边形时画中心线，其它封闭曲线在质心处画十字线
  (defun HH:CenMark (en / CEN LL LST OBJ OBJN P1 P2 PX1 PX2 PY1 PY2 R UR X Y la)
    ;;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 (mid (car lst) (caddr lst)))
(setq p1 (mid (car lst) (cadddr lst)))
(setq p1 (scale_pnt p1 cen 1.25))
(setq p2 (mid (cadr lst) (caddr lst)))
(setq p2 (scale_pnt p2 cen 1.25))
(Ptline p1 p2)
(setq p1 (mid (car lst) (cadr lst)))
(setq p1 (scale_pnt p1 cen 1.25))
(setq p2 (mid (caddr lst) (cadddr lst)))
(setq p2 (scale_pnt p2 cen 1.25))
(Ptline p1 p2)
      )
      (progn
(setq *MSP* (vla-get-Modelspace *DOC*))
(vlax-invoke *MSP* 'addregion (list (vlax-ename->vla-object en)))
(setq la (entlast))
(HH:REGION la)
(vla-delete (vlax-ename->vla-object la))
      )
    )
  )</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))
(Ptline p1 p3)
(Ptline p2 p4)
      )
    )
  )</P>
<P>  ;;8 两点画直线
  (defun Ptline (p1 p2)
    (entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
  )</P>
<P>  ;;9  本程序主程序
  (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 "Color" 1 "" "_LINETYPE" "s" "center" "" "CELWEIGHT" "9" "")
  (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
    (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日**********************************
;;;;请帮忙恢复变量(vl-cmdf "Color" bylayer "" "_LINETYPE" "s" "bylayer" "" "CELWEIGHT" "-1" "")

tljdhh

谢谢分享，下来看看

bhf0114

不错哦，支持一下

浮世小半生

这个很强大

yifengqiuye

以前看到过，主要是收集到了新函数

o0g9

oooooooooooooooo

zxfway

好东西，谢谢楼主！

lea丶丶

顶一个。。。。。。。。。。。

十分之一

支持一下，谢谢分享！

xuanhu103

xie xie fen xiang!!!!!!!!!!!!!!!!