本帖最后由 x_s_s_1 于 2026-2-4 15:44 编辑

如上图所示，任意lwpolyline，先选择图元，再选择图元外任意一点（point），在图元接近选择点的端头增设200长的线段，线段与原始线段夹角45度，且指向point所在方位（象限）。用向量解法，谢谢

以下是我自己的代码，没解决anchorpt所在方位的判断问题，也就是方位点在基线的哪个象限
  1. (defun vec-Rot2D  (v a / c s x y)
  2.   (setq  c (cos a)
  3.   s (sin a))
  4.   (setq  x (car v)
  5.   y (cadr v))
  6.   (list (- (* x c) (* y s)) (+ (* x s) (* y c))))
  7. (defun vec-unit   (v / norm)
  8.   (setq norm (vec-norm v))
  9.   (cond  ((= 1. norm) v)
  10.   ((> norm 1e-14) (vec-vxs v (/ 1. norm)))
  11.   ((equal 0. norm 1e-14) nil)))
  12. (defun vec-norm   (v)
  13.   (sqrt (apply (function +) (vec-v*v v v))))
  14. (defun vec-vxs  (v sc)
  15.   (mapcar (function (lambda (n) (* n sc))) v))
  16. (defun vec-Dot  (v1 v2)
  17.   (apply (function +) (vec-v*v v1 v2)))
  18. (defun vec-v*v  (v1 v2)
  19.   (mapcar (function *) v1 v2))
  20. (defun xty-make-gjxg  (en selectpt anchorpt)
  21.   (setq  pts   (vlax-curve-getstartpoint en)
  22.   pte   (vlax-curve-getendpoint en)
  23.   len   (vlax-curve-getdistatpoint en pte)
  24.   selectpt (vlax-curve-getclosestpointto en selectpt)
  25.   len1   (vlax-curve-getdistatpoint en selectpt))
  26.   (if (<= len1 (- len len1))
  27.     (progn (setq v (vlax-curve-getfirstDeriv
  28.          en
  29.          (vlax-curve-getstartparam en))
  30.      v (vec-unit v)
  31.      v (vec-Rot2D v (* 0.25 pi)))
  32.      (vl-cmdf "pline"
  33.         "none"
  34.         pts
  35.         "none"
  36.         (mapcar '+ pts (vec-vxs v 200))
  37.         ""))
  38.     (progn (setq v (vlax-curve-getfirstDeriv en (vlax-curve-getendparam en))
  39.      v (vec-unit v)
  40.      v (vec-Rot2D v (* 0.75 pi)))
  41.      (vl-cmdf "pline"
  42.         "none"
  43.         pte
  44.         "none"
  45.         (mapcar '+ pte (vec-vxs v 200))
  46.         "")))
  47.   (setq  ss (ssadd)
  48.   ss (ssadd en ss)
  49.   ss (ssadd (entlast) ss))
  50.   (vl-cmdf "pedit" "m" ss "" "j" "" ""))
  51. (defun c:tt  ()
  52.   (setq  en (entsel)
  53.   pt (cadr en)
  54.   en (car en))
  55.   (xty-make-gjxg en pt (getpoint)))



网友答: 本帖最后由 夏生生 于 2026-2-5 17:38 编辑

搞定了，现在在外，稍后发上来
  1. (defun make-gjxg  (en  selectpt anchorpt /     gjxg_j
  2.            en1  len   len1    pte1     pte2
  3.            pte3  pteparam pts1    pts2     pts3
  4.            ptsparam)
  5.   (defun gjxg_j
  6.    (en P1 P2 P3 p ang / cen ptn ptn1 ptn2 ptt1 ptt2 v v1 v2 va)
  7.     (setq v    (vlax-curve-getfirstDeriv
  8.      en
  9.      (vlax-curve-getparamatpoint en p1)) ;_起始（终）点切向量
  10.     v    (vec-unit v) ;_起始（终）点单位切向量
  11.     v1   (vec-Rot2D v ang) ;_正旋转
  12.     v2   (vec-Rot2D v (- ang)) ;_负旋转
  13.     ptn1 (mapcar '+ p1 (vec-vxs v1 200)) ;_正旋转点
  14.     ptn2 (mapcar '+ p1 (vec-vxs v2 200))) ;_负旋转点
  15.     (if  (setq cen (G-3ptcen p1 p2 p3))
  16.       (if (< (distance p (car cen)) (cadr cen)) ;_方向点是否在圆内
  17.   (setq ptn ptn1)
  18.   (setq ptn ptn2))
  19.       (progn (setq ptt1  (g-pertoline p P1 p3) ;_方向点在线段上投影
  20.        va  (mapcar '- p ptt1) ;_方向点向量
  21.        ptt2  (mapcar '+ p1 va)) ;_起始（终）点偏移
  22.        (if (< (G-PerDistToLine ptn1 ptt1 ptt2)
  23.         (G-PerDistToLine ptn2 ptt1 ptt2)) ;_离偏移线近者为所需
  24.          (setq ptn ptn1)
  25.          (setq ptn ptn2))))
  26.     (make-lwpl (list p1 ptn) 0 0))
  27.   (setq  pts1   (vlax-curve-getstartpoint en) ;_起点
  28.   ptsparam (vlax-curve-getstartparam en) ;_起点参数
  29.   pts2   (vlax-curve-getpointatparam en (+ ptsparam 0.5)) ;_起始段中间点
  30.   pts3   (vlax-curve-getpointatparam en (1+ ptsparam)) ;_起始段终点
  31.   pte1   (vlax-curve-getendpoint en) ;_终点
  32.   pteparam (vlax-curve-getendparam en) ;_终点参数
  33.   pte2   (vlax-curve-getpointatparam en (- pteparam 0.5)) ;_终止段中间点
  34.   pte3   (vlax-curve-getpointatparam en (1- pteparam)) ;_终止段起点
  35.   len   (vlax-curve-getdistatpoint en pte1) ;_线段长
  36.   selectpt (vlax-curve-getclosestpointto en selectpt) ;_选择点在线上的投影
  37.   len1   (vlax-curve-getdistatpoint en selectpt)) ;_投影点距起点距离
  38.   (if (<= len1 (- len len1)) ;_当离起点近
  39.     (setq en1 (gjxg_j en pts1 pts2 pts3 anchorpt (* 0.25 pi)))
  40.     (setq en1 (gjxg_j en pte1 pte2 pte3 anchorpt (* 0.75 pi)))
  41.     )
  42.   (vl-cmdf "pedit" "m" en en1 "" "j" "" ""))
  43. (defun c:tt  ()
  44.   (setq  en (entsel)
  45.   pt (cadr en)
  46.   en (car en))
  47.   (make-gjxg en pt (getpoint)))



网友答: 本帖最后由 ytl1223 于 2026-2-4 13:28 编辑

搬别人得代码 之后 自己改得 看看你 适用不适用

  3. (defun c:AA (/ ee p d pp enf)
  4.   (setq ee (nentselp (getpoint)))
  5.   (setq p (cadr ee))
  6.   (setq d 50)
  7.   (setq pp (list (mapcar '- p (list d 0)) p (mapcar '+ p (list d 0))))
  8.   (foreach p pp
  9.     (setq enf (apv p))
  10.   )
  11.   (entmod
  12.     (subst (cons 10 (mapcar '+ p (mapcar '- (getpoint "\n 插入点") p)))
  13.      (cons 10 (list (car p) (cadr p)))
  14.      enf
  15.     )
  16.   )
  17.   (princ)
  18. )


  21. (defun apv (p / *error* a b e h l n r v w x z en lp)

  23.   (defun *error* (msg)
  24.     (LM:endundo (LM:acdoc))
  25.     (if  (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
  26.       (princ (strcat "\nError: " msg))
  27.     )
  28.     (princ)
  29.   )

  31.   (cond
  32.     ((null p)
  33.      nil
  34.     )
  35.     ((null (setq e (nentselp p)))
  36.      (princ "\n not lie on a polyline.")

  38.     )
  39.     ((= 4 (length e))
  40.      (princ
  41.        "\nThis program is not compatible with nested objects."
  42.      )
  43.     )
  44.     ((/= "LWPOLYLINE" (cdr (assoc 0 (entget (setq e (car e))))))
  45.      (princ "\nThe specified point does not lie on a polyline.")
  46.     )

  48.   )

  50.   (if (and p
  51.      e
  52.      (setq p (vlax-curve-getclosestpointto e (trans p 1 0))
  53.      n (vlax-curve-getparamatpoint e p)
  54.      )
  55.       )
  56.     (if  (not (equal n (fix n) 1e-8))
  57.       (progn
  58.   (setq e  (entget e)
  59.         h  (reverse (member (assoc 39 e) (reverse e)))
  60.         v  (assoc 90 h)
  61.         l  (LM:LWVertices e)
  62.         z  (assoc 210 e)
  63.   )
  64. ;;;        (print l )
  65.   (repeat  (fix n)
  66.     (setq  a (cons (car l) a)
  67.     l (cdr l)
  68.     )
  69.   )
  70.   (setq x  (car l)
  71.         r  (- n (fix n))
  72.         w  (cdr (assoc 40 x))
  73.         w  (+ w (* r (- (cdr (assoc 41 x)) w)))
  74.         b  (atan (cdr (assoc 42 x)))
  75.   )
  76.   (LM:startundo (LM:acdoc))
  77.   (setq en (entmod
  78.        (append
  79.          (subst (cons 90 (1+ (cdr v))) v h)
  80.          (apply 'append (reverse a))
  81.          (list
  82.            (assoc 10 x)
  83.            (assoc 40 x)
  84.            (cons 41 w)
  85.            (cons 42 (tan (* r b)))
  86. ;;;          (cons  42 0.414214)
  87.            (cons 10 (trans p 0 (cdr z)))
  88.            (cons 40 w)
  89.            (assoc 41 x)
  90.            (cons 42 (tan (* (- 1.0 r) b)))
  91.          )
  92.          (apply 'append (cdr l))
  93.          (list z)
  94.        )
  95.      )
  96.   )
  97.   (LM:endundo (LM:acdoc))
  98.       )
  99.     )
  100.   )
  101.   (princ)
  102.   en
  103. )


  106. (defun tan (x)
  107.   (if (not (equal 0.0 (cos x) 1e-10))
  108.     (/ (sin x) (cos x))
  109.   )
  110. )


  113. (defun LM:LWVertices (e)
  114.   (if (setq e (member (assoc 10 e) e))
  115.     (cons
  116.       (list
  117.   (assoc 10 e)
  118.   (assoc 40 e)
  119.   (assoc 41 e)
  120.   (assoc 42 e)
  121.       )
  122.       (LM:LWVertices (cdr e))
  123.     )
  124.   )
  125. )



  129. (defun LM:startundo (doc)
  130.   (LM:endundo doc)
  131.   (vla-startundomark doc)
  132. )



  136. (defun LM:endundo (doc)
  137.   (while (= 8 (logand 8 (getvar 'undoctl)))
  138.     (vla-endundomark doc)
  139.   )
  140. )


  143. (defun LM:acdoc  nil
  144.   (eval  (list 'defun
  145.         'LM:acdoc
  146.         'nil
  147.         (vla-get-activedocument (vlax-get-acad-object))
  148.   )
  149.   )
  150.   (LM:acdoc)
  151. )

  153. ;;----------------------------------------------------------------------;;

  155. (vl-load-com)
  156. (princ)






网友答:
ytl1223 发表于 2026-2-4 13:26
搬别人得代码 之后 自己改得 看看你 适用不适用

谢谢您的帮助，但抱歉，不是这样的

网友答: 本帖最后由 ytl1223 于 2026-2-4 16:58 编辑

试试这次得这个 是不是你想要的啊  


  4. (defun c:vv (/ ee p d pp enf)
  5.   (setq ee (nentselp (getpoint)))
  6.   (setq p (cadr ee))
  7.   (setq enf (apv p))
  8.   (princ)
  9. )


  12. (defun apv (p / *error* a b e h l n r v w x z en lp RR P2)

  14.   (defun *error* (msg)
  15.     (LM:endundo (LM:acdoc))
  16.     (if        (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
  17.       (princ (strcat "\nError: " msg))
  18.     )
  19.     (princ)
  20.   )

  22. ;;;    (while
  23. ;;;        (progn ;;(setq p (getpoint "\nSpecify point for new vertex: "))
  24.   (cond
  25.     ((null p)
  26.      nil
  27.     )
  28.     ((null (setq e (nentselp p)))
  29.      (princ "\n not lie on a polyline.")

  31.     )
  32.     ((= 4 (length e))
  33.      (princ
  34.        "\nThis program is not compatible with nested objects."
  35.      )
  36.     )
  37.     ((/= "LWPOLYLINE" (cdr (assoc 0 (entget (setq e (car e))))))
  38.      (princ "\nThe specified point does not lie on a polyline.")
  39.     )

  41.   )

  43.   (if (and p
  44.            e
  45.            (setq p (vlax-curve-getclosestpointto e (trans p 1 0))
  46.                  n (vlax-curve-getparamatpoint e p)
  47.            )
  48.       )
  49.     (if        T
  50.       ;;(not (equal n (fix n) 1e-8))
  51.       (progn

  53.         (setq e        (entget e)
  54.               h        (reverse (member (assoc 39 e) (reverse e)))
  55.               v        (assoc 90 h)
  56.               l        (LM:LWVertices e)
  57.               z        (assoc 210 e)
  58.         )
  59.         (if (< n (/ (1- (cdr v)) 2))
  60.           (setq n 0)
  61.           (setq n (1- (cdr v)))
  62.         )
  63. ;;;              (print l )
  64. ;;;                (if (> n 1) (+1 n) 0)
  65.         (print (length l))

  67.         (repeat        (fix n)
  68.           (setq        a (cons (car l) a)
  69.                 l (cdr l)
  70.           )
  71.         )
  72.         (setq x (car l))

  74.         (LM:startundo (LM:acdoc))
  75.         (setq RR (/ (* 180
  76.                        (angle (cdr (assoc 10 x))
  77.                               (getpoint (cdr (assoc 10 x)))
  78.                        )
  79.                     )
  80.                     PI
  81.                  )
  82.         )
  83.         (setq RR
  84.                (cond
  85.                  ((<= RR 90) (* pi 0.25))
  86.                  ((<= RR 180) (* pi 0.75))
  87.                  ((<= RR 270) (* pi 1.25))
  88.                  ((<= RR 360) (* pi 1.75))
  89.                )
  90.         )
  91.         (setq p2 (polar (cdr (assoc 10 x)) RR 200))

  93.         (setq en (entmod
  94.                    (append
  95.                      (subst (cons 90 (1+ (cdr v))) v h)
  96.                      (apply 'append (reverse a))
  97.                      (if (> n (/ (1- (cdr v)) 2))
  98.                        (apply 'append (list x))
  99.                      )
  100.                      (list
  101.                        (cons 10 p2)
  102.                        (cons 40 0)
  103.                        (cons 41 0)
  104.                        (cons 42 0)
  105.                      )
  106.                      (if (< n (/ (1- (cdr v)) 2))
  107.                        (apply 'append l)
  108.                        (apply 'append (cdr l))
  109.                      )


  112.                      (list z)
  113.                    )
  114.                  )
  115.         )
  116.         (LM:endundo (LM:acdoc))
  117.       )
  118.     )
  119.   )
  120.   (princ)
  121.   en
  122. )

  124. ;; Tangent  -  Lee Mac
  125. ;; Args: x - real

  127. (defun tan (x)
  128.   (if (not (equal 0.0 (cos x) 1e-10))
  129.     (/ (sin x) (cos x))
  130.   )
  131. )

  133. ;; LW Vertices  -  Lee Mac
  134. ;; Returns a list of lists in which each sublist describes
  135. ;; the position, starting width, ending width and bulge of the
  136. ;; vertex of a supplied LWPolyline

  138. (defun LM:LWVertices (e)
  139.   (if (setq e (member (assoc 10 e) e))
  140.     (cons
  141.       (list
  142.         (assoc 10 e)
  143.         (assoc 40 e)
  144.         (assoc 41 e)
  145.         (assoc 42 e)
  146.       )
  147.       (LM:LWVertices (cdr e))
  148.     )
  149.   )
  150. )

  152. ;; Start Undo  -  Lee Mac
  153. ;; Opens an Undo Group.

  155. (defun LM:startundo (doc)
  156.   (LM:endundo doc)
  157.   (vla-startundomark doc)
  158. )

  160. ;; End Undo  -  Lee Mac
  161. ;; Closes an Undo Group.

  163. (defun LM:endundo (doc)
  164.   (while (= 8 (logand 8 (getvar 'undoctl)))
  165.     (vla-endundomark doc)
  166.   )
  167. )

  169. ;; Active Document  -  Lee Mac
  170. ;; Returns the VLA Active Document Object

  172. (defun LM:acdoc        nil
  173.   (eval        (list 'defun
  174.               'LM:acdoc
  175.               'nil
  176.               (vla-get-activedocument (vlax-get-acad-object))
  177.         )
  178.   )
  179.   (LM:acdoc)
  180. )

  182. ;;----------------------------------------------------------------------;;

  184. (vl-load-com)
  185. (princ)




网友答:
ytl1223 发表于 2026-2-4 16:48
试试这次得这个 是不是你想要的啊

再次感谢，还是不对，角度是固定的，和select point的区位有关系，但角度和它没关系，角度固定是45度

网友答: 本帖最后由 xyp1964 于 2026-2-5 18:38 编辑

  1. (defun c:tt ()
  2.   "tt(象限画线)"
  3.   (defun line (p1 p2)
  4.     (entmakex (list '(0 . "LINE")'(100 . "AcDbEntity")'(100 . "AcDbLine")(cons 10 p1)(cons 11 p2)))
  5.   )
  6.   (defun abc(s1 s2)(command "pedit" "m" s1 s2 "" "j" "" ""))  
  7.   (if (and (setq e (entsel "\n选择: "))
  8.            (setq s1 (car e))
  9.            (setq p1 (cadr e))
  10.            (= (cdr (assoc 0 (entget s1))) "LWPOLYLINE")
  11.            (setq p0 (getpoint "\n基点<退出>: "))
  12.       )
  13.     (progn
  14.       (mapcar 'set'(pt1 pt2)(list (vlax-curve-getStartPoint s1)(vlax-curve-getEndPoint s1)))
  15.       (setq ps (if (< (distance p0 pt1) (distance p0 pt2)) pt1 pt2)
  16.             r1 (angle p1 p0)
  17.       )
  18.       (cond ((< 0 r1 (* pi 0.5))(line ps (polar ps (* pi 0.25) 200))(abc s1 (entlast)))
  19.             ((< (* pi 0.5) r1 (* pi 1))(line ps (polar ps (* pi 0.75) 200))(abc s1 (entlast)))
  20.             ((< (* pi 1) r1 (* pi 1.5))(line ps (polar ps (* pi 1.25) 200))(abc s1 (entlast)))
  21.             ((< (* pi 1.5) r1 (* pi 2))(line ps (polar ps (* pi 1.75) 200))(abc s1 (entlast)))
  22.       )
  23.     )
  24.   )
  25.   (princ)
  26. )


网友答:
xyp1964 发表于 2026-2-4 19:16

谢谢院长，您这个只对单段直线段，对于多段线和首尾带弧段的不适用。

网友答:


     如果只是达到这个效果的话   可以先判断点击点是否在多段线内 ，如果在多段线圆弧内， 且圆弧向上凸，则短线角度取正45度  否则在圆弧外且向上凸则取正135度  ；反之，如果点击点在多段线圆弧内，且圆弧向下凸，则角度取-45度，否则若在圆弧外  且向下凸，则取-135度


网友答: 本帖最后由 xyp1964 于 2026-2-5 20:02 编辑


利用 vla-addVertex 函数应该更专业

  • 上一篇：ShxViewer(查看cad字体文件中定义的字符）
  • 下一篇：没有了
    CAD技术交流中心 | 建筑CAD | 给排水CAD | 暖通CAD | 电气CAD | 电力CAD | 机械CAD | CAD母线槽 | CAD看图
    Copyright © 2019 - 2025