Lsp on creating Blocks from drawn Polyline

Once again, i am posting for help on a lsp that could help me reduce my CAD processing time and mistakes.

Situation:

I have to enlarge or shrink the size of the "polyline" dimension in the drawing provided by my customer. These polylines are mostly "rectangle" or "square".

As they are not in block forms, i have to manually edited them to my desire dimensions. This has taken me time and i have even enlarged them to wrong size before.

Question:

Is it possible to convert the same dimension of "rectangle" or "square" into block forms using an lsp script?

It will be good if the different block can be separated into different layers. (The name of the layers is not important)

Will this script be too hard to construct?

I have attached a sample of the drawing. (Only 3 types to be converted)

I would appreciate if any expert can advice me on this questions.

Thank you!:wink:

Carl

Example.zip

Try it

SetNB - convert selected entities to block

SetNB1 - convert each selected primitive in a separate named block

(defun c:setnb (/ ss adoc pt_lst center blk *error* bi bname bpat)
;;;Selected Entities To Named Block
 (setq bpat "BLOCK-") ;_ <- Edit block name pattern here
 (defun *error* (msg)
   (vla-endundomark adoc)
   (princ msg)
   (princ)
   ) ;_ end of defun
 (vl-load-com)
 (vla-startundomark
   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of vla-StartUndoMark
 (if (not (vl-catch-all-error-p
            (vl-catch-all-apply '(lambda () (setq ss (ssget "_:L"))))
            ) ;_ end of vl-catch-all-error-p
          ) ;_ end of not
   (progn
     (setq
       ss     (mapcar 'vlax-ename->vla-object
                      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                      ) ;_ end of mapcar
       pt_lst (apply 'append
                     (mapcar
                       '(lambda (x / minp maxp)
                          (vla-getboundingbox x 'minp 'maxp)
                          (list (vlax-safearray->list minp)
                                (vlax-safearray->list maxp)
                                ) ;_ end of append
                          ) ;_ end of lambda
                       ss
                       ) ;_ end of mapcar
                     ) ;_ end of append
       center (mapcar '(lambda (a b) (/ (+ a b) 2.))
                      (list (apply 'min (mapcar 'car pt_lst))
                            (apply 'min (mapcar 'cadr pt_lst))
                            (apply 'min (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      (list (apply 'max (mapcar 'car pt_lst))
                            (apply 'max (mapcar 'cadr pt_lst))
                            (apply 'max (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      ) ;_ end of mapcar
       bname
       (progn
         (setq bi 0)
         (while (tblsearch "BLOCK" (setq bname (strcat bpat (itoa(setq bi(1+ bi)))))))
            bname)
       blk    (vla-add (vla-get-blocks adoc)
                       (vlax-3d-point center)
                       bname
                       ) ;_ end of vla-add
       ) ;_ end of setq
     (vla-copyobjects
       adoc
       (vlax-make-variant
         (vlax-safearray-fill
           (vlax-make-safearray vlax-vbobject (cons 0 (1- (length ss))))
           ss
           ) ;_ end of vlax-safearray-fill
         ) ;_ end of vlax-make-variant
       blk
       ) ;_ end of vla-copyobjects
     (vla-insertblock
       (vla-objectidtoobject adoc (vla-get-ownerid (car ss)))
       (vlax-3d-point center)
       (vla-get-name blk)
       1.0
       1.0
       1.0
       0.0
       ) ;_ end of vla-insertblock
     (mapcar 'vla-erase ss)
     ) ;_ end of and
   ) ;_ end of if
 (vla-endundomark adoc)
 (princ)
 ) ;_ end of defun

(defun c:SETNB1 (/ ss adoc pt_lst center blk *error* lst bpat bname bi)
 ;;;Each primitive in a separate named block
 ;;;Каждый примитив в отдельный Имсенованный блок
 (defun *error* (msg)
   (vla-endundomark adoc)
   (princ msg)
   (princ)
   ) ;_ end of defun
 (setq bpat "BLOCK-") ;_ <- Edit block name pattern here
 (vl-load-com)
 (vla-startundomark
   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of vla-StartUndoMark
 (if (not (vl-catch-all-error-p
            (vl-catch-all-apply '(lambda () (setq ss (ssget "_:L"))))
            ) ;_ end of vl-catch-all-error-p
          ) ;_ end of not
   (progn
     (mapcar '(lambda(item)
     (setq
ss (list item)
       pt_lst (apply 'append
                     (mapcar
                       '(lambda (x / minp maxp)
                          (vla-getboundingbox x 'minp 'maxp)
                          (list (vlax-safearray->list minp)
                                (vlax-safearray->list maxp)
                                ) ;_ end of append
                          ) ;_ end of lambda
                       ss
                       ) ;_ end of mapcar
                     ) ;_ end of append
       center (mapcar '(lambda (a b) (/ (+ a b) 2.))
                      (list (apply 'min (mapcar 'car pt_lst))
                            (apply 'min (mapcar 'cadr pt_lst))
                            (apply 'min (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      (list (apply 'max (mapcar 'car pt_lst))
                            (apply 'max (mapcar 'cadr pt_lst))
                            (apply 'max (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      ) ;_ end of mapcar
       bname
       (progn
         (setq bi 0)
         (while (tblsearch "BLOCK" (setq bname (strcat bpat (itoa(setq bi(1+ bi)))))))
            bname)
       blk    (vla-add (vla-get-blocks adoc)
                       (vlax-3d-point center)
                       bname
                       ) ;_ end of vla-add
       ) ;_ end of setq
     (vla-copyobjects
       adoc
       (vlax-make-variant
         (vlax-safearray-fill
           (vlax-make-safearray vlax-vbobject (cons 0 (1- (length ss))))
           ss
           ) ;_ end of vlax-safearray-fill
         ) ;_ end of vlax-make-variant
       blk
       ) ;_ end of vla-copyobjects
     (vla-insertblock
       (vla-objectidtoobject adoc (vla-get-ownerid (car ss)))
       (vlax-3d-point center)
       (vla-get-name blk)
       1.0
       1.0
       1.0
       0.0
       ) ;_ end of vla-insertblock
	 )
  (setq
       lst     (mapcar 'vlax-ename->vla-object
                      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                      ) ;_ end of mapcar
)
      )
     
     (mapcar 'vla-erase lst)
     ) ;_ end of and
   ) ;_ end of if
 (vla-endundomark adoc)
 (princ)
 )

Hello VVA,

Thank you so much for your LSP!

May i request for one more function?

The "SetNB1" work exactly what i wanted.

But is it possible to convert my selected primitive to the same block name?

Definitely, i will ensure that the shapes selected will be the same.

Sorry if i explain badly.

Hope you understand what i related.

Will be excited on your reply.

Thanks!

Carl

Another way: to scale the selected objects on their center (BoundingBox)

(defun c:sm (/ ERRCOUNT MAXPT MINPT MIPT MNPT MXPT 
         OBJSET PTLST XLST YLST old Flg) 
(vl-load-com) 
 (if(not sm:scale)(setq sm:scale 1)) 
   (initget 6)    
   (setq old sm:scale 
         sm:scale(getdist 
        (strcat"\nSpecify the scale factor <"(rtos sm:scale 2 2)">: ")) 
  ); end setq 
 (if(null sm:scale)(setq sm:scale old)) 
 (setq errCount 0 ptLst 'nil Flg t); en setq 
 (while Flg 
   (princ "\n§§§ Select objects and press Enter or Esc to exit. §§§") 
(if 
  (not(setq objSet(ssget "_I"))) 
  (setq objSet(ssget)) 
  ); end if 
 (if objSet 
   (progn 
     (setq objSet 
      (mapcar 'vlax-ename->vla-object 
                   (vl-remove-if 'listp 
                    (mapcar 'cadr(ssnamex objSet))))) 
     (foreach obj objSet 
  (vla-GetBoundingBox obj 'MinPt 'MaxPt) 
   (setq mnPt(vlax-safearray->list MinPt) 
    mxPt(vlax-safearray->list MaxPt) 
    miPt (polar mnPt (angle mnPt mxPt)(* 0.5 (distance mnPt mxPt)))      
    )
    (if (vlax-method-applicable-p obj 'ScaleEntity)
    (if 
     (vl-catch-all-error-p 
  (vl-catch-all-apply 'vla-ScaleEntity 
    (list obj(vlax-3D-Point miPt) sm:scale))) 
     (setq errCount(1+ errCount)) 
     )
      )
  ); end foreach 
  (princ(strcat "\n" (itoa errCount) " objects blocked layer! ")) 
  ) 
     ); if objset 
   (setq Flg nil) 
 ); end while 
 )

...

But is it possible to convert my selected primitive to the same block name?

Definitely, i will ensure that the shapes selected will be the same.

...

You must ensure that the shapes selected will be the same

(defun c:SETNB2 (/ ss adoc pt_lst center blk *error* lst bpat bname bi first)
 ;;;Each primitive in a separate named block
 ;;;http://www.cadtutor.net/forum/showthread.php?p=287449&posted=1#post287449
 (defun *error* (msg)
   (vla-endundomark adoc)
   (princ msg)
   (princ)
   ) ;_ end of defun
 (setq bpat "BLOCK-") ;_ <- Edit block name pattern here
 (vl-load-com)
 (vla-startundomark
   (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ end of vla-StartUndoMark
 (if (not (vl-catch-all-error-p
            (vl-catch-all-apply '(lambda () (setq ss (ssget "_:L"))))
            ) ;_ end of vl-catch-all-error-p
          ) ;_ end of not
   (progn
     (mapcar '(lambda(item)
     (setq
ss (list item)
       pt_lst (apply 'append
                     (mapcar
                       '(lambda (x / minp maxp)
                          (vla-getboundingbox x 'minp 'maxp)
                          (list (vlax-safearray->list minp)
                                (vlax-safearray->list maxp)
                                ) ;_ end of append
                          ) ;_ end of lambda
                       ss
                       ) ;_ end of mapcar
                     ) ;_ end of append
       center (mapcar '(lambda (a b) (/ (+ a b) 2.))
                      (list (apply 'min (mapcar 'car pt_lst))
                            (apply 'min (mapcar 'cadr pt_lst))
                            (apply 'min (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      (list (apply 'max (mapcar 'car pt_lst))
                            (apply 'max (mapcar 'cadr pt_lst))
                            (apply 'max (mapcar 'caddr pt_lst))
                            ) ;_ end of list
                      ) ;_ end of mapcar
)
(if (null first)
  (progn
    (setq
      bname  
     (progn
       (setq bi 0)
       (while (tblsearch "BLOCK" (setq bname (strcat bpat (itoa(setq bi(1+ bi)))))))
       bname)
      blk
     (vla-add (vla-get-blocks adoc)
                       (vlax-3d-point center)
                       bname
	      )
      ) ;_ end of setq
   (vla-copyobjects
       adoc
       (vlax-make-variant
         (vlax-safearray-fill
           (vlax-make-safearray vlax-vbobject (cons 0 (1- (length ss))))
           ss
           ) ;_ end of vlax-safearray-fill
         ) ;_ end of vlax-make-variant
       blk
       );_ end of vla-copyobjects
    (setq first t)
  )
)
    
     (vla-insertblock
       (vla-objectidtoobject adoc (vla-get-ownerid (car ss)))
       (vlax-3d-point center)
       (vla-get-name blk)
       1.0
       1.0
       1.0
       0.0
       ) ;_ end of vla-insertblock
	 )
  (setq
       lst     (mapcar 'vlax-ename->vla-object
                      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
                      ) ;_ end of mapcar
)
      )
     
     (mapcar 'vla-erase lst)
     ) ;_ end of and
   ) ;_ end of if
 (vla-endundomark adoc)
 (princ)
 )

VVA,

I would thank you from the bottom of my heart.

Your kindness strike deep into my emotion of appreciation.

Carl

Just adding, I would do it by aligning a block into lines and polylines, here's what i made before:

;|***********************************************************************************
   PROGRAM CREATED FOR RESTORING/ALIGNING/REPLACING BLOCKS TO 
       SIMILAR LINES/POLYLINES WITH DIFFERENT ROTATIONS
           
   DATE: NOVEMBER 20, 2008
   CREATED BY: RONALD MANEJA (WIZMAN)...email_add: [email="ron_09812001@yahoo.com"]ron_09812001@yahoo.com[/email]
   

------- CAN BE USED ALSO FOR MODIFYING BLOCK'S INSERTION POINT
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
|;

(defun c:blocker (/
         blkname
         blocker_kword
         bloker_newset
         blok_rot_strng
         counter
         fpoint
         ronblock
         ronblockdata
         seta
         spoint
         *error*
        )

;;;------------------------------------------------------------------------------------
;;;Initialize setvar, rtd,dtr & *error* functions    
   (setvar 'cmdecho 0)

   (vl-load-com)
   (defun rtd (a)
   (/ (* a 180) pi)
   ) ;_ end_defun
   (defun DTR (a)
   (* PI (/ a 180.0))
   ) ;_ end_defun
   (defun *error* (msg)
   (vla-EndUndoMark
       (vla-Get-ActiveDocument
       (vlax-Get-Acad-Object)
       ) ;_ end_vla-Get-ActiveDocument
   ) ;_ end_vla-EndUndoMark
   (setvar 'cmdecho 1)
   ) ;_ end_defun



;;;------------------------------------------------------------------------------------    
;;;blok_rot function - to relative rotate objects in selections


   (defun blok_rot (blok_set / blok_rot_allset blok_rot_counter)
   (setq blok_rot_allset blok_set)
   (while
       (not
       (member
           (strcase
           (setq blok_rot_strng
                (getstring
                    "\n>>>...Press Spacebar/Enter to continue rotating, [M] to Move or [E] to Exit...>>>: "
                ) ;_ end_getint
           ) ;_ end_setq
           ) ;_ end_strcase
           '("M" "E")
       ) ;_ end_member
       ) ;_ end_not

          (setq blok_rot_counter 0)
          (while (< blok_rot_counter (sslength blok_rot_allset))
          (command "rotate"
               (ssname blok_rot_allset blok_rot_counter)
               ""
               (cdr
               (assoc 10
                      (entget (ssname blok_rot_allset blok_rot_counter))
               ) ;_ end_assoc
               ) ;_ end_cdr
               90
          ) ;_ end_command
          (setq blok_rot_counter (1+ blok_rot_counter))
          ) ;_ end_while
   ) ;_ end_while
   (if (= (strcase blok_rot_strng) "M")
       (bmov bloker_newset)
   ) ;_ end_if
   (if (= (strcase blok_rot_strng) "E")
       (progn
       (initget 1 "Yes No")
       (setq blok_del_kword
            (getkword
                "\n>>>...Do you want to erase reference lines[Yes/No]?...>>>: "
            ) ;_ end_getkword
       ) ;_ end_setq
       (if (= blok_del_kword "Yes")
           (progn
           (vl-cmdf "._erase" seta "")
           (*error* nil)
           (exit)
           ) ;_ end_progn
           (progn
           (*error* nil)
           (exit)
           ) ;_ end_progn
       ) ;_ end_if
       ) ;_ end_progn
   ) ;_ end_if
   ) ;_ end_defun


;;;------------------------------------------------------------------------------------    
;;;bmov function - to relative move objects in selections    

   (defun bmov    (bmov_set / 2nd_pt_bmov allset_bmov ang_bmov counter_bmov dist_bmov ent_rot_bmov)

   (setq allset_bmov bmov_set)
   (while (and
          (not (initget 129))
          (setq dist_bmov
               (getdist
               "\n>>>...Enter Distance to move, [R] to Rotate or [E] to Exit...>>>: "
               ) ;_ end_getdist
          ) ;_ end_setq
                   ;(member (strcase dist_bmov) '("R" "E"))
          ) ;_ end_and
       (cond
       ((= (numberp dist_bmov) T)
        (progn
            (while
            (progn
                (setq ang_bmov
                     (cond
                     ((getint
                          "\nEnter the relative direction  [0/90/180/270] <0>"
                      ) ;_ end_getint
                     )
                     (0)
                     ) ;_ end_cond
                ) ;_ end_setq
                (if
                (not
                    (member ang_bmov '(0 90 180 270 -90))
                ) ;_ end_not
                   (not
                   (prompt
                       "\nError  Angle must be 0 90 180 270, please re-enter."
                   ) ;_ end_prompt
                   ) ;_ end_not
                ) ;_ end_if
            ) ;_ end_progn
            ) ;_ end_while
            (setq counter_bmov 0)
            (while (< counter_bmov (sslength allset_bmov))
            (setq ent_rot_bmov
                 (cdr (assoc 50 (entget (ssname allset_bmov counter_bmov)))
                 ) ;_ end_cdr
            ) ;_ end_setq

            (setq 2nd_pt_bmov
                 (polar (cdr (assoc 10 (entget (ssname allset_bmov counter_bmov))))
                    (+ ent_rot_bmov (dtr ang_bmov))
                    dist_bmov
                 ) ;_ end_polar
            ) ;_ end_setq
            (command "move"
                 (ssname allset_bmov counter_bmov)
                 ""
                 "_non"
                 (cdr (assoc 10 (entget (ssname allset_bmov counter_bmov))))
                 "_non"
                 2nd_pt_bmov
            ) ;_ end_command
            (setq counter_bmov (1+ counter_bmov))
            ) ;_ end_while
        ) ;_ end_progn
       )
       ((= (strcase dist_bmov) "R") (blok_rot bloker_newset))
       ((= (strcase dist_bmov) "E")
        (progn
            (initget 1 "Yes No")
            (setq blok_del_kword
                 (getkword
                 "\n>>>...Do you want to erase reference lines[Yes/No]?...>>>: "
                 ) ;_ end_getkword
            ) ;_ end_setq
            (if (= blok_del_kword "Yes")
            (progn
                (vl-cmdf "._erase" seta "")
                (*error* nil)
                (exit)
            ) ;_ end_progn
            (progn
                (*error* nil)
                (exit)
            ) ;_ end_progn
            ) ;_ end_if
        ) ;_ end_progn
       )
       ) ;_ end_cond
   ) ;_ end_while
   ) ;_ end_defun


;;;------------------------------------------------------------------------------------    
;;;end undo, start undo    

   (vla-EndUndoMark
   (vla-Get-ActiveDocument
       (vlax-Get-Acad-Object)
   ) ;_ end_vla-Get-ActiveDocument
   ) ;_ end_vla-EndUndoMark

   (vla-StartUndoMark
   (vla-Get-ActiveDocument
       (vlax-Get-Acad-Object)
   ) ;_ end_vla-Get-ActiveDocument
   ) ;_ end_vla-StartUndoMark



;;;------------------------------------------------------------------------------------    
;;;Main Routine    

   (while (not
          (and
          (or (setq ronblock (car (entsel "\n>>>...SELECT A BLOCK...>>>")))
              (prompt "\nMissed, try again.")
          ) ;_ end_or
          (or (= (cdr (assoc 0 (entget ronblock))) "INSERT")
              (prompt
              "\n>>>...That is not a block, pick a block this time...<<<"
              ) ;_ end_prompt
          ) ;_ end_or
          ) ;_ end_and
      ) ;_ end_not
   ) ;_ end_while

   (setq ronblockdata (entget ronblock))
   (setq blkname (cdr (assoc 2 ronblockdata)))

   (prompt
   "\n>>>...SELECT LINES OR POLYLINES TO ALIGN...>>>"
   ) ;_ end_prompt
   (setq seta (ssget '((0 . "LWpolyline,line"))))
   (setq counter 0)
   (setq bloker_newset (ssadd))
   (mapcar '(lambda (x)
        (setq fpoint (vlax-curve-getPointAtParam x 0))
        (setq spoint (vlax-curve-getPointAtParam x 1))

        (entmake (list    (cons 0 "INSERT")
               (cons 2 blkname)
               (cons 10 fpoint)
               (cons 41 1)
               (cons 42 1)
               (cons 43 1)
               (cons 50 (angle fpoint spoint))
             ) ;_ end_list
        ) ;_ end_entmake
        (ssadd (entlast) bloker_newset)
                   ;(vla-delete x)
        ) ;_ end_lambda

       (mapcar 'vlax-ename->vla-object
           (vl-remove-if
           'listp
           (mapcar 'cadr (ssnamex seta))
           ) ;_ end of vl-remove-if
       ) ;_ end_mapcar
   ) ;_ end_mapcar

   (princ (strcat "\nNo. of blocks added to the drawing = "
          (vl-princ-to-string (sslength bloker_newset))
      ) ;_ end_strcat
   ) ;_ end_princ

   (initget 7 "Move Rotate Exit")
   (if    (setq blocker_kword (getkword "\n Do you want to [Rotate/Move/Exit]?: "))
   (progn
       (if    (null blocker_kword)
       (setq blocker_kword "Exit")
       ) ;_ end_if
       (cond
       ((= blocker_kword "Move") ((bmov bloker_newset)))
       ((= blocker_kword "Rotate") ((blok_rot bloker_newset)))
       ((= blocker_kword "Exit")
        (progn
            (initget 1 "Yes No")
            (setq blok_del_kword
                 (getkword
                 "\n>>>...Do you want to erase reference lines[Yes/No]?...>>>: "
                 ) ;_ end_getkword
            ) ;_ end_setq
            (if (= blok_del_kword "Yes")
            (progn
                (vl-cmdf "._erase" seta "")
                (*error* nil)
                (exit)
            ) ;_ end_progn
            (progn
                (*error* nil)
                (exit)
            ) ;_ end_progn
            ) ;_ end_if
        ) ;_ end_progn
       )
;;;        ((= blocker_kword "Both")
;;;         ((progn
;;;          (bmov bloker_newset)
;;;          (blok_rot bloker_newset)
;;;          ) ;_ end_progn
;;;         )
;;;        )
       ) ;_ end_cond
   ) ;_ end_progn
   ) ;_ end_if
   (*error* nil)
   (princ)
) ;_ end_defun
(prompt
   "\n>>>...BLOCKER.LSP LOADED...Type 'BLOCKER' to run command by Ronald Maneja...<<<"
) ;_ end_prompt
(princ)

Is it possible with SETNB2.lsp to keep the hyperlink attached.

Jaap