社区 › Auto Lisp › 需要autolisp

git_thailand 发表于 2022-7-6 08:52:08

需要autolisp

需要：在多行中设置2层

Lt Dan's l 发表于 2022-7-6 08:58:45

很快完成。。
 
我对此不满意

(defun c:test ( / addpolyline *error* pt p2 pts e _offset1 _offset2 _layer1 _layer2 )
;|v set offset and layers here v|;
(setq _offset1 2.)
(setq _layer1 "0")

(setq _offset2 (+ _offset1 0.5))
(setq _layer2 "Defpoints")

;|^ set offset and layers here ^|;
(vl-load-com)
(defun addpolyline ( pointslst layer closed flag / e )
   (setq e
   (entmakex
       (append
         (list
         (cons 0 "LWPOLYLINE")
         (cons 100 "AcDbEntity")
         (cons 100 "AcDbPolyline")
         (cons 90 (length pointslst))
         (cons 70 (if closed 1 0))
         (cons 8 layer)
         (cons 43 0.0)
         )
         (mapcar
         (function
             (lambda ( x )
               (if (listp x)(cons 10 x)
               (cons 42 x)
               )
             )
         ) pointslst
         )
       )
   )
   )
   (if (and e flag)
   (vlax-ename->vla-object e) e
   )
)
(defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
      (princ (strcat "\n** Error: " msg " **"))
   )
   (princ)
)

(if
   (and (setq pt (getpoint "\nSpecify starting point: "))
   (setq pts (cons pt pts))
   )
   (while (setq p2 (getpoint pt "\nSpecify next point: "))
   (and e (mapcar (function vla-delete) e))
   (
       (lambda ( p )
         (setq e
         (apply (function append)
             (mapcar
               (function
               (lambda ( x y / o )
                   (setq o (vlax-invoke p 'Offset y))
                   (vla-put-layer (car o) _layer2)
                   (append (vlax-invoke p 'Offset x) o)
               )
               ) (list _offset1 (- _offset1))
               (list _offset2 (- _offset2))
             )
         )
         ) (vla-delete p)
       )
       (addpolyline (setq pts (cons (setq pt p2) pts))
         _layer1 nil t
       )
   )
   )
)
)

git_thailand 发表于 2022-7-6 09:04:27

谢谢你，但我希望函数能证明到底部、顶部和零

Lt Dan's l 发表于 2022-7-6 09:13:27

有几分钟。。
 

(defun c:test ( / addpolyline *error* p pt p2 pts e _offset1 _offset2 _layer1 _layer2 )
;|v set offset and layers here v|;
(setq _offset1 2.)
(setq _layer1 "0")
(setq _offset20.5)
(setq _layer2 "Defpoints")
;|^ set offset and layers here ^|;
(vl-load-com)
(defun addpolyline ( pointslst layer closed flag / e )
   (setq e
   (entmakex
       (append
         (list
         (cons 0 "LWPOLYLINE")
         (cons 100 "AcDbEntity")
         (cons 100 "AcDbPolyline")
         (cons 90 (length pointslst))
         (cons 70 (if closed 1 0))
         (cons 8 layer)
         (cons 43 0.0)
         )
         (mapcar
         (function
             (lambda ( x )
               (if (listp x)(cons 10 x)
               (cons 42 x)
               )
             )
         ) pointslst
         )
       )
   )
   )
   (if (and e flag)
   (vlax-ename->vla-object e) e
   )
)
(defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
      (princ (strcat "\n** Error: " msg " **"))
   )
   (princ)
)
(and (not *testcommandjustification*)
   (setq *testcommandjustification* "Center")
)
(while
   (and
   (not pt)
   (not
       (prompt
         (strcat "\n\n** Current Justification: " *testcommandjustification* " **")
       )
   )
   (not (initget 1 "Justification"))
   (setq pt (getpoint "\nSpecify starting point or : "))
   )
   (cond ( (listp pt) (setq pts (cons pt pts)) )
   (t (initget 1 "Top Bottom Center")
       (setq *testcommandjustification*
         (getkword "\nSpecify justification : ")
         pt nil
       )
   )
   )
)
(while (and pts (setq p2 (getpoint pt "\nSpecify next point: ")))
   (and e (mapcar (function vla-delete) e))
   (
   (lambda ( p )
       (cond
         ( (eq *testcommandjustification* "Center")
         (setq e
             (apply (function append)
               (mapcar
               (function
                   (lambda ( x y / o )
                     (setq o (vlax-invoke p 'Offset y))
                     (vla-put-layer (car o) _layer2)
                     (append (vlax-invoke p 'Offset x) o)
                   )
               ) (list (* 0.5 _offset1) (- (* 0.5 _offset1)))
                   (list (+ (* 0.5 _offset1) _offset2)
                     (- (+ (* 0.5 _offset1) _offset2))
                   )
               )
             )
         ) (vla-delete p)
         )
         ( (eq *testcommandjustification* "Bottom")
         (setq e
             (append (list p)
               (mapcar
               (function
                   (lambda ( o la )
                     (setq p
                     (car
                         (vlax-invoke p 'offset o)
                     )
                     )
                     (vla-put-layer p la) p
                   )
               )
               (list _offset2 _offset1 _offset2)
               (list _layer1 _layer1 _layer2)
               )
             )
         )
         )
         ( (eq *testcommandjustification* "Top")
         (setq e
             (append (list p)
               (mapcar
               (function
                   (lambda ( o la )
                     (setq p
                     (car
                         (vlax-invoke p 'offset o)
                     )
                     )
                     (vla-put-layer p la) p
                   )
               )
               (list (- _offset2)(- _offset1)(- _offset2))
               (list _layer1 _layer1 _layer2)
               )
             )
         )
         )
       )
   )
   (addpolyline (setq pts (cons (setq pt p2) pts))
       (if (eq *testcommandjustification* "Center") _layer1 _layer2) nil t
   )
   )
) (princ)
)

git_thailand 发表于 2022-7-6 09:15:08

非常感谢。非常酷的lisp，请在内线（层“0”）之间插入自动填充功能

Lt Dan's l 发表于 2022-7-6 09:22:22

我明天会解决这个问题。

Lt Dan's l 发表于 2022-7-6 09:29:49

如果这对你有效，请告诉我
 
这个Lisp程序看起来很可怕！

(defun c:test ( / pairpts addpolyline *error* ad as p pt p2 pts e _offset1 _offset2 _layer1 _layer2 o3 ph h )
;|v set offset and layers here v|;
(setq _offset1 2.)
(setq _layer1 "0")
(setq _offset20.5)
(setq _layer2 "Defpoints")
(setq _hatch "ansi31")
(setq _hatchscale 1.)
(setq _hatchangle (* pi 0.75))
;|^ set offset and layers here ^|;
(vl-load-com)
   (defun pairpts ( _list / l pt )
   (foreach x (reverse _list)
   (if pt
       (setq l (cons (cons x pt) l) pt nil)
       (setq pt (cons x pt))
   )
   ) l
)
(defun addpolyline ( pointslst layer closed flag / e )
   (setq e
   (entmakex
       (append
         (list
         (cons 0 "LWPOLYLINE")
         (cons 100 "AcDbEntity")
         (cons 100 "AcDbPolyline")
         (cons 90 (length pointslst))
         (cons 70 (if closed 1 0))
         (cons 8 layer)
         (cons 43 0.0)
         )
         (mapcar
         (function
             (lambda ( x )
               (if (listp x)(cons 10 x)
               (cons 42 x)
               )
             )
         ) pointslst
         )
       )
   )
   )
   (if (and e flag)
   (vlax-ename->vla-object e) e
   )
)
(defun *error* ( msg )
   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
      (princ (strcat "\n** Error: " msg " **"))
   )
   (princ)
)
(defun ad nil
   (setq *acdoc*
   (cond( *acdoc* )
       ( (vlax-get (vlax-get-acad-object)
         'ActiveDocument
         )
       )
   )
   )
)
(defun as nil (ad)
   (cond
   ( (eq AcModelSpace (vlax-get *acdoc* 'ActiveSpace))
       (vlax-get *acdoc* 'ModelSpace)
   )
   ( (vlax-get *acdoc* 'PaperSpace) )
   )
)
(and (not *testcommandjustification*)
   (setq *testcommandjustification* "Center")
)
(while
   (and
   (not pt)
   (not
       (prompt
         (strcat "\n\n** Current Justification: " *testcommandjustification* " **")
       )
   )
   (not (initget 1 "Justification"))
   (setq pt (getpoint "\nSpecify starting point or : "))
   )
   (cond ( (listp pt) (setq pts (cons pt pts)) )
   (t (initget 1 "Top Bottom Center")
       (setq *testcommandjustification*
         (getkword "\nSpecify justification : ")
         pt nil
       )
   )
   )
)
(while (and pts (setq p2 (getpoint pt "\nSpecify next point: ")))
   (and e (mapcar (function vla-delete) e))
   (
   (lambda ( p )
       (cond
         ( (eq *testcommandjustification* "Center")
         (setq e
             (apply (function append)
               (mapcar
               (function
                   (lambda ( x y / o )
                     (setq o (vlax-invoke p 'Offset y))
                     (vla-put-layer (car o) _layer2)
                     (setq o3
                     (cons
                         (car
                           (vlax-invoke p 'Offset x)
                         ) o3
                     )
                     ) o
                   )
               ) (list (* 0.5 _offset1) (- (* 0.5 _offset1)))
                   (list (+ (* 0.5 _offset1) _offset2)
                     (- (+ (* 0.5 _offset1) _offset2))
                   )
               )
             )
         ) (vla-delete p)
         )
         ( (eq *testcommandjustification* "Bottom")
         (setq e
             (append (list p)
               (vl-remove-if (function not)
               (mapcar
                   (function
                     (lambda ( o la )
                     (setq p
                         (car
                           (vlax-invoke p 'offset o)
                         )
                     )
                     (vla-put-layer p la)
                     (if (eq la _layer1)
                         (progn (setq o3(cons p o3)) nil)
                         p
                     )
                     )
                   )
                   (list _offset2 _offset1 _offset2)
                   (list _layer1 _layer1 _layer2)
               )
               )
             )
         )
         )
         ( (eq *testcommandjustification* "Top")
         (setq e
             (append (list p)
               (vl-remove-if (function not)
               (mapcar
                   (function
                     (lambda ( o la )
                     (setq p
                         (car
                           (vlax-invoke p 'offset o)
                         )
                     )
                     (vla-put-layer p la)
                     (if (eq la _layer1)
                         (progn (setq o3(cons p o3)) nil)
                         p
                     )
                     )
                   )
                   (list (- _offset2)(- _offset1)(- _offset2))
                   (list _layer1 _layer1 _layer2)
               )
               )
             )
         )
         )
       )
       (setq e
         (cons
         (setq ph
             (addpolyline
               (append
               (pairpts (vlax-get (car o3) 'Coordinates))
               (reverse (pairpts (vlax-get (cadr o3) 'Coordinates)))
               ) _layer1 t t
             )
         ) e
         )
       )(mapcar (function vla-delete) o3)
       (setq o3 nil)
       (setq h
         (vla-addhatch (as)
         acHatchPatternTypePredefined _hatch :vlax-true
         )
       )
       (vlax-invoke h 'AppendOuterLoop (list ph))
       (vlax-invoke h 'Evaluate)
       (vla-put-patternscale h _hatchscale)
       (vla-put-patternangle h _hatchangle)
       (vla-put-layer h _layer1)
       (setq e (cons h e))
   )
   (addpolyline (setq pts (cons (setq pt p2) pts))
       (if (eq *testcommandjustification* "Center") _layer1 _layer2) nil t
   )
   )
) (vla-regen (ad) acactiveviewport) (princ)
)

git_thailand 发表于 2022-7-6 09:34:32

对它的工作设置层，请设置图案填充角度135度。非常感谢。

Lt Dan's l 发表于 2022-7-6 09:38:11

以上代码已更新

git_thailand 发表于 2022-7-6 09:45:56

非常感谢你，伙计

查看完整版本: 需要autolisp