关于画垂线的，哪位大佬给优化一下啊，拜托了

xj6019

以下代码是两个命令，一个是画垂线的，一个是画中垂线的，最理想的是把两个命令合成一个，留个选项可以键值切换，默认垂线，能识别普通直线，构造线，块中的直线，多段线，尺寸线 运行时，普通垂线时先选择直线，然后提示垂足通过的点，中垂线时输入键值直接出结果 垂线的长度，可以用xline也可以是线，长度放的长点就行，100000就够了,默认当前图层，这些就够了，谢谢！！！ (defun c:cx() (setvar "CMDECHO" 0) (if (setq s1 (entsel "\n選取直線:")) (progn   (setq pt (cadr s1)         pt2 (osnap pt "NEAR")         pt1 (polar pt2 (angle pt2 pt) 900)         pt3 (polar pt2 (angle pt pt2) 900)         pt4 (polar pt1 (angle pt pt2) -150)         pt5 (polar pt3 (angle pt2 pt) -150))    (command "PLINE" pt4  pt1 pt3 pt5 "") )) (setvar "CMDECHO" 1) (princ) ) (defun C:ZC (/ ENT P1 P2 MP AN DI)   (setq ENT (entsel "\n選取直線:")         ENT (entget (car ENT))         P1  (cdr (assoc 10 ENT))         P2  (cdr (assoc 11 ENT))         MP  (mapcar '(lambda (X Y) (/ (+ X Y) 2.)) P1 P2)         AN  (+ (angle P1 P2) (/ PI 2.))         DI  (/ (distance P1 P2) 2.)   )   (entmake (list '(0 . "LINE")                  (cons 10 (polar MP AN DI))                  (cons 11 (polar MP AN (- DI)))   )) )

caiqs

;;;师兄QQ361865648
;;;好人做到底，送佛送到西，好吧，现在块可以使用了，尺寸也可以了，不过要多响应一次;;再要如何你自已弄了，浪费我太多时间，应该是你要的效果了
(vl-load-com)
(defun cxfun (ent / ename pickpt ponl ang p1 p2 entdat etype pt)
  (setq ename (car ent))
    (setq entdat(entget ename)
        etype(cdr(assoc 0 entdat)))
  (setq pickpt (cadr ent))
  (cond
    (  (member etype
               '("CIRCLE" "ELLIPSE" "RAY" "LINE" "XLINE" "SPLINE"
                 "LWPOLYLINE")
       )
    (setq ponl (vlax-curve-getClosestPointTo ename pickpt))
     )
    (t (setq ponl (osnap pickpt "_nea"))))
  (setq ang (angle pickpt ponl))
  (setq pt(VL-CATCH-ALL-APPLY 'getpoint (list "\n指定垂足点: ")))
  (if (and pt (not (VL-CATCH-ALL-ERROR-P pt)))
    (setq p1(polar pt ang 1000)
          p2(polar pt (+ ang pi) 1000))

  (setq        p1 (polar ponl ang 1000)
        p2 (polar ponl (+ ang PI) 1000)
  )
    )
  (entmake (list '(0 . "LINE")
                 (cons 10 p1)
                 (cons 11 p2)
           )
  )

  (princ)
)
(defun c:cx (/ ent)
  (setq ent (entsel "\n選取直線:"))
  (vl-CATCH-ALL-APPLY 'cxfun '(ent))
  (princ)
)

(defun ZCfun (ent / ename pickpt ponl ang p1 p2 entdat etype)
  (setq ename (car ent))
  (setq entdat(entget ename)
        etype(cdr(assoc 0 entdat)))
  (setq pickpt (cadr ent))
  (cond
    (  (member etype
               '("CIRCLE" "ELLIPSE" "RAY" "LINE" "XLINE" "SPLINE"
                 "LWPOLYLINE")
       )
    (setq ponl (vlax-curve-getClosestPointTo ename pickpt))
     )
    (t (setq ponl (osnap pickpt "_nea"))))

  (setq midp (osnap ponl "_mid")) ;_中点
  (setq ang (angle pickpt ponl))
  (setq        p1 (polar midp ang  1000)
        p2 (polar midp (+ ang PI)  1000)
  )
  (entmake (list '(0 . "LINE")
                 (cons 10 p1)
                 (cons 11 p2)
           )
  )
)


(defun c:ZC (/ ent)
  (setq ent (entsel "\n選取直線:"))
  (vl-CATCH-ALL-APPLY 'Zcfun '(ent))
  (princ)
)

(defun c:test (/ mystr k str mod ent mod)
  (setq        mystr (list "中垂线" "一般垂线")
        k     0
        str   (nth k mystr)
        mod   t
  )
  (while mod

    (setq ENT (VL-CATCH-ALL-APPLY
                'entsel
                (list (strcat "\n選取直線 <" str "> :"))
              )
    )
    (if
      (not (VL-CATCH-ALL-ERROR-P ent))
       (cond
         ((null ent) (setq k (- 1 k)))
          (t
            (if        (= k 0)
              (VL-CATCH-ALL-APPLY 'ZCfun (list ent))
              (VL-CATCH-ALL-APPLY 'cxfun (list ent))
            )
          )
         )
         (setq mod nil)
       )
       (setq str (nth k mystr))
    )
  (princ)
  )

caiqs

;;;师兄QQ361865648,用A键切换中垂线和一般垂线
(defun c:ts1 (/             ang    endpt  entdat entpick        ept    etype
              inpt   intpt  len           midp          midpt         mode        ospts  p1
              p2     pt            ret           sortlst         startpt       x
              y
             )
  (while (and (setq entpick (entsel "\n選取直線 :"))
              (setq entdat (entget (car entpick)))
              (setq etype (cdr (assoc 0 entdat)))
              (= etype "LINE")
         )
    (setq startpt (cdr (assoc 10 entdat))
          endpt          (cdr (assoc 11 entdat))
          midpt          (getmidpt startpt endpt)
          len          (DISTANCE startpt endpt)
          ang          (angle startpt endpt)
          mode          nil
    )
    (while (and
             (setq ret (grread t 12))
             (member (car ret) '(2 5))
           )
      (redraw)

      (cond
        ((= (car ret) 2) (setq mode (not mode)))
        ((= (car ret) 5)
         (setq pt (cadr ret))
         (setq intpt (getprep startpt endpt pt))
         ;;如果离中点很近则自动为中垂线
;;;      (if (< (DISTANCE intpt midpt) (* 0.01 len))
;;;        (setq intpt midpt))
         (if mode
           (progn
             (setq midp (osnap intpt "_mid"))
             (setq inpt (osnap intpt "_int"))
             (setq ept (osnap intpt "_end"))
             (setq ospts nil)
             (if midp
               (setq ospts (cons midp ospts))
             )
             (if inpt
               (setq ospts (cons inpt ospts))
             )
             (if ept
               (setq ospts (cons ept ospts))
             )

             (setq sortlst nil)
             (if ospts
               (setq sortlst
                      (vl-sort ospts
                               '(lambda        (x y)
                                  (<= (DISTANCE x intpt) (DISTANCE y intpt))
                                )
                      )
               )
             )
             (if sortlst
               (setq intpt (car sortlst))
             )
           )

         )

        )
      )
      (setq p1 (polar intpt (+ ang (* 0.5 PI)) (* 0.5 len))
            p2 (polar intpt (- ang (* 0.5 pi)) (* 0.5 len))
      )
      (grdraw p1 p2 3)

    )
    (redraw)
    (if        (= (car ret) 3)
      (entmake (list '(0 . "LINE")
                     (cons 10 P1)
                     (cons 11 P2)
               )
      )
    )
  )
)

xj6019

caiqs 发表于 2019-12-17 22:03
;;;师兄QQ361865648,用A键切换中垂线和一般垂线
(defun c:ts1 (/             ang    endpt  entdat entpick        ept  ...

您好老师，首先谢谢您的热心解答，您的想法虽然很新颖，但是与我的本意还是差了点
1，垂线生成预览后无法捕捉，虽然可以自由移动，但是有点过于自由了，想要放到某一个点还得手动移动一下，希望可以完善。
2.最最最重要的，我经常需要对构造线，多段线，尺寸线，图块里面的某根线做垂线，目前您的代码还是不行，这次求助主要想解决这个问题，如果不是解决这个问题，对普通直线，之前那代码是完全够我用的。
再次麻烦一下呗，把您的代码可否完善一下呀，谢谢！！

xyp1964

1. (defun c:cx ()
   
2. (setq ukw (Ukword 1 "1 2" "1-垂线/2-中垂线" ukw))
   
3.   (while (setq s1 (entsel "\n选线: "))
   
4.     (setq pt (cadr s1)
   
5.           p2 (osnap pt "near")
   
6.           rr (angle pt p2)
   
7.           p2 (if (= ukw "1") p2 (osnap pt "mid"))
   
8.           p1 (polar p2 rr 1000)
   
9.           p3 (polar p2 rr -1000)
   
10.     )
    
11.     (command "line" "non" p1 "non" p3 "")
    
12.   )
    
13.   (princ)
    
14. )

(defun c:cx ()<br /> (setq ukw (Ukword 1 "1 2" "1-垂线/2-中垂线" ukw))<br />   (while (setq s1 (entsel "\n选线: "))<br />     (setq pt (cadr s1)<br />           p2 (osnap pt "near")<br />           rr (angle pt p2)<br />           p2 (if (= ukw "1") p2 (osnap pt "mid"))<br />           p1 (polar p2 rr 1000)<br />           p3 (polar p2 rr -1000)<br />     )<br />     (command "line" "non" p1 "non" p3 "")<br />   )<br />   (princ)<br /> )

1. (defun ukword (bit kwd msg def / inp)  (if (and def (/= def ""))
   
2.     (setq msg (strcat "\n" msg "<" def ">: ")
   
3.           bit (* 2 (fix (/ bit 2)))
   
4.     )
   
5.     (setq msg (strcat "\n" msg ": "))
   
6.   )
   
7.   (initget bit kwd)
   
8.   (setq inp (getkword msg))
   
9.   (if inp inp def)
   
10. )

(defun ukword (bit kwd msg def / inp)  (if (and def (/= def ""))<br />     (setq msg (strcat "\n" msg "<" def ">: ")<br />           bit (* 2 (fix (/ bit 2)))<br />     )<br />     (setq msg (strcat "\n" msg ": "))<br />   )<br />   (initget bit kwd)<br />   (setq inp (getkword msg))<br />   (if inp inp def)<br /> )

caiqs

xyp1964 发表于 2019-12-18 00:54

抽空给你看看吧，我那个能捕捉的，只是你没有试

caiqs

xj6019 发表于 2019-12-17 22:45
您好老师，首先谢谢您的热心解答，您的想法虽然很新颖，但是与我的本意还是差了点
1，垂线生成预览后无 ...

抽空给你看看，我那个能捕捉，你没有试一下吗?

xj6019

caiqs 发表于 2019-12-18 07:37
抽空给你看看，我那个能捕捉，你没有试一下吗?

我特意试了，可能没领会到怎么捕捉技巧吧，还有别的方式吗，正常情况没有捕捉哦，主要还是特殊情况下（非普通直线）的使用问题，谢谢您的回复！

xj6019

xyp1964 发表于 2019-12-18 00:54

谢谢版主，您的代码说实在的都是关联函数，我每次看到都头疼，因为知道您的函数简洁好用，但是无奈我没法用工具箱（系统非中文）也就没法用您的一系列函数库，有兴趣搞搞多国语言版，或者研究一下能支持非中文系统支持也行哦，所以，您给的回复我也又只能望洋兴叹了，非常感谢您的回复！
这次是缺UKWORD！！！

caiqs

xj6019 发表于 2019-12-18 08:11
我特意试了，可能没领会到怎么捕捉技巧吧，还有别的方式吗，正常情况没有捕捉哦，主要还是特殊情况下（非 ...

恩明白你的意思了，晚上给你改一下吧