将直线更改为矩形乐筑天下 - Powered by Discuz! Archiver

Sooshiant 发表于 2022-7-6 00:00:26

pBe否没有多段线
我们只有一些线，如案例1中所示，并希望将它们更改为案例2，与它们的中心点相关。

pBe 发表于 2022-7-6 00:01:51

可以发誓拼写成普林

试试这个：

(defun c:l2r ( /ss e ent ang pts)
(if (not width) (setq width 1.00))
(setq width (cond
                  ((getdist
                        (strcat "\nEnter Width <"
                                 (rtos width 2 2)
                                 ">: ")))
                  (width)))
(if (setq ss (ssget '((-4 . "<OR")
   (-4 . "<AND")(0 . "LWPOLYLINE")(90 . 2)(42 . 0)(-4 . "AND>")
   (0 . "LINE")(-4 . "OR>"))))
(repeat (setq i (sslength ss))
   (setq e (ssname ss (Setq i (1- i))))
   (setq ent (entget e)
ang (angle (setq sp (vlax-curve-getStartPoint e))
(setq ep (vlax-curve-getendPoint e))
)
   )
   (setq pts (mapcar
   '(lambda (pt)
      (list (setq
      p_ (polar pt (+ ang (/ pi 2.0)) (* 0.5 width))
   )
   (polar p_ (+ ang (* pi 1.5)) width)
      )
   )
   (list sp ep)
)
pts (apply 'append (list (car pts) (reverse (cadr pts))))
   )
   (entmakex
(append (list (cons 0 "LWPOLYLINE")
      (cons 100 "AcDbEntity")
      (assoc 8 ent)
      (cons 100 "AcDbPolyline")
      (cons 90 (length pts))
      (cons 70 1)
)
(mapcar (function (lambda (p) (cons 10 p))) pts)
)
   )
   (entdel e)
)
)
)

多段/弧段

(defun c:l2r2 ( /ss i e pts ob)
(setq pac (getvar 'peditaccept))
(setvar 'peditaccept 1)
(if (not width) (setq width 1.00))
(setq width (cond
                  ((getdist
                        (strcat "\nEnter Width <"
                                 (rtos width 2 2)
                                 ">: ")))
                  (width)))
(if (setq ss (ssget '((0 . "LWPOLYLINE,LINE"))))
(repeat (setq i (sslength ss))
      (setq e (ssname ss (Setq i (1- i))) sss (ssadd))
(setq pts (mapcar
   '(lambda (y)
      (list (vlax-curve-getStartPoint y)
      (vlax-curve-getEndPoint y)
      )
      )
(mapcar 'car
      (mapcar
'(lambda (x)
   (setq ob (vlax-invoke
      (vlax-ename->vla-object e)
      'Offset
      x
   )
)
   (ssadd (entlast) sss)
ob
)
(list (setq h (* 0.5 width))
      (- h)
)
      )
)
   )
      )
(mapcar '(lambda (k l)
   (entmakex (list (cons 0 "LINE") (cons 10 k) (cons 11 l)))
   (ssadd (entlast) sss)
   )
(car pts)(cadr pts)
)
   (command "_.pedit" "_m" sss """_j" 0.0 "")
(entdel e)
)
)
(setvar 'peditaccept pac)
(princ)
)

asos2000 发表于 2022-7-6 00:06:47

检查这个
还有这个

Sooshiant 发表于 2022-7-6 00:09:50

谢谢pBe。你是个天才。我该怎么做作为回报？我可以存钱吗？

David Bethel 发表于 2022-7-6 00:15:11

为什么不打一个简单的PEDIT电话？

Command: pedit
Select polyline: (pause) or ename

Object selected is not a polyline
Do you want to turn it into one? <Y> y

Close/Join/Width/Edit vertex/Fit/Spline/Decurve/Ltype gen/Undo/eXit <X>: Width

Enter new width for all segments: 0.5

Close/Join/Width/Edit vertex/Fit/Spline/Decurve/Ltype gen/Undo/eXit <X>:eXit

-大卫

Snownut 发表于 2022-7-6 00:18:49

这是（青蛙毛）一个新的，与“青蛙屁股防水吗？”。

Sooshiant 发表于 2022-7-6 00:20:35

pedit编辑宽度只是改变线条的可见性，但pBe编写的代码将线条重塑为矩形，这有助于用户通过捕捉模式解决方案根据矩形的边缘和侧面绘制更多细节。

EthanY 发表于 2022-7-6 00:25:00

我也试了一下。但我的代码有点凌乱，没有pBe的那么清晰。而且它的兼容性没有经过测试。

干杯

; Covert multiple lines or plines to rectangles with given width
; 21 MAR 2014 @ MELBOURNE
; yxinst@gmail.com
(vl-load-com)
(princ)
(defun c:L2REC (/ _ss->lst subl2rec ss obs odist )
(defun _ss->lst (sset / i lst)
(setq i 0)
(while (< i (sslength sset))
(setq lst (cons (vlax-ename->vla-object (ssname sset i)) lst))
(setq i (+ i 1))
)
lst
)
;offset in 2 directions and link ends
(defun subl2rec (oblst dist / l1 l2 l3 l4 temp pt11 pt12 pt21 pt22)
(mapcar '(lambda (x)
   (setq l1 (vlax-vla-object->ename
(car (vlax-safearray->list
(vlax-variant-value (vla-offset x dist))
      )
)
)
   l2 (vlax-vla-object->ename
(car (vlax-safearray->list
(vlax-variant-value (vla-offset x (- 0 dist)))
      )
)
)
   )
   (if (/= "LINE" (cdr (assoc 0 (entget l1))))
(progn (command "_explode" l1)
(setq l1 (entlast))
(command "_explode" l2)
(setq l2 (entlast))
)
   )
   (setq pt11 (cdr (assoc 10 (entget l1)))
   pt12 (cdr (assoc 11 (entget l1)))
   pt21 (cdr (assoc 10 (entget l2)))
   pt22 (cdr (assoc 11 (entget l2)))
   )
   (if (equal (distance pt11 pt22) (* 2 dist))
(setq temp pt22
   pt22 pt21
   pt21 temp
)
   )
   (command "_line" pt11 pt21 "")
   (setq l3 (entlast))
   (command "_line" pt12 pt22 "")
   (setq l4 (entlast))
   (command "_pedit" l1 "y" "j" l3 "" "j" l2 "" "j" l4 "" "")
)
oblst
)
)
(princ "Select multiple lines or plines please.")
(setq ss (ssget))
(setq obs (_ss->lst ss))
(setq odist (/ (getreal "Width?: ") 2))
(subl2rec obs odist)
(command "erase" ss "")
(princ)
)

页: 1 [2]

乐筑天下's Archiver