Author Topic: Block translate and insert by Size.  (Read 5153 times)

0 Members and 1 Guest are viewing this topic.

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Block translate and insert by Size.
« on: December 10, 2015, 09:45:31 PM »
This is in response to a post on the AutoDesk forum.
http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/insert-a-new-block-based-on-the-size-of-an-old-block-width-and/m-p/5946907#U5946907
Refer to that thread for intent.

I'm posting here for code clarity.
The code is for proof of concept and doesn't handle situations where the original block is inserted mirrored.

It is possible to change code from single selection to multiple selection , but not today :)

Source:
Code - Auto/Visual Lisp: [Select]
  1. ;;;-----------------------------------------------------------
  2. (defun c:BlockInsertBySize151211 (/
  3.                                   *error*
  4.                                   ;|  TODO Make these local after testing
  5.                                   _singleSelection
  6.                                   _GetBlockData
  7.                                   _SwapBlock
  8.                                   _SwapLayerForOldInstance
  9.                                   ;;    
  10.                                   g:OriginalBlocksData
  11.                                   g:OriginalBlocksNames
  12.                                   ;|
  13.                                   ;;
  14.                                   ;|
  15.                                   G:BLOCKNAME
  16.                                   G:ENT
  17.                                   G:INSERTION
  18.                                   G:NEWBLOCKNAME
  19.                                   G:NEWLAYERNAME
  20.                                   G:OLDLAYER
  21.                                   G:ROTATION
  22.                                   |;
  23.                                  )
  24.   ;;-----------------------------------------------------------
  25.   (defun *error* (msg) (Default*error* msg))
  26.   ;;-----------------------------------------------------------
  27.   (setq g:OriginalBlocksData  (list
  28.                                 '("SAMPLE BLOCK" "T" 72 42.25)
  29.                                 '("SK1" "T" 72 42.25)
  30.                                 '("SK2" "WS" 31.1875 29)
  31.                                 '("SK3" "ST" 43 22)
  32.                                 '("SK4" "SH" 43 22)
  33.                                 '("SK5" "T" 15 15)
  34.                                 '("SK6" "S" 72 24)
  35.                                )
  36.         g:OriginalBlocksNames (mapcar '(lambda (x) (car x))
  37.                                       g:OriginalBlocksData
  38.                               )
  39.   )
  40.  
  41.   ;;-----------------------------------------------------------
  42.   (defun _singleSelection (/ selection ename)
  43.     (if (and (setq selection (entsel))
  44.              (setq ename (car selection))
  45.              (setq g:ent (entget ename))
  46.              (setq g:blockName (dxf 2 g:ent))
  47.              (= "INSERT" (dxf 0 g:ent))
  48.              (member g:blockName g:OriginalBlocksNames)
  49.         )
  50.       (_GetBlockData g:ent)
  51.     )
  52.   )
  53.   ;;-----------------------------------------------------------
  54.   (defun _GetBlockData (ent / Data xScale yScale zScale width height)
  55.     (setq g:insertion (dxf 10 ent)
  56.           g:oldlayer  (dxf 8 ent)
  57.           g:rotation  (dxf 50 ent)
  58.           xScale      (dxf 41 ent)
  59.           yScale      (dxf 42 ent)
  60.           zScale      (dxf 43 ent)
  61.     )
  62.     (setq Data           (dxf g:blockName g:OriginalBlocksData)
  63.           g:newLayerName (strcat "Table" (car Data))
  64.           width          (abs (* xScale (cadr Data)))
  65.           height         (abs (* yScale (caddr Data)))
  66.     )
  67.     (if (= g:blockName "SK5")                          ; It's a circle
  68.       (setq g:newBlockName (strcat g:newLayerName
  69.                                    (kdub:roundnearest height 1 0)
  70.                                    "R"
  71.                            )
  72.       )
  73.       ;; else it's a rectangle
  74.       (setq g:newBlockName (strcat g:newLayerName
  75.                                    (kdub:roundnearest height 1 0)
  76.                                    (kdub:roundnearest width 1 0)
  77.                            )
  78.       )
  79.     )
  80.   )
  81.   ;;-----------------------------------------------------------
  82.   (defun _SwapBlock ( / newblkent)
  83.     (if (or (tblsearch "BLOCK" g:newBlockName)
  84.             (findfile (strcat g:newBlockName ".dwg"))
  85.         )
  86.       (vl-cmdf "-INSERT"
  87.                g:newBlockName
  88.                "S"
  89.                1.0
  90.                "R"
  91.                (kdub:rtd g:rotation)
  92.                g:insertion
  93.       )
  94.       ;; else
  95.       (progn (ALERT (strcat "Can't locate Block "
  96.                             g:newBlockName
  97.                             "\n Routine will exit"
  98.                     )
  99.              )
  100.              (princ (strcat "Can't locate Block "
  101.                             g:newBlockName
  102.                             "\n Routine will exit"
  103.                     )
  104.              )
  105.              (exit)
  106.       )
  107.     )
  108.     ;;Change to correct Layer
  109.     (or (tblsearch "LAYER" g:newLayerName) (vl-cmdf "-Layer" "New" g:newLayerName ""))
  110.     (setq newblkent (entget (entlast)) )
  111.     (entmod (subst (cons 8 g:newLayerName) (assoc 8 newblkent) newblkent))
  112.   )
  113.   ;;-----------------------------------------------------------
  114.   (defun _SwapLayerForOldInstance (/ Lay)
  115.     (setq lay (strcat "SCRAP-" g:oldlayer))
  116.     (or (tblsearch "LAYER" lay) (vl-cmdf "-Layer" "New" lay ""))
  117.     (entmod (subst (cons 8 lay) (assoc 8 g:ent) g:ent))
  118.   )
  119.   ;;-----------------------------------------------------------
  120.   (_singleSelection)
  121.   (_SwapBlock)
  122.   (_SwapLayerForOldInstance)
  123.   (princ)
  124. )
  125.  

Library code:
Code - Auto/Visual Lisp: [Select]
  1. ;;; Return linked value from association list
  2. (defun dxf (key data /) (cdr (assoc key data)))
  3.  
  4. ;;;  Convert Angles from DEGREES to RADIANS
  5. (defun kdub:dtr (ang) (* (/ ang 180.0) pi))
  6.  
  7. ;;; Convert Angles from RADIANS to DEGREES
  8. (defun kdub:rtd (ang) (/ (* ang 180.0) pi))
  9. ;;;---------------------------------------------------------------------------
  10. ;;;---------------------------------------------------------------------------
  11. ;;* kdub:roundNearest (numVal roundTo displayPrecision)
  12. ;; Round a numeric positive number to the NEAREST 'rounded' number
  13. ;; and format to n digits
  14. ;; kwb@theSwamp 20070814
  15. ;|
  16. (kdub:roundnearest 5.7 1 0) ;-> "6"
  17. (kdub:roundnearest 6.3 1 0) ;-> "6"
  18. (kdub:roundnearest 6.3 0.5 2) ;-> "6.50"
  19. (kdub:roundnearest 6.2 0.5 3) ;-> "6.000"
  20. |;
  21.  
  22. (defun kdub:roundnearest (numval roundto displayprecision / remnum)
  23.   (setq remnum (rem numval roundto))
  24.   (rtos (if (>= (* 2 remnum) roundto)
  25.           (+ numval (- roundto remnum))
  26.           (- numval remnum)
  27.         )
  28.         2
  29.         displayprecision
  30.   )
  31. )
  32. ;;;-----------------------------------------------------------
  33. (defun Default*error* (msg)
  34.   (while (< 0 (getvar 'cmdactive)) (command-s nil))
  35.   (setvar 'menuecho 1)
  36.   (cond ((not msg))
  37.         ((member
  38.            (strcase msg t)
  39.            '("console break" "function cancelled" "quit / exit abort")
  40.          )
  41.          (princ "\nFunction Cancelled.")
  42.         )
  43.         ((princ (strcat "\nApplication Error: "
  44.                         (itoa (getvar 'errno))
  45.                         " :- "
  46.                         msg
  47.                 )
  48.          )
  49.          (vl-bt)
  50.         )
  51.   )
  52.   (setvar 'errno 0)
  53.   (princ)
  54. )
  55.  
  56.  
  57.  

ADDED:
Code revised to add new block on specific layer :


Code attachment :
« Last Edit: December 10, 2015, 10:22:11 PM by Kerry »
kdub, kdub_nz in other timelines.
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Re: Block translate and insert by Size.
« Reply #1 on: December 11, 2015, 11:00:29 AM »
Stage 2 :
Determine the unique blocks required.

Proof of concept
Not thoroughly tested

NOTE : For an accurate record the g:OriginalBlocksData list must be complete
... or we don't know what to look for ...

Code - Auto/Visual Lisp: [Select]
  1.  
  2. ;;;-----------------------------------------------------------
  3.  
  4. (defun c:CountBlocksToInsertBySize151212 (/
  5.                                           *error*
  6.                                           _COLLECTBLOCKS
  7.                                           _GETNEWBLOCKNAME
  8.                                           _LIST->CSV
  9.                                           ;;
  10.                                           g:OriginalBlocksData
  11.                                           g:OriginalBlocksNames
  12.                                          )
  13.   ;;-----------------------------------------------------------
  14.   (defun *error* (msg) (Default*error* msg))
  15.   ;;-----------------------------------------------------------
  16.   (setq g:OriginalBlocksData  (list
  17.                                 '("SAMPLE BLOCK" "T" 72 42.25)
  18.                                 '("SK1" "T" 72 42.25)
  19.                                 '("SK2" "WS" 31.1875 29)
  20.                                 '("SK3" "ST" 43 22)
  21.                                 '("SK4" "SH" 43 22)
  22.                                 '("SK5" "T" 15 15)
  23.                                 '("SK6" "S" 72 24)
  24.                                )
  25.         g:OriginalBlocksNames (mapcar '(lambda (x) (car x))
  26.                                       g:OriginalBlocksData
  27.                               )
  28.   )
  29.   ;;-----------------------------------------------------------
  30.   (defun _list->CSV (lst delim)
  31.       delim
  32.       (apply 'strcat
  33.              (mapcar (function (lambda (x) (strcat x delim))) lst)
  34.       )
  35.     )
  36.   )
  37.   ;;-----------------------------------------------------------
  38.   (defun _GetNewBlockName (ent         /
  39.                            Data        xScale
  40.                            yScale      width
  41.                            height      blockName
  42.                            newBlockName
  43.                            newLayerName
  44.                           )
  45.     (setq blockName    (dxf 2 ent)
  46.           xScale       (dxf 41 ent)
  47.           yScale       (dxf 42 ent)
  48.           Data         (dxf blockName g:OriginalBlocksData)
  49.           newLayerName (strcat "Table" (car Data))
  50.           width        (abs (* xScale (cadr Data)))
  51.           height       (abs (* yScale (caddr Data)))
  52.     )
  53.     (if (= blockName "SK5")                            ; It's a circle
  54.       (setq newBlockName (strcat newLayerName
  55.                                  (kdub:roundnearest height 1 0)
  56.                                  "R"
  57.                          )
  58.       )
  59.       ;; else it's a rectangle
  60.       (setq newBlockName (strcat newLayerName
  61.                                  (kdub:roundnearest height 1 0)
  62.                                  (kdub:roundnearest width 1 0)
  63.                          )
  64.       )
  65.     )
  66.   )
  67.   ;;-----------------------------------------------------------
  68.   (defun _CollectBlocks
  69.          (/ ss BlockList newBlockName NewBlockList n ent)
  70.     (setq ss
  71.            (ssget "X"
  72.                   (list (cons 2 (_list->CSV g:OriginalBlocksNames ",")))
  73.            )
  74.           BlockList nil
  75.           NewBlockList nil
  76.     )
  77.     (if ss
  78.       (princ (strcat "Processing " (itoa (sslength ss)) " blocks\n"))
  79.       (progn (princ "No Blocks were selected\n") (exit))
  80.     )
  81.     (repeat (setq n (sslength ss))
  82.       (setq BlockList (cons (ssname ss (setq n (1- n))) BlockList))
  83.     )
  84.     (foreach blk BlockList
  85.       (setq ent          (entget blk)
  86.             newBlockName (_GetNewBlockName ent)
  87.       )
  88.       (if (not (vl-position newBlockName NewBlockList))
  89.         (setq NewBlockList (cons newBlockName NewBlockList))
  90.       )
  91.     )
  92.     (setq NewBlockList (vl-sort NewBlockList '<))
  93.   )
  94.   ;;-----------------------------------------------------------
  95.   (_CollectBlocks)
  96. )
  97.  
« Last Edit: December 11, 2015, 11:10:53 AM by Kerry »
kdub, kdub_nz in other timelines.
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.

Kerry

  • Mesozoic relic
  • Seagull
  • Posts: 11654
  • class keyThumper<T>:ILazy<T>
Re: Block translate and insert by Size.
« Reply #2 on: December 12, 2015, 01:08:33 AM »
Stage 3 :
Build designated blocks required.

Proof of concept.

Code - Auto/Visual Lisp: [Select]
  1. ;;;------------------------------------------------------------------
  2. ;; Codehimbelonga kdub 2015.12.12
  3. ;;
  4. ;| Requires Library Functions
  5. kdub:roundnearest ()
  6. Default*error* ()
  7.  
  8. REFER: http://www.theswamp.org/index.php?topic=50602.0
  9. |;
  10.  
  11. ;;
  12. (defun c:MakeNewBlock151212 (/
  13.                              *error*
  14.                              _ENTPLINEBLOCKMAKER
  15.                              _ENTMAKETEXT
  16.                              _ENTMAKEPLINE
  17.                              _ENTCIRCLEBLOCKMAKER
  18.                             )
  19.   ;;-----------------------------------------------------------
  20.   (defun *error* (msg) (Default*error* msg))
  21.   ;;-----------------------------------------------------------
  22.   (defun _entmakepline (VertexList closed)
  23.     ;; Codehimbelonga kdub 2010.06.22
  24.     (entmake
  25.       (append (list '(0 . "LWPOLYLINE")
  26.                     '(100 . "AcDbEntity")
  27.                     '(100 . "AcDbPolyline")
  28.                     (cons 90 (length VertexList))
  29.                     (cons 70
  30.                           (if Closed
  31.                             1
  32.                             0
  33.                           )
  34.                     )
  35.                     (cons 8 "0")
  36.               )
  37.               (mapcar (function (lambda (pt) (cons 10 pt))) VertexList)
  38.       )
  39.     )
  40.   )
  41.   ;;-----------------------------------------------------------
  42.   (defun _entmakeBLText (textString)
  43.     (entmake (list '(0 . "TEXT")
  44.                    '(100 . "AcDbEntity")
  45.                    '(67 . 0)
  46.                    '(8 . "0")
  47.                    '(62 . 0)
  48.                    '(6 . "ByBlock")
  49.                    '(370 . -2)
  50.                    '(100 . "AcDbText")
  51.                    '(10 2.0 -4.0 0.0)
  52.                    '(40 . 2.0)
  53.                    (cons 1 textString)
  54.                    '(50 . 0.0)
  55.                    '(41 . 1.0)
  56.                    '(51 . 0.0)
  57.                    '(7 . "Arial")
  58.                    '(71 . 0)
  59.                    '(72 . 0)
  60.                    '(11 0.0 0.0 0.0)
  61.                    '(100 . "AcDbText")
  62.                    '(73 . 0)
  63.              )
  64.     )
  65.   )
  66.   ;;-----------------------------------------------------------
  67.   (defun _entPlineBlockMaker
  68.          (Table width height / textString BlockName vertexList)
  69.     (setq textString (strcat Table
  70.                              (kdub:roundnearest height 1 0)
  71.                              (kdub:roundnearest width 1 0)
  72.                      )
  73.           BlockName  (strcat "Table" textString)
  74.           vertexList (list (list 0. 0. 0.)
  75.                            (list width 0. 0.)
  76.                            (list width (- height) 0.)
  77.                            (list 0. (- height) 0.)
  78.                      )
  79.     )
  80.     (entmake (list '(0 . "BLOCK")
  81.                    '(100 . "AcDbEntity")
  82.                    '(67 . 0)
  83.                    '(8 . "0")
  84.                    '(100 . "AcDbBlockReference")
  85.                    (cons 2 BlockName)
  86.                    '(10 0.0 0.0 0.0)
  87.                    '(70 . 0)
  88.              )
  89.     )
  90.     (entmake (_EntmakePline vertexList T))
  91.     (entmake (_entmakeBLText textString))
  92.     (entmake '((0 . "ENDBLK") (100 . "AcDbBlockEnd") (8 . "0")))
  93.     (princ (strcat "\nDefined block " BlockName))
  94.   )
  95.   ;;-----------------------------------------------------------
  96.   ;;
  97.   (defun _entCircleBlockMaker (Table radius / textString BlockName)
  98.     (setq textString (strcat Table (kdub:roundnearest radius 1 0) "R")
  99.           BlockName  (strcat "Table" textString)
  100.     )
  101.     (entmake (list '(0 . "BLOCK")
  102.                    '(100 . "AcDbEntity")
  103.                    '(67 . 0)
  104.                    '(8 . "0")
  105.                    '(100 . "AcDbBlockReference")
  106.                    (cons 2 BlockName)
  107.                    '(10 0.0 0.0 0.0)
  108.                    '(70 . 0)
  109.              )
  110.     )
  111.     (entmake (list '(0 . "CIRCLE")
  112.                    '(8 . "0")
  113.                    '(62 . 0)
  114.                    '(6 . "ByBlock")
  115.                    '(370 . -2)
  116.                    '(10 0.0 0.0 0.0)
  117.                    (cons 40 radius)
  118.              )
  119.     )
  120.     (entmake '((0 . "ENDBLK") (100 . "AcDbBlockEnd") (8 . "0")))
  121.     (princ (strcat "\nDefined block " BlockName))
  122.   )
  123.   ;;-----------------------------------------------------------
  124.   ;;-----------------------------------------------------------
  125.   (_entPlineBlockMaker "XX" 50 30)
  126.   (_entPlineBlockMaker "XXA" 50 30)
  127.   (_entPlineBlockMaker "XXS" 150 36)
  128.   ;;
  129.   (_entCircleBlockMaker "XC" 12)
  130.   (_entCircleBlockMaker "XDC" 15)
  131.   (_entCircleBlockMaker "XDC" 11)
  132.   (princ)
  133. )
  134.  
  135.  
« Last Edit: December 12, 2015, 01:17:02 AM by Kerry »
kdub, kdub_nz in other timelines.
Perfection is not optional.
Everything will work just as you expect it to, unless your expectations are incorrect.
Discipline: None at all.