在多段线上绘制矩形

Rakumbada · 发表于 2022-7-6 09:05:34

您好，如果这可以通过lisp实现，我需要您的帮助。我有一条样线，我想在它的两个连续顶点上画一个矩形，高度给定，在图纸上是X。多段线可能有4到无限个顶点。我不管生成的矩形是在多段线/多边形的内部还是外部。

或者单击多段线的一段，它将创建具有给定高度的矩形。所以我只需要点击每个部分。也可以将高度存储为变量，这样我就不必再次输入，除非高度再次更改。就像我们进行偏移一样，最后的偏移距离也会被存储，并且可以通过按enter键再次调用。谢谢大家，祝你们度过愉快的一天。

Tharwat · 发表于 2022-7-6 09:28:34

欢迎来到论坛。

这是我刚刚为您编写的代码。如果多段线在内部，而您希望它们在外部绘制，那么只需调用命令reverse并在
源多段线。

copy


(defun c:TesT (/ e lst i j d p1 p2 ang p3 p4)
 ;;=====   TharwaT  =====;;
 ;;===== 31.07.2011 =====;;
 (if (not x)
   (setq x 1.0)
 )
 (if
   (and
     (setq e (car (entsel "\n Select a polyline : ")))
     (member (cdr (assoc 0 (entget e)))
             '("LWPOLYLINE" "POLYLINE")
     )
     (setq
       x (cond ((getdist (strcat "\n Specify the Depth distance <"
                                 (rtos x 2)
                                 "> :"
                         )
                )
               )
               (atoi x)
         )
     )
   )
    (progn
      (setq lst (vl-remove-if-not
                  (function (lambda (x)
                              (eq (car x) 10)
                            )
                  )
                  (entget e)
                )
      )
      (setq i 0
            j 1
      )
      (repeat (1- (length lst))
        (setq
          d (distance
              (setq p1 (vlax-curve-getpointatparam e i))
              (setq p2 (vlax-curve-getpointatparam e (setq i (1+ i))))
            )
        )
        (setq ang (angle p1 p2))
        (entmakex
          (list '(0 . "LWPOLYLINE")
                '(100 . "AcDbEntity")
                '(100 . "AcDbPolyline")
                '(90 . 5)
                '(70 . 1)
                (cons 10 p1)
                (cons 10 p2)
                (cons 10 (setq p3 (polar p2 (- ang 1.5708) x)))
                (cons 10 (setq p4 (polar p3 (angle p2 p1) d)))
          )
        )
      )
    )
    (princ
      "\n You missed the Polyline or it's not a Polyline !! ... "
    )
 )
 (princ)
)

塔瓦特

Tharwat · 发表于 2022-7-6 09:37:31

除了“撤消”选项外，该选项在处理矩形多段线（正方形）时更好一些。

copy


(defun c:TesT (/ *error* acdoc e lst i j l d p1 p2 ang p3 p4)
 ;;=====   TharwaT  =====;;
 ;;===== 31.07.2011 =====;;
 (vl-load-com)
 (defun *error* (msg)
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
       (princ (strcat "\n** Error: " msg " **"))
   )
   (princ)
 )
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
 (if (not x)
   (setq x 1.0)
 )
 (if
   (and
     (setq e (car (entsel "\n Select a polyline : ")))
     (member (cdr (assoc 0 (entget e)))
             '("LWPOLYLINE" "POLYLINE")
     )
     (setq
       x (cond ((getdist (strcat "\n Specify the Depth distance <"
                                 (rtos x 2)
                                 "> :"
                         )
                )
               )
               (atoi x)
         )
     )
   )
    (progn
      (vla-StartUndoMark acdoc)
      (setq lst (vl-remove-if-not
                  (function (lambda (x)
                              (eq (car x) 10)
                            )
                  )
                  (entget e)
                )
      )
      (setq i 0
            j 1
      )
      (if (not (eq 4 (setq l (length lst))))
        (setq l (1- l))
      )
      (repeat l
        (setq
          d (distance
              (setq p1 (vlax-curve-getpointatparam e i))
              (setq p2 (vlax-curve-getpointatparam e (setq i (1+ i))))
            )
        )
        (setq ang (angle p1 p2))
        (entmakex
          (list '(0 . "LWPOLYLINE")
                '(100 . "AcDbEntity")
                '(100 . "AcDbPolyline")
                '(90 . 5)
                '(70 . 1)
                (cons 10 p1)
                (cons 10 p2)
                (cons 10 (setq p3 (polar p2 (- ang 1.5708) x)))
                (cons 10 (setq p4 (polar p3 (angle p2 p1) d)))
          )
        )
      )
      (vla-EndUndoMark acdoc)
    )
    (princ
      "\n You missed the Polyline or it's not a Polyline !! ... "
    )
 )
 (princ)
)

Tharwat

stevesfr · 发表于 2022-7-6 09:52:39

有趣的是，它只适用于LWpolyline，而不适用于普林斯？如果我做错了什么呢。如果我将Pline转换为LW，那么它可以工作。
TIA

Tharwat · 发表于 2022-7-6 09:57:49

我相信你指的是三维多边形而不是多段线。所以这不包括在内。

Lee Mac · 发表于 2022-7-6 10:07:30

有一段时间了，下面是另一个纯香草AutoLISP版本，用于LWPolylines：

copy

(defun c:doit ( / angle0 angle1 angle2 bulge elist entity point1 point2 selection xsize ) ;; Lee Mac 2011
   (initget 1)
   (setq xsize (getdist "\nHeight: "))
   (if (setq selection (ssget '((0 . "LWPOLYLINE"))))
       (while (setq entity (ssname selection 0))
           (setq elist (entget entity))
           (if (= 1 (logand 1 (cdr (assoc 70 elist))))
               (setq elist (append elist (list (assoc 10 elist))))
           )
           (repeat  (+ (cdr (assoc 90 elist)) (logand 1 (cdr (assoc 70 elist))) -1)
               (setq point1 (assoc 10 elist)
                     elist  (cdr (member point1 elist))
                     point2 (assoc 10 elist)
                     bulge  (* 2.0 (atan (cdr (assoc 42 elist))))
                     angle0 (angle (cdr point1) (cdr point2))
                     angle1 (- angle0 (+ (/ pi 2.) bulge))
                     angle2 (- angle0 (- (/ pi 2.) bulge))
               )
               (entmakex
                   (list
                       (cons 0 "LWPOLYLINE")
                       (cons 100 "AcDbEntity")
                       (cons 100 "AcDbPolyline")
                       (cons 90 4)
                       (cons 70 0)
                       point1
                       (cons 10 (polar (cdr point1) angle1 xsize))
                       (assoc 42 elist)
                       (cons 10 (polar (cdr point2) angle2 xsize))
                       point2
                       (assoc 210 elist)
                   )
               )
           )
           (ssdel entity selection)
       )
   )
   (princ)
)

应适用于所有UCS/视图和LW多段线弧。

[编程交流] 在多段线上绘制矩形

发表回复

精选推荐