Compose entities-blocks in a w

sadhu · 发表于 2022-7-6 12:04:31

Actually I was trying with this :

(and (setq Pts (acet-ss-drag-move (ssadd blk) Pt1 "\nSpecify Second Point: " t 0))    (not (vla-move (vlax-ename->vla-object blk)              (vlax-3D-point Pts)              (vlax-3D-point Pt2)))    (setq Rot (acet-ss-drag-rotate (ssadd blk) Pt2 "Specify angle: " T 0))    (vla-put-rotation (vlax-ename->vla-object blk) Rot))

but didn't get any result. Infact "blk" returned nil. I was hoping to get the last block inserted. Each block is created (composed) and inserted one at a time.

Lee Mac · 发表于 2022-7-6 12:07:51

That's because 'blk' is the block definition as found in the Document Block table, not the reference object.

I'll post an example in a bit

Lee Mac · 发表于 2022-7-6 12:11:14

copy

(defun c:BoxObj (/ *error*                  BENT BLK BOBJ DEL ENT FLOOR I LAY MA MI NNUM NUM                  OBJLST OFFSET P1 P2 PTS R SPC SS THGT UFLAG)  (vl-load-com) ;; Lee Mac  ~  11.02.10 (setq lay "My Boxing Layer" ;; Layer       offset 5.  ;; Offset       thgt 2.5   ;; Text Height       del  t     ;; Delete Original Objects )  (defun *error* (msg)   (and uFlag (vla-EndUndomark *doc))   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")       (princ (strcat "\n** Error: " msg " **")))   (princ)) (setq *doc (cond (*doc) ((vla-get-ActiveDocument                            (vlax-get-acad-object))))       spc  (if (or (eq AcModelSpace (vla-get-ActiveSpace *doc))                    (eq :vlax-true   (vla-get-MSpace *doc)))              (vla-get-ModelSpace *doc)              (vla-get-PaperSpace *doc)))  (if (setq ss (ssget))   (progn     (setq uFlag (not (vla-StartUndoMark *doc)))     (or (tblsearch "LAYER" lay)         (vla-add (vla-get-Layers *doc) lay))          (vlax-for obj (setq ss (vla-get-ActiveSelectionSet *doc))       (setq Objlst (cons obj Objlst))       (vla-getBoundingbox obj 'Mi 'Ma)       (setq pts (cons (vlax-safearray->list Mi)                       (cons (vlax-safearray->list Ma) pts))))     (vla-delete ss)          (setq Mi (apply (function mapcar) (cons 'min pts))           Ma (apply (function mapcar) (cons 'max pts)))          (setq Blk (vlax-invoke (vla-get-Blocks *doc) 'Add (list (- (car Mi) offset)                                                             (- (cadr Mi) Offset) 0.) "*U"))     (vla-copyObjects *doc       (vlax-make-variant         (vlax-safearray-fill           (vlax-make-safearray vlax-vbObject             (cons 0  (1- (length ObjLst))))           ObjLst))       Blk)          (vla-put-closed       (vlax-invoke blk 'AddLightWeightPolyline         (list (- (car Mi) offset)               (- (cadr Mi) Offset)               (- (car Mi) offset)               (+ (cadr Ma) offset)               (+ (car Ma) offset)               (+ (cadr Ma) offset)               (+ (car Ma) offset)               (- (cadr Mi) offset)))  :vlax-true)          (setq num       (if (setq i -1 floor 1 ss (ssget "_X" (list (cons 0 "INSERT") (cons 8 lay) (cons 66 1))))         (progn           (while (setq ent (ssname ss (setq i (1+ i))))             (if (< floor (setq nNum (atoi (cdr (assoc 1 (entget (entnext ent)))))))               (setq floor nNum)))           (itoa (1+ floor))) "1"))          (vlax-invoke blk 'AddAttribute thgt acAttributeModePreset "num"       (list (/ (+ (car Mi) (car Ma)) 2.)             (- (cadr Mi) (+ Offset tHgt)) 0.) "num" num)          (vla-put-layer       (setq bObj         (vlax-invoke spc 'InsertBlock (setq p1 (list (- (car Mi)  offset)                                                      (- (cadr Mi) Offset) 0.))           (vla-get-Name blk) 1. 1. 1. 0.))       lay)          (if Del (mapcar (function vla-delete) ObjLst))     (and (setq p2 (acet-ss-drag-move                     (ssadd (setq bEnt (vlax-vla-object->ename bObj)))                     p1 "\nSpecify Second Point: " t 0))                    (not (vla-move bObj (vlax-3D-point p1) (vlax-3D-point p2)))          (setq r  (acet-ss-drag-rotate (ssadd bEnt) p2 "\nSpecify Angle: " t 0))          (vla-put-rotation bObj r))                                    (setq uFlag (vla-EndUndoMark *doc))))       (princ))

sadhu · 发表于 2022-7-6 12:15:25

Just tried it. Thanks. It works.

You are indeed a luminous being.

Lee Mac · 发表于 2022-7-6 12:21:00

Thanks Sadhu,

With a Scale option also:

copy

(defun c:BoxObj (/ *error*                  BENT BLK BOBJ DEL ENT FLOOR I LAY MA MI NNUM NUM                  OBJLST OFFSET P1 P2 PTS R SPC SS THGT UFLAG)  (vl-load-com) ;; Lee Mac  ~  11.02.10 (setq lay "My Boxing Layer" ;; Layer       offset 5.  ;; Offset       thgt 2.5   ;; Text Height       del  t     ;; Delete Original Objects )  (defun *error* (msg)   (and uFlag (vla-EndUndomark *doc))   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")       (princ (strcat "\n** Error: " msg " **")))   (princ)) (setq *doc (cond (*doc) ((vla-get-ActiveDocument                            (vlax-get-acad-object))))       spc  (if (or (eq AcModelSpace (vla-get-ActiveSpace *doc))                    (eq :vlax-true   (vla-get-MSpace *doc)))              (vla-get-ModelSpace *doc)              (vla-get-PaperSpace *doc)))  (if (setq ss (ssget))   (progn     (setq uFlag (not (vla-StartUndoMark *doc)))     (or (tblsearch "LAYER" lay)         (vla-add (vla-get-Layers *doc) lay))          (vlax-for obj (setq ss (vla-get-ActiveSelectionSet *doc))       (setq Objlst (cons obj Objlst))       (vla-getBoundingbox obj 'Mi 'Ma)       (setq pts (cons (vlax-safearray->list Mi)                       (cons (vlax-safearray->list Ma) pts))))     (vla-delete ss)          (setq Mi (apply (function mapcar) (cons 'min pts))           Ma (apply (function mapcar) (cons 'max pts)))          (setq Blk (vlax-invoke (vla-get-Blocks *doc) 'Add (list (- (car Mi) offset)                                                             (- (cadr Mi) Offset) 0.) "*U"))     (vla-copyObjects *doc       (vlax-make-variant         (vlax-safearray-fill           (vlax-make-safearray vlax-vbObject             (cons 0  (1- (length ObjLst))))           ObjLst))       Blk)          (vla-put-closed       (vlax-invoke blk 'AddLightWeightPolyline         (list (- (car Mi) offset)               (- (cadr Mi) Offset)               (- (car Mi) offset)               (+ (cadr Ma) offset)               (+ (car Ma) offset)               (+ (cadr Ma) offset)               (+ (car Ma) offset)               (- (cadr Mi) offset)))  :vlax-true)          (setq num       (if (setq i -1 floor 1 ss (ssget "_X" (list (cons 0 "INSERT") (cons 8 lay) (cons 66 1))))         (progn           (while (setq ent (ssname ss (setq i (1+ i))))             (if (< floor (setq nNum (atoi (cdr (assoc 1 (entget (entnext ent)))))))               (setq floor nNum)))           (itoa (1+ floor))) "1"))          (vlax-invoke blk 'AddAttribute thgt acAttributeModePreset "num"       (list (/ (+ (car Mi) (car Ma)) 2.)             (- (cadr Mi) (+ Offset tHgt)) 0.) "num" num)          (vla-put-layer       (setq bObj         (vlax-invoke spc 'InsertBlock (setq p1 (list (- (car Mi)  offset)                                                      (- (cadr Mi) Offset) 0.))           (vla-get-Name blk) 1. 1. 1. 0.))       lay)          (if Del (mapcar (function vla-delete) ObjLst))     (and (setq p2 (acet-ss-drag-move                     (ssadd (setq bEnt (vlax-vla-object->ename bObj)))                     p1 "\nSpecify Second Point: " t 0))                    (not (vla-move bObj (vlax-3D-point p1) (vlax-3D-point p2)))          (setq s  (acet-ss-drag-scale  (ssadd bEnt) p2 "\nSpecify Scale: " t 0))          (mapcar            (function              (lambda (prop)                (vlax-put-property bObj (read (strcat prop "ScaleFactor")) s))) '("X" "Y" "Z"))          (setq r  (acet-ss-drag-rotate (ssadd bEnt) p2 "\nSpecify Angle: " t 0))          (vla-put-rotation bObj r))                                    (setq uFlag (vla-EndUndoMark *doc))))       (princ))

sadhu · 发表于 2022-7-6 12:24:22

Thanks. This is too good.

Is it possible to put the scale option as the last action ?

Thanks again.

Lee Mac · 发表于 2022-7-6 12:25:16

Certainly, just swicth the segments of code around

copy

(defun c:BoxObj (/ *error*                  BENT BLK BOBJ DEL ENT FLOOR I LAY MA MI NNUM NUM                  OBJLST OFFSET P1 P2 PTS R SPC SS THGT UFLAG)  (vl-load-com) ;; Lee Mac  ~  11.02.10 (setq lay "My Boxing Layer" ;; Layer       offset 5.  ;; Offset       thgt 2.5   ;; Text Height       del  t     ;; Delete Original Objects )  (defun *error* (msg)   (and uFlag (vla-EndUndomark *doc))   (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")       (princ (strcat "\n** Error: " msg " **")))   (princ)) (setq *doc (cond (*doc) ((vla-get-ActiveDocument                            (vlax-get-acad-object))))       spc  (if (or (eq AcModelSpace (vla-get-ActiveSpace *doc))                    (eq :vlax-true   (vla-get-MSpace *doc)))              (vla-get-ModelSpace *doc)              (vla-get-PaperSpace *doc)))  (if (setq ss (ssget))   (progn     (setq uFlag (not (vla-StartUndoMark *doc)))     (or (tblsearch "LAYER" lay)         (vla-add (vla-get-Layers *doc) lay))          (vlax-for obj (setq ss (vla-get-ActiveSelectionSet *doc))       (setq Objlst (cons obj Objlst))       (vla-getBoundingbox obj 'Mi 'Ma)       (setq pts (cons (vlax-safearray->list Mi)                       (cons (vlax-safearray->list Ma) pts))))     (vla-delete ss)          (setq Mi (apply (function mapcar) (cons 'min pts))           Ma (apply (function mapcar) (cons 'max pts)))          (setq Blk (vlax-invoke (vla-get-Blocks *doc) 'Add (list (- (car Mi) offset)                                                             (- (cadr Mi) Offset) 0.) "*U"))     (vla-copyObjects *doc       (vlax-make-variant         (vlax-safearray-fill           (vlax-make-safearray vlax-vbObject             (cons 0  (1- (length ObjLst))))           ObjLst))       Blk)          (vla-put-closed       (vlax-invoke blk 'AddLightWeightPolyline         (list (- (car Mi) offset)               (- (cadr Mi) Offset)               (- (car Mi) offset)               (+ (cadr Ma) offset)               (+ (car Ma) offset)               (+ (cadr Ma) offset)               (+ (car Ma) offset)               (- (cadr Mi) offset)))  :vlax-true)          (setq num       (if (setq i -1 floor 1 ss (ssget "_X" (list (cons 0 "INSERT") (cons 8 lay) (cons 66 1))))         (progn           (while (setq ent (ssname ss (setq i (1+ i))))             (if (< floor (setq nNum (atoi (cdr (assoc 1 (entget (entnext ent)))))))               (setq floor nNum)))           (itoa (1+ floor))) "1"))          (vlax-invoke blk 'AddAttribute thgt acAttributeModePreset "num"       (list (/ (+ (car Mi) (car Ma)) 2.)             (- (cadr Mi) (+ Offset tHgt)) 0.) "num" num)          (vla-put-layer       (setq bObj         (vlax-invoke spc 'InsertBlock (setq p1 (list (- (car Mi)  offset)                                                      (- (cadr Mi) Offset) 0.))           (vla-get-Name blk) 1. 1. 1. 0.))       lay)          (if Del (mapcar (function vla-delete) ObjLst))     (and (setq p2 (acet-ss-drag-move                     (ssadd (setq bEnt (vlax-vla-object->ename bObj)))                     p1 "\nSpecify Second Point: " t 0))                    (not (vla-move bObj (vlax-3D-point p1) (vlax-3D-point p2)))          (setq r  (acet-ss-drag-rotate (ssadd bEnt) p2 "\nSpecify Angle: " t 0))          (vla-put-rotation bObj r)          (setq s  (acet-ss-drag-scale  (ssadd bEnt) p2 "\nSpecify Scale: " t 0))          (mapcar            (function              (lambda (prop)                (vlax-put-property bObj (read (strcat prop "ScaleFactor")) s))) '("X" "Y" "Z")))                                    (setq uFlag (vla-EndUndoMark *doc))))       (princ))

sadhu · 发表于 2022-7-6 12:29:32

Thanks, Lee. You are great.

(just forgot to post a reply earlier)

[编程交流] Compose entities-blocks in a w

发表回复

精选推荐