沿多段线复制？乐筑天下 - Powered by Discuz! Archiver

rjohnson42 发表于 2022-7-6 07:47:33

沿多段线复制？

我以前搜索过这个，但没有找到我想要的。我希望能够沿着多段线复制块，因此结果如下所示：
在水平方向上，应沿多段线每隔单位宽度（1.5）插入块，直到强制其与多段线同步。当强制步进时，它水平步进块宽度的一半（0.75）。垂直方向上，块应为一个块单元（1.33），因为它遵循多段线。

目前，我正在使用“running bond pattern”并使用copym命令覆盖多段线的范围。然后我使用fastsel命令来选择所有与poyline接触的块。问题是它并不是一直都很有效，我也不能使用一个命令同时执行这两个操作。

谢谢你的帮助！

marko_ribar 发表于 2022-7-6 08:07:06

这并不完全是你想要的，但结果大致相同。。。

(vl-load-com)
(defun c:copysquarealongpline ( / osm a +a -a ss pl stpt enpt loop ptint d )
(setq osm (getvar 'osmode))
(setvar 'osmode 0)
(setq a (getdist "\nDimension of edge of square : "))
(setq +a a)
(setq -a (- a))
(while (not ss)
(prompt "\nSelect 2d polyline witch vertices are oriented from left to right to perform copym of square along it")
(setq ss (ssget ":L" '((0 . "*POLYLINE"))))
)
(setq pl (ssname ss 0))
(setq stpt (vlax-curve-getstartpoint pl))
(setq enpt (vlax-curve-getendpoint pl))
(if (> (cadr stpt) (cadr enpt))
(progn
(setq loop T)
(while loop
   (setq ptint (vlax-curve-getclosestpointtoprojection pl (list (car stpt) (+ (cadr stpt) a) (caddr stpt)) '(1.0 0.0 0.0)))
   (setq d (- (car ptint) (car stpt)))
   (if (not (eq a -a))
      (vl-cmdf "_.rectangle" stpt "d" +a +a (list (+ (car stpt) 1.0) (+ (cadr stpt) 1.0) (caddr stpt)))
      (vl-cmdf "_.rectangle" stpt "d" +a +a (list (+ (car stpt) 1.0) (- (cadr stpt) 1.0) (caddr stpt)))
   )
   (if ptint
      (repeat (fix (/ d +a))
      (vl-cmdf "_.copy" (entlast) "" '(0.0 0.0 0.0) (list +a 0.0 0.0) "")
      )
   )
   (if (eq a +a)
      (if (eq (cadr ptint) (+ (cadr stpt) a))
      (setq stpt ptint)
      (progn
         (vl-cmdf "_.pedit" pl "r" "")
         (setq ptint nil a 0.0)
      )
      )
   )
   (if (eq a 0.0)
      (if (eq (cadr ptint) (cadr stpt))
      (setq stpt ptint a -a)
      )
   )
   (if (and (not (equal stpt ptint 1e-) (eq a -a))
      (progn
      (if (equal ptint enpt 1e-
         (progn
            (setq d (- (car enpt) (car stpt)))
            (setq loop nil)
         )
      )
      (if (eq (cadr ptint) (+ (cadr stpt) a))
         (setq stpt ptint)
      )
      )
   )
)
(vl-cmdf "_.pedit" pl "r" "")
)
(progn
(vl-cmdf "_.pedit" pl "r" "")
(setq stpt (vlax-curve-getstartpoint pl))
(setq enpt (vlax-curve-getendpoint pl))
(setq loop T)
(while loop
   (setq ptint (vlax-curve-getclosestpointtoprojection pl (list (car stpt) (+ (cadr stpt) a) (caddr stpt)) '(1.0 0.0 0.0)))
   (setq d (- (- (car ptint) (car stpt))))
   (if (not (eq a -a))
      (vl-cmdf "_.rectangle" stpt "d" +a +a (list (- (car stpt) 1.0) (+ (cadr stpt) 1.0) (caddr stpt)))
      (vl-cmdf "_.rectangle" stpt "d" +a +a (list (- (car stpt) 1.0) (- (cadr stpt) 1.0) (caddr stpt)))
   )
   (if ptint
      (repeat (fix (/ d +a))
      (vl-cmdf "_.copy" (entlast) "" '(0.0 0.0 0.0) (list -a 0.0 0.0) "")
      )
   )
   (if (eq a +a)
      (if (eq (cadr ptint) (+ (cadr stpt) a))
      (setq stpt ptint)
      (progn
         (vl-cmdf "_.pedit" pl "r" "")
         (setq ptint nil a 0.0)
      )
      )
   )
   (if (eq a 0.0)
      (if (eq (cadr ptint) (cadr stpt))
      (setq stpt ptint a -a)
      )
   )
   (if (and (not (equal stpt ptint 1e-) (eq a -a))
      (progn
      (if (equal ptint enpt 1e-
         (progn
            (setq d (- (car enpt) (car stpt)))
            (setq loop nil)
         )
      )
      (if (eq (cadr ptint) (+ (cadr stpt) a))
         (setq stpt ptint)
      )
      )
   )
)
)
)
(setvar 'osmode osm)
(princ)
)
(defun c:csapl nil (c:copysquarealongpline))
(prompt "\nShortcut to c:copysquarealongpline is c:csapl")
(princ)

您好，M.R。
P、 S.多段线必须有一个顶部。。。如果多段线有底部，则沿X轴镜像多段线，执行例程，并沿X轴镜像回结果。。。还请注意，直线段必须上升到顶部，然后段必须不断下降，直到结束。。。只允许一段上升和一段下降，但段之间的角度可能不同。。。

rjohnson42 发表于 2022-7-6 08:21:37

谢谢，M.R.有几项我不知道如何在LISP中执行，我相信您可以在代码中解决这些问题。我将尝试实现我的算法，看看我的结果如何。

rjohnson42 发表于 2022-7-6 08:33:01

我想我会在这里回答，因为这与我最初的常规目标有关。

我使用此例程获取选定多段线的顶点（从AfraLISP）：

(defun c:coord (/ e len n e1)

(setq e (entget (car (entsel))))
;get the entity list

(setq len (length e))
;get the length of the list

(setq n 0)
;set counter to zero

(repeat len
;repeat for the length of the entity list

(setq e1 (car (nth n e)))
;get each item in the entity list
;and strip the entity code number

(if (= e1 10)
;check for code 10 (vertex)

(progn
;if it's group 10 do the following

(terpri)
   ;new line

            (setq pt (cdr (nth n e))) ;; my code starts here
      (cdr (reverse (setq lst (list pt lst))))
      (reverse (cdr lst)) ;; my code ends here

);progn

);if
(setq n (1+ n))
;increment the counter

);repeat

(princ)
);defun
(princ)

我需要的不是打印的顶点，而是一个列表。我在那里插入了我认为有效的内容，但它将一个列表放在一个列表中。。。有人能帮我吗？谢谢

Lee Mac 发表于 2022-7-6 08:46:42

你好，rjohnson42，

下面是五个示例，演示如何从LWPolyline图元中检索顶点列表。

以下每个函数都需要一个参数：LWPolyline图元，并将返回所提供LWPolyline的顶点列表（以OCS表示）。

下面包含一个测试功能，用于测试。

(defun LM:LW-Vertices ( ent / _lwvertices )
(defun _lwvertices ( en / pair )
   (if (setq pair (assoc 10 en))
      (cons (cdr pair) (_lwvertices (cdr (member pair en))))
   )
)
(_lwvertices (entget ent))
)

(defun LM:LW-Vertices ( ent )
(apply 'append (mapcar '(lambda ( x ) (if (= 10 (car x)) (list (cdr x)))) (entget ent)))
)

(defun LM:LW-Vertices ( ent / lst )
(foreach pair (entget ent)
   (if (= 10 (car pair))
      (setq lst (cons (cdr pair) lst))
   )
)
(reverse lst)
)

(defun LM:LW-Vertices ( ent / _group2 )
(defun _group2 ( lst )
   (if lst
      (cons (list (car lst) (cadr lst)) (_group2 (cddr lst)))
   )
)
(_group2 (vlax-get (vlax-ename->vla-object ent) 'coordinates))
)

(defun LM:LW-Vertices ( ent )
(mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget ent)))
)

下面是一个测试函数，展示了如何调用上述任何函数：

(defun c:test ( / e )
(if
   (and
      (setq e (car (entsel "\nSelect LWPolyline: ")))
      (eq "LWPOLYLINE" (cdr (assoc 0 (entget e))))
   )
   (LM:LW-Vertices e)
)
)

rjohnson42 发表于 2022-7-6 08:48:05

谢谢你，李。我想我知道我现在做错了什么——我的列表语法错了。

页: [1]

乐筑天下's Archiver

沿多段线复制？