智能中心线

自贡黄明儒 · 发表于 2013-11-19 14:58:17

本帖最后由自贡黄明儒于 2013-11-23 10:59 编辑

感谢大家帮助

;;编组开始;(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*)
  )
)

;;中心标记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)
;;0 错误处理
(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)
)
;;1 两点之中点
(defun mid (p1 p2 / X Y)
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) p1 p2)
)
;;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 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)))
)
;;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)
)
;;4.2 两线平行时，画梯形腰线(找对称中心线)
(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)
)
;;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)))
)
)
)
;;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)))
)
(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))
)
)
)
;;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)
)
)
)
;;8 两点画直线
(defun Ptline (p1 p2)
(entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2)))
)
;;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)
(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
(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) 
  ;;0 错误处理 
  (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) 
  ) 
  ;;1 两点之中点 
  (defun mid (p1 p2 / X Y) 
    (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) p1 p2) 
  ) 
  ;;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 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))) 
  ) 
  ;;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) 
  ) 
  ;;4.2 两线平行时，画梯形腰线(找对称中心线) 
  (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) 
  ) 
  ;;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))) 
      ) 
    ) 
  ) 
  ;;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))) 
    ) 
    (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)) 
      ) 
    ) 
  ) 
  ;;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) 
      ) 
    ) 
  ) 
  ;;8 两点画直线 
  (defun Ptline (p1 p2) 
    (entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))) 
  ) 
  ;;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) 
  (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 
    (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日***********************************

zmzk · 发表于 2021-2-15 19:55:29

下面这种图片http://bbs.mjtd.com/forum.php?mod=attachment&aid=MTEyMzk0fDlkOTEyMjRmYTVkODkzZDllMjQyOTMxNDk0OTZiNGJjfDE3MzE1NjY4Mzc%3D&request=yes&_f=.jpg

zmzk · 发表于 2021-2-15 19:53:18

黄大师，请问，能否把平行线的中心线加长，让中心线比平行线长出很多？在哪里改啊？

liu22737 · 发表于 2013-11-19 15:35:59

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

win7 AUTOCAD2008
不能运行
; 错误: *error* 函数中出错AutoCAD 变量设置被拒绝: "cmdecho" nil

我觉得椭圆中心线应该在旋转45°,两线应该垂直

香田里浪人 · 发表于 2013-11-19 18:18:26

winxp AUTOCAD2004不能运行;
错误: *error* 函数中出错AutoCAD 变量设置被拒绝: "cmdecho" nil

ynhh · 发表于 2013-11-20 11:10:00

支持黄工,感谢分享

yunfengning · 发表于 2013-11-20 12:43:49

错误: *error* 函数中出错AutoCAD 变量设置被拒绝

原地踏步 · 发表于 2013-11-20 12:58:53

好像不错，下来看看

长风（尚品） · 发表于 2013-11-20 12:59:41

路过。学习学习

海盗曹 · 发表于 2013-11-20 15:11:19

支持一下哦~

hao3ren · 发表于 2013-11-20 15:28:21

老黄厉害啊

langjs · 发表于 2013-11-20 15:32:32

不错哦，支持一下

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

[讨论] 智能中心线

本帖子中包含更多资源

点评

本帖被以下淘专辑推荐:

相关帖子

本帖子中包含更多资源

点评

点评

评分