一个心线程序，求改

行雲

针对选择集里面的直线，试图给它画中点垂线，即十字垂直线。加了些红色代码，没成功，不知是否选择集没衔接上。请各位高人帮忙给看看，谢谢大家。原程序来自网络。

;;编组开始
(defun _StartUndo (*DOC*)
  (_EndUndo *DOC*)
  (vla-StartUndoMark *DOC*)
)
;;结束编组
(defun _EndUndo (*DOC*)
  (if (= 8 (logand 8 (getvar 'UNDOCTL)))
    (vla-EndUndoMark *DOC*)
  )
)
(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 分离选择集
  (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)
  )
  ;;4.3 单线画称中心线
  (defun HH:cen (en1 ent/ Pt1 Pt2 l al Pt3 Pt4 Pt5)
    (setq ent (entget en1))
    (setq Pt1 (cdr (assoc 10 ent)))
    (setq Pt2 (cdr (assoc 11 ent)))
    (setq l (distance Pt1 Pt2))
    (setq al (angle Pt1 Pt2))
    (setq Pt3 (polar Pt1 al (/ l 2)))
    (setq P1 (polar Pt3 (+ al (* pi 1.5)) (/ l 2)))
    (setq P2 (polar Pt3 (+ al (* pi 0.5)) (/ l 2)))
    ；(command "line" P1 P2 "")
  )
  ;;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.2))
    (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)
    (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.2))
        (setq p2 (mid (cadr lst) (caddr lst)))
        (setq p2 (scale_pnt p2 cen 1.2))
        (Ptline p1 p2)
        (setq p1 (mid (car lst) (cadr lst)))
        (setq p1 (scale_pnt p1 cen 1.2))
        (setq p2 (mid (caddr lst) (cadddr lst)))
        (setq p2 (scale_pnt p2 cen 1.2))
        (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 椭圆中心标记
  (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" "DIM" "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)
(HH:cen en1)
      (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)
)

Lisphk

红色代码你想做什么？

你执行你的代码有什么错误，提示？

贴个图片和上传个图吧，执行前什么样，你想变成什么样

行雲

Lisphk 发表于 2017-2-3 21:18

你好。
原程序执行效果如图中上半部分那样。
添加的红色代码想实现图中下半部分那样，给直线画一条垂直中心线。
添加的红色代码之后，原程序受到干扰，图中上半部分右侧，画平行中心线的功能失效。
框选那两条平行线时，错误如下




此外，框选单条直线，程序无任何反应，如图

xyp1964

2. ;;4.3 单线画称中心线
   
3. ;; (hh:cen (setq s1 (car (entsel "\n选择: "))))
   
4. (defun hh:cen (en1 / ent pt1 pt2 leng rad pt3 pt4 pt5)
   
5.   (setq ent  (entget en1)
   
6.         pt1  (cdr (assoc 10 ent))
   
7.         pt2  (cdr (assoc 11 ent))
   
8.         leng (* (distance pt1 pt2) 0.5)
   
9.         rad  (angle pt1 pt2)
   
10.         pt3  (mid pt1 pt2)
    
11.         p1   (polar pt3 (+ rad (* pi 1.5)) leng)
    
12.         p2   (polar pt3 (+ rad (* pi 0.5)) leng)
    
13.   )
    
14.   (command "line" p1 p2 "")
    
15. )

;;4.3 单线画称中心线<br /> ;; (hh:cen (setq s1 (car (entsel "\n选择: "))))<br /> (defun hh:cen (en1 / ent pt1 pt2 leng rad pt3 pt4 pt5)<br />   (setq ent  (entget en1)<br />         pt1  (cdr (assoc 10 ent))<br />         pt2  (cdr (assoc 11 ent))<br />         leng (* (distance pt1 pt2) 0.5)<br />         rad  (angle pt1 pt2)<br />         pt3  (mid pt1 pt2)<br />         p1   (polar pt3 (+ rad (* pi 1.5)) leng)<br />         p2   (polar pt3 (+ rad (* pi 0.5)) leng)<br />   )<br />   (command "line" p1 p2 "")<br /> )

行雲

xyp1964 发表于 2017-2-4 23:03

多谢xyp1964 版主出手相助，将那代码嵌进去之后，框选单线仍无反应，

请问是不是这里接的位置不对
  (if LIN
    (while (> (sslength LIN) 1)
      (setq en1 (ssname LIN 0))
      (setq en2 (ssname LIN 1))
      (ssdel en1 LIN)
      (ssdel en2 LIN)
；(HH:cen en1) ；接在这里，框选单线无反应
      (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)
(HH:cen en1) ；接在这里，加载程序即报   错误: *error* 函数中出错AutoCAD 变量设置被拒绝: "cmdecho" nil
      )
    )
  )