使用choosen在X轴上拉伸

3dwannab · 发表于 2022-7-5 17:17:13

我真的希望有人能帮我。我不希望你的努力白费。我在LISP中的限制是有限的，因为最初的fn是第一次尝试使用LISP。

我很乐意帮你，但我的知识还不够。

希望罗伊043的回答有一些用处。

我确实喜欢拉伸的工作方式，像正常行为一样，它与CP一起工作。但我注意到，虽然在拾取pt1后，它不会像正常的ACAD拉伸那样从一个点开始断裂。

太挑剔了！我只想让它的核心功能发挥作用。

Roy_043 · 发表于 2022-7-5 17:18:37

我将使用一个函数来重新计算相对于pt1的pt2。

copy

; Round half towards pos. or neg. infinity.
(defun Round (num)
 (fix ((if (minusp num) - +) num 0.5))
)
; Recalculate pt so that the X, Y and Z distance to base are n times dim.
(defun ModularizePoint (pt base dim)
 (mapcar
   '(lambda (coorPt coorBase)
     (+ coorBase (* dim (Round (/ (- coorPt coorBase) (float dim)))))
   )
   pt
   base
 )
)
(defun c:bsx (/ *error* vl ov ss pt1 pt2 gridx ansx)
 (defun *error* (msg)
   (if ov (mapcar 'setvar vl ov))
   (if (not (wcmatch (strcase msg) "*CANCEL*,*EXIT*"))
     (princ (strcat "\n<< Error: " msg " >>"))
   )
   (princ)
 )
 (setq vl '("CMDECHO"))
 (setq ov (mapcar 'getvar vl))
 (mapcar 'setvar vl '(0))
 (if
   (and
     (princ "\nSelect entities to stretch by crossing-window or crossing-polygon: ")
     (setq ss (ssget))
     (setq pt1 (getpoint "\nSelect Base Point: "))
     (setq pt2 (getpoint pt1 "\nSelect Second Point: "))
   )
   (progn
     (initget "215mm 225mm 235mm Custom LockXOnly")
     (setq ansx (getkword "\nX Brick Size ? [215mm/225mm/235mm/Custom/LockXOnly] <225mm>: "))
     (cond
       ((or (not ansx) (= "215mm" ansx))
         (setq gridx 215)
       )
       ((= "225mm" ansx)
         (setq gridx 225)
       )
       ((= "235mm" ansx)
         (setq gridx 235)
       )
       ((= "Custom" ansx)
         (setq gridx (getint))
       )
     )
     (if gridx (setq pt2 (ModularizePoint pt2 pt1 gridx)))
     (command "_.stretch" ss "" "_non" pt1 "_non" (list (car pt2) (cadr pt1)))
     (princ
       (strcat
         "\nLocked axis dim " (if gridx "ON " "OFF ")
         "\nStretched on X: " (rtos (- (car pt2) (car pt1))) " "
       )
     )
   )
 )
 (mapcar 'setvar vl ov)
 (princ)
)

3dwannab · 发表于 2022-7-5 17:22:29

谢谢Roy_043。

对不起，我没有早点回来。我生病了。

这是Grrrs lisp的不同变体。但不幸的是，它不能根据CO-或CO+来增加或减少10mm。

在拾取对象之前，是否可以添加拉伸选项，使拉伸跨越到所选砖层的增量？

我附加了一个dwg，以更清楚地说明我希望拉伸如何工作。
砖拉伸试验。图纸

Roy_043 · 发表于 2022-7-5 17:25:48

试试这个：

copy

(vl-load-com)
; Round half towards pos. or neg. infinity.
(defun Round (num)
 (fix ((if (minusp num) - +) num 0.5))
)
; Recalculate pt so that the X, Y and Z distance to base are n times module plus joint.
(defun ModularizePoint (pt base module joint)
 (mapcar
   '(lambda (coordPt coordBase)
     (+ coordBase joint (* module (Round (/ (- coordPt coordBase) (float module)))))
   )
   pt
   base
 )
)
(defun c:bsx (/ *error* doc ansx gridx jointx pt1 pt2 ss)
 (defun *error* (msg)
   (setvar 'cmdecho 1)
   (vla-endundomark doc)
   (if (not (wcmatch (strcase msg) "*CANCEL*,*EXIT*"))
     (princ (strcat "\n<< Error: " msg " >>"))
   )
   (princ)
 )
 (setq doc (vla-get-activedocument (setq cad (vlax-get-acad-object))))
 (vla-endundomark doc)
 (vla-startundomark doc)
 (if
   (and
     (princ "\nSelect entities to stretch by crossing-window or crossing-polygon: ")
     (setq ss (ssget))
     (setq pt1 (getpoint "\nSelect Base Point: "))
     (setq pt2 (getpoint pt1 "\nSelect Second Point: "))
   )
   (progn
     (setvar 'cmdecho 0)
     (initget "Stand Min Plus Custom None")
     (setq ansx (getkword "\nX Brick Size (Standard=112.5 Joint=10)? [stand/stand Min joint/stand Plus joint/Custom/None] <Stand>: "))
     (cond
       ((or (not ansx) (= "Stand" ansx))
         (setq gridx 112.5)
         (setq jointx 0.0)
       )
       ((= "Min" ansx)
         (setq gridx 112.5)
         (setq jointx -10.0)
       )
       ((= "Plus" ansx)
         (setq gridx 112.5)
         (setq jointx 10.0)
       )
       ((= "Custom" ansx)
         (setq gridx (getreal "\nCustom size: "))
         (setq jointx 0.0)
       )
     )
     (if gridx (setq pt2 (ModularizePoint pt2 pt1 gridx jointx)))
     (command "_.stretch" ss "" "_non" pt1 "_non" (list (car pt2) (cadr pt1)))
     (princ
       (strcat
         "\nModular dimension: " (if gridx "ON " "OFF ")
         "\nStretched on X: " (rtos (- (car pt2) (car pt1))) " "
       )
     )
     (setvar 'cmdecho 1)
   )
 )
 (vla-endundomark doc)
 (princ)
)

3dwannab · 发表于 2022-7-5 17:28:56

谢谢太好了，这是朝着正确方向迈出的一步。

当它在负X轴上拉伸时会出现问题。请参阅附图以查看问题。

大体上在X正方向拉伸有效，但在负方向拉伸与预期结果相反。如果我选择+10mm选项，则为-10mm，如果为-10mm，则为+10mm接头。

是否有任何可能的方法来选择关节类型，然后拉伸捕捉到增量？如果没有，也没问题。这样可以更容易地看到拉伸的最终位置。
砖拉伸问题。图纸

Roy_043 · 发表于 2022-7-5 17:34:17

捕捉到增量是有问题的。如果关节不为零，则需要根据拉伸方向更改snapbase。下面的代码显示网格（不考虑关节）。

copy

(vl-load-com)
; Round half towards pos. or neg. infinity.
(defun Round (num)
 (fix ((if (minusp num) - +) num 0.5))
)
; Recalculate pt so that the X, Y and Z distance to base are n times module plus joint.
(defun ModularizePoint (pt base module joint)
 (mapcar
   '(lambda (coordPt coordBase / delta)
     (setq delta (* module (Round (/ (- coordPt coordBase) (float module)))))
     (cond
       ((zerop delta)  coordBase)
       ((minusp delta) (+ coordBase delta (- joint)))
       (T              (+ coordBase delta joint))
     )
   )
   pt
   base
 )
)
(defun SetVars (lst)
 (mapcar
   '(lambda (sub / old)
     (setq old (getvar (car sub)))
     (if (cadr sub) (setvar (car sub) (cadr sub)))
     (list (car sub) old)
   )
   lst
 )
)
(defun c:bsx (/ *error* doc ansx gridx jointx pt1 pt2 ss vars)
 (defun *error* (msg)
   (if vars (SetVars vars))
   (vla-endundomark doc)
   (if (not (wcmatch (strcase msg) "*CANCEL*,*EXIT*"))
     (princ (strcat "\n<< Error: " msg " >>"))
   )
   (princ)
 )
 (setq doc (vla-get-activedocument (setq cad (vlax-get-acad-object))))
 (vla-endundomark doc)
 (vla-startundomark doc)
 (if
   (and
     (princ "\nSelect entities to stretch by crossing-window or crossing-polygon: ")
     (setq ss (ssget))
     (progn
       (initget "Stand Minus Plus Custom None")
       (setq ansx (getkword "\nX Brick Size (Standard=112.5 Joint=10)? [stand/stand Minus joint/stand Plus joint/Custom/None] <Stand>: "))
       (cond
         ((or (not ansx) (= "Stand" ansx))
           (setq gridx 112.5)
           (setq jointx 0.0)
         )
         ((= "Minus" ansx)
           (setq gridx 112.5)
           (setq jointx -10.0)
         )
         ((= "Plus" ansx)
           (setq gridx 112.5)
           (setq jointx 10.0)
         )
         ((= "Custom" ansx)
           (setq gridx (getreal "\nCustom size: "))
           (setq jointx 0.0)
         )
       )
       T
     )
     (setq pt1 (getpoint "\nSelect Base Point: "))
     (setq vars
       (SetVars
         (if (= "None" ansx)
           '((cmdecho 0))
           (list
             '(cmdecho 0)
             (list 'snapbase pt1)
             '(griddisplay 1)
             '(gridmode 1)
             (list 'gridunit (list gridx gridx))
           )
         )
       )
     )
     (setq pt2 (getpoint pt1 "\nSelect Second Point: "))
   )
   (progn
     (if gridx (setq pt2 (ModularizePoint pt2 pt1 gridx jointx)))
     (command "_.stretch" ss "" "_non" pt1 "_non" (list (car pt2) (cadr pt1)))
     (princ
       (strcat
         "\nModular dimension: " (if gridx "ON " "OFF ")
         "\nStretched on X: " (rtos (- (car pt2) (car pt1))) " "
       )
     )
   )
 )
 (if vars (SetVars vars))
 (vla-endundomark doc)
 (princ)
)

3dwannab · 发表于 2022-7-5 17:34:47

我现在不在AutoCAD，但在周末，我痛苦地试图让你的代码正常工作。

我试图将网格设置为共测量，如果选择了任何砖块选项，则拉伸将遵循该选项，并根据命令开始时选择的值，然后将拉伸减去或添加10mm。

初始网格不一定要考虑关节，因为它只是一个粗略的引导，但最终拉伸将。

3dwannab · 发表于 2022-7-5 17:39:25

出现错误：

copy

Select Base Point:
<< Error: AutoCAD variable setting rejected: SNAPBASE (452.5 4278.5 0.0) >>

如果它能像17号岗位那样工作。我不介意扣子是否与砖层的选择不符。

看见http://www.cadtutor.net/forum/showthread.php?99652-X轴拉伸-带-choosen-value-in-they-increments&p=678648&viewfull=1#post678648

Grrr · 发表于 2022-7-5 17:41:48

Snapbase需要二维点：
替换：

copy

(list 'snapbase pt1)

使用：

copy

(list 'snapbase (reverse (cdr (reverse pt1))))

copy

[s](list 'snapbase (vl-remove (last pt1) pt1))[/s]

copy


_$ (setq pt (getpoint))
(0.0 0.0 0.0)
_$ (vl-remove (last pt) pt)
nil
_$

Roy_043 · 发表于 2022-7-5 17:44:46

谢谢Grrr。BricsCAD在此处接受三维点：

copy

: (setvar 'snapbase '(1 2 3))
(1 2 3)
: (getvar 'snapbase)
(1.0 2.0)

[编程交流] 使用choosen在X轴上拉伸

发表回复

精选推荐