Author Topic: Revisit Alan's MakeEntMake.lsp Routine  (Read 3447 times)

0 Members and 1 Guest are viewing this topic.

chlh_jd

  • Guest
Revisit Alan's MakeEntMake.lsp Routine
« on: April 26, 2014, 02:55:39 PM »
Alan has done a nice job for Entity to lisp . http://www.theswamp.org/index.php?topic=31145
Today need to used it in nested block and a lot blocks with attrib , so revisit Alan's program , I hope Alan don't mind . :-)
Code - Auto/Visual Lisp: [Select]
  1. ;;;=======================[ MakeEntmake.lsp ]==================================
  2. ;;; Author:  Charles Alan Butler Copyright?2005-2012
  3. ;;; Version: 1.5 Nov. 10, 2012
  4. ;;; Purpose: To create a lisp that will recreate the objects selected
  5. ;;;          Will not process xref or nested blocks, blocks are created
  6. ;;;          from Inserts but no insert is created, you must insert
  7. ;;; Output;  A lisp file with the name of the drawing contailing the lisp code
  8. ;;; Sub_Routines:
  9. ;;;          _replace -  replace in string
  10. ;;;          dxfstrip - Strip dxf from list
  11. ;;;          make_complex -  Write additional lines needed for complex objects
  12. ;;;          dxf -  return value from a dotted pair
  13. ;;;          ToString -  convert item to a string by MP
  14. ;;; Requirements: -None
  15. ;;; Returns: -None
  16. ;;; Original Thread:  http://www.theswamp.org/index.php?topic=4814.0
  17. ;;; Latest Version: http://www.theswamp.org/index.php?topic=31145
  18. ;;;===========================================================================
  19. ;;;  Note: No error checking at this time
  20. ;;;  This routine is a major rewrite of a routine found on the internet
  21. ;;;  and the author of the original code is unkown
  22. ;;;  Objects supported
  23. ;;;     "3DFACE" "3DSOLID" "ARC" "ATTDEF" "CIRCLE" "DIMENSION"
  24. ;;;     "ELLIPSE" "HATCH" "LEADER" "LWPOLYLINE" "LINE" "MTEXT"
  25. ;;;     "POINT" "RAY" "REGION" "SHAPE" "SOLID" "SPLINE" "TEXT"
  26. ;;;     "TRACE" "XLINE" "WIPEOUT"
  27. ;;;     "TABLE" ; untested
  28. ;;;  Objects not supported at this time
  29. ;;;     MLine  Raster  Tolerance  XRecord  
  30. ;;;===========================================================================
  31. ;;;
  32. ;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED     ;
  33. ;;;   WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR  ;
  34. ;;;   PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.            ;
  35. ;;;                                                                    ;
  36. ;;;  You are hereby granted permission to use, copy and modify this    ;
  37. ;;;  software without charge, provided you do so exclusively for       ;
  38. ;;;  your own use or for use by others in your organization in the     ;
  39. ;;;  performance of their normal duties, and provided further that     ;
  40. ;;;  the above copyright notice appears in all copies and both that    ;
  41. ;;;  copyright notice and the limited warranty and restricted rights   ;
  42. ;;;  notice below appear in all supporting documentation.              ;
  43. ;;;
  44. ;;;============================================================================
  45. ;;; Edited by GSLS(SS)  April 14 , 2014
  46. ;;; what's changed :
  47. ;;;  Try to Add some type of "TABLE" -- LTYPE , This part has not check LTYPE Loaded ,
  48. ;;;                                            I think it can Separate outputs a LineType file , and then reload it .
  49. ;;;                                     Layer , It can make remake entities keep their Layer-property .
  50. ;;;                                     STYLE , No check
  51. ;;;                                     DIMSTYLE , NO check
  52. ;;;  Add check Ltype before remake curves
  53. ;;;  Add Nested block , block with attrib .
  54. ;;;
  55.  

snownut2

  • Swamp Rat
  • Posts: 971
  • Bricscad 22 Ultimate
Re: Revisit Alan's MakeEntMake.lsp Routine
« Reply #1 on: April 26, 2014, 03:21:56 PM »
Not as easy as you think it is, otherwise Alan would have included in original code.

Attribute locations when created are not based in location within the block but actual location in the drawing instead, so each block will have different dxf 10 & 11 codes for each attribute, a bit tricky to keep tract of, a transform function has to be applied to each attribute based on blocks current location within the drawing. (not even getting into user coordinate system transformations)

Pretty much same holds true for nested blocks.

If you are just looking for the enttity (dxf) code for particular blocks you can explode them to get to the nested blocks or attributes and then run Alans function on the previously nested blocks.



chlh_jd

  • Guest
Re: Revisit Alan's MakeEntMake.lsp Routine
« Reply #2 on: April 26, 2014, 03:40:11 PM »
Not as easy as you think it is, otherwise Alan would have included in original code.

Attribute locations when created are not based in location within the block but actual location in the drawing instead, so each block will have different dxf 10 & 11 codes for each attribute, a bit tricky to keep tract of, a transform function has to be applied to each attribute based on blocks current location within the drawing. (not even getting into user coordinate system transformations)

Pretty much same holds true for nested blocks.

If you are just looking for the enttity (dxf) code for particular blocks you can explode them to get to the nested blocks or attributes and then run Alans function on the previously nested blocks.
Have you test it ?
« Last Edit: April 26, 2014, 03:43:28 PM by chlh_jd »

CAB

  • Global Moderator
  • Seagull
  • Posts: 10401
Re: Revisit Alan's MakeEntMake.lsp Routine
« Reply #3 on: April 26, 2014, 07:12:28 PM »
Alan has done a nice job for Entity to lisp . http://www.theswamp.org/index.php?topic=31145
Today need to used it in nested block and a lot blocks with attrib , so revisit Alan's program , I hope Alan don't mind . :)

I don't mind at all. Thanks for the interest.
No time to test it today.
I've reached the age where the happy hour is a nap. (°¿°)
Windows 10 core i7 4790k 4Ghz 32GB GTX 970
Please support this web site.

chlh_jd

  • Guest
Re: Revisit Alan's MakeEntMake.lsp Routine
« Reply #4 on: April 27, 2014, 12:32:48 AM »
Alan has done a nice job for Entity to lisp . http://www.theswamp.org/index.php?topic=31145
Today need to used it in nested block and a lot blocks with attrib , so revisit Alan's program , I hope Alan don't mind . :)

I don't mind at all. Thanks for the interest.
No time to test it today.

Thanks Alan , thank you a lot !  :-)

chlh_jd

  • Guest
Re: Revisit Alan's MakeEntMake.lsp Routine
« Reply #5 on: April 29, 2014, 12:09:07 PM »
Found error :
 1. Dimension entity can't be rebuild in block ;
 2. Curve rebuild catch lost when the linetype is not found .

Are grateful for any help .

 for rebuild Conventional linetype
Code - Auto/Visual Lisp: [Select]
  1. (defun rwlty  (Ltn fn / ent str d74 d75 sty shp)
  2.   ;; rebuild part of linetype file -- *.Lin
  3.   ;; ltn -- Linetype Name
  4.   ;; fn  -- an file is open to write .
  5.   ;;  v0.1
  6.   ;; by GSLS(SS) 4.29 . 2014
  7.   ;; curren version no support for insert shape linetype .
  8.   (setq ent (entget (tblobjname "LTYPE" ltn)));_get elist
  9.     (strcat "*" (cdr (assoc 2 ent)) "," (cdr (assoc 3 ent)))
  10.     fn);_LineType Name and Description
  11.  
  12.   ;; Start LineType shape inversion ...
  13.   (setq str (strcat (chr (cdr (assoc 72 ent))) ","))
  14.   (repeat (cdr (assoc 73 ent))
  15.     (setq ent (member (assoc 49 ent) ent)
  16.           str (strcat str (vl-princ-to-string (cdr (assoc 49 ent))) ",")
  17.           ent (cdr ent)
  18.           d74 (cdr (assoc 74 ent))
  19.           ent (cdr ent))
  20.     (if (and ent (/= (caar ent) 49))
  21.       (cond ((= d74 0))
  22.             ((= d74 1)
  23.              (prompt "\n*** Warning no support d74 = 1 ."))
  24.             ((and (= d74 2) (= (cdr (assoc 75 ent)) 0));_Insert String with specified font ,
  25.                                                        ;_here no check whether the font is correct .
  26.              (setq sty (cdr (assoc 2 (entget (cdr (assoc 340 ent)))))
  27.                    str (strcat str
  28.                                "["
  29.                                (cdr (assoc 9 ent))
  30.                                ","
  31.                                sty
  32.                                ",S="
  33.                                (vl-princ-to-string (cdr (assoc 46 ent)))
  34.                                ",R="
  35.                                (vl-princ-to-string (cdr (assoc 50 ent)))
  36.                                ",X="
  37.                                (vl-princ-to-string (cdr (assoc 44 ent)))
  38.                                ",Y="
  39.                                (vl-princ-to-string (cdr (assoc 45 ent)))
  40.                                "],")))
  41.             ((= d74 4);_Insert special shape ,
  42.              (prompt "\n*** Curren version no support insert shape linetype rebuild .")
  43.              (setq d75 (cdr (assoc 75 ent));_how to get shape name though the shape number ?
  44.                                            ;_*******************
  45.                    shp (cdr (assoc 3 (entget (cdr (assoc 340 ent))))))
  46.              (setq
  47.                str (strcat str
  48.                            "["
  49.                            (vl-princ-to-string d75)
  50.                            ","
  51.                            shp
  52.                            ",S="
  53.                            (vl-princ-to-string (cdr (assoc 46 ent)))
  54.                            ",R="
  55.                            (vl-princ-to-string (cdr (assoc 50 ent)))
  56.                            ",X="
  57.                            (vl-princ-to-string (cdr (assoc 44 ent)))
  58.                            ",Y="
  59.                            (vl-princ-to-string (cdr (assoc 45 ent)))
  60.                            "],")))))
  61.     )
  62.   (setq str (vl-string-right-trim "," str))
  63.   (write-line str fn)
  64.   (princ)
  65.   )
  66.  

chlh_jd

  • Guest
Re: Revisit Alan's MakeEntMake.lsp Routine
« Reply #6 on: May 03, 2014, 11:24:54 AM »
New for rebuild Linetype  Embed shape , if it's *shp.shx can be found .
ss:readbinarystream function see here http://www.theswamp.org/index.php?topic=36656.msg519678#msg519678
Code - Auto/Visual Lisp: [Select]
  1. ;;
  2. (defun rwlty  (Ltn fn / ent str d74 d75 sty shp f shpidx)
  3.   ;; rebuild part of linetype file -- *.Lin
  4.   ;; ltn -- Linetype Name
  5.   ;; fn  -- an file is open to write .
  6.   ;;  v0.1
  7.   ;; by GSLS(SS) 4.29 . 2014
  8.   ;; curren version no support for insert shape linetype .
  9.   (setq ent (entget (tblobjname "LTYPE" ltn)));_get elist
  10.     (strcat "*" (cdr (assoc 2 ent)) "," (cdr (assoc 3 ent)))
  11.     fn);_LineType Name and Description  
  12.   ;; Start LineType shape inversion ...
  13.   (setq str (strcat (chr (cdr (assoc 72 ent))) ","))
  14.   (repeat (cdr (assoc 73 ent))
  15.     (setq ent (member (assoc 49 ent) ent)
  16.           str (strcat str (vl-princ-to-string (cdr (assoc 49 ent))) ",")
  17.           ent (cdr ent)
  18.           d74 (cdr (assoc 74 ent))
  19.           ent (cdr ent))
  20.     (if (and ent (/= (caar ent) 49))
  21.       (cond ((= d74 0))
  22.             ((= d74 1)
  23.              (prompt "\n*** Warning no support d74 = 1 ."))
  24.             ((and (= d74 2) (= (cdr (assoc 75 ent)) 0));_Insert String with specified font ,
  25.                                                        ;_here no check whether the font is correct .
  26.              (setq sty (cdr (assoc 2 (entget (cdr (assoc 340 ent)))))
  27.                    str (strcat str
  28.                                "["
  29.                                (cdr (assoc 9 ent))
  30.                                ","
  31.                                sty
  32.                                ",S="
  33.                                (vl-princ-to-string (cdr (assoc 46 ent)))
  34.                                ",R="
  35.                                (vl-princ-to-string (cdr (assoc 50 ent)))
  36.                                ",X="
  37.                                (vl-princ-to-string (cdr (assoc 44 ent)))
  38.                                ",Y="
  39.                                (vl-princ-to-string (cdr (assoc 45 ent)))
  40.                                "],")))
  41.             ((= d74 4);_Insert special shape ,
  42.              (prompt "\n*** Curren version no support insert shape linetype rebuild .")
  43.              (setq d75 (cdr (assoc 75 ent));_how to get shape name though the shape number ?                                       
  44.                    shp (cdr (assoc 3 (entget (cdr (assoc 340 ent))))))
  45.              (if (and (setq f (findfile shp)) (setq shpidx (ss:shx:GetIndexName f)) (assoc d75 shpidx))
  46.                (setq d75 (cdr (assoc d75 shpidx)))
  47.                (progn
  48.                  (prompt (strcat "\n*** LineType "  Ltn "can't find bind shape " (rtos d75 2 0) "in " shp " , Please check it ***"))             
  49.                (setq d75 "???"
  50.                      shp "STANDARD")))
  51.              (setq
  52.                str (strcat str
  53.                            "["
  54.                            (vl-princ-to-string d75)
  55.                            ","
  56.                            shp
  57.                            ",S="
  58.                            (vl-princ-to-string (cdr (assoc 46 ent)))
  59.                            ",R="
  60.                            (vl-princ-to-string (cdr (assoc 50 ent)))
  61.                            ",X="
  62.                            (vl-princ-to-string (cdr (assoc 44 ent)))
  63.                            ",Y="
  64.                            (vl-princ-to-string (cdr (assoc 45 ent)))
  65.                            "],")))))
  66.     )
  67.   (setq str (vl-string-right-trim "," str))
  68.   (write-line str fn)
  69.   (princ)
  70.   )
  71.  
  72. ;;;--------------------------------------
  73. (defun ss:shx:GetIndexName (shxfile / l str stp etp asn sn cin l1 a b n i l2 l3 l4)
  74.   ;; get shape name and it's index from a shx file
  75.   ;; shxfile --  *shx file with full path
  76.   ;; e.g. (ss:shx:GetIndexName (findfile "gslsshp.shx"))
  77.   (setq l (ss:readbinarystream   shxfile   nil    nil    nil)
  78.         ;; ss:readbinarystream function see here http://www.theswamp.org/index.php?topic=36656.msg519678#msg519678
  79.         l (mapcar (function (lambda (a) (rem(+ (rem a 256) 256) 256))) l)
  80.         i 0)
  81.   (gc)
  82.   (repeat 25
  83.     (setq l1 (cons (nth i l) l1)
  84.           i (1+ i)))
  85.   (setq str (vl-list->string (reverse l1))
  86.         l1 nil
  87.         l (mapcar (function (lambda (a / s n) (setq s (ss-dec2bas 16 a) n (strlen s)) (repeat (- 2 n) (setq s (strcat "0" s))) s)) l))
  88.   (cond ((or (partmember '("73" "68" "61" "70" "65" "73") l);_shapes
  89.              (partmember '("61" "73" "63" "69" "69") l));_ascii  
  90.          (setq l (partmember '("0D"   "0A"  "1A") l)
  91.                l (cdddr l)
  92.                stp (ss-bas2dec 16 (strcat (cadr l) (car l)));_Index begining code
  93.                etp (ss-bas2dec 16 (strcat (cadddr l) (caddr l)));_Index ending code
  94.                l (cddddr l)
  95.                asn (ss-bas2dec 16 (strcat (cadr l) (car l)));_Index numbers
  96.                l (cddr l))
  97.          (repeat asn
  98.            (setq l1 (cons (cons (ss-bas2dec 16 (strcat (cadr l) (car l) )) (ss-bas2dec 16 (strcat (cadddr l) (caddr l)))) l1)
  99.                  l (cddddr l)))
  100.          (setq l1 (reverse l1))
  101.          (setq i 0)
  102.          (repeat (length l1)
  103.            (setq a (nth i l1)
  104.                  n (cdr a)
  105.                  b nil)
  106.            (repeat n
  107.              (setq b (cons (car l) b)
  108.                    l (cdr l)))
  109.            (setq l2 (cons (reverse b) l2)
  110.                  i (1+ i)))
  111.          (setq l2 (reverse l2))
  112.          (setq l3 (mapcar (function (lambda (a) (if (/= (car a) "00")  (vl-list->string (mapcar (function(lambda (a) (ss-bas2dec 16 a))) (car (partsplit '("00") a)))) ""))) l2))
  113.          (setq l4 (vl-remove nil (mapcar (function (lambda (a b) (if (and b (/= b "")) (cons (car a) b)))) l1 l3)))
  114.          )
  115.         ((partmember '("75" "6E" "69" "66" "6F" "6E" "74") l) ;_*unifont*
  116.          ;|
  117.          (setq l (partmember '("0D"   "0A"  "1A") l)
  118.                l (cdddr l)
  119.                asn (ss-bas2dec 16 (strcat (cadr l) (car l)));_Index numbers
  120.                l (cddr l)
  121.                ifn (ss-bas2dec 16 (strcat (cadr l) (car l)));_Index begining code
  122.                l (cddr l))
  123.          (repeat ifn
  124.            (setq l (cdr l)))|;
  125.          (prompt "\n *** No support unifont ***")        
  126.          )
  127.         ((partmember '("62" "69" "67" "66" "6F" "6E" "74") l) ;_bigfont
  128.           ;|
  129.          (setq l (cdddr (partmember '("0D"   "0A"  "1A") l))
  130.                sn (ss-bas2dec 16 (strcat (cadr l) (car l)));_Single Index bytsnum
  131.                l (cddr l)
  132.                asn (ss-bas2dec 16 (strcat (cadr l) (car l)));_Index numbers
  133.                l (cddr l)
  134.                cin (ss-bas2dec 16 (strcat (cadr l) (car l)));_change IndexCode numbers
  135.                l (cddr l)
  136.                stp (ss-bas2dec 16 (strcat (cadr l) (car l)));_Index begining code
  137.                etp (ss-bas2dec 16 (strcat (cadddr l) (caddr l)));_Index ending code
  138.                l (cddddr l)            
  139.                )       
  140.          (repeat asn
  141.            (setq a (list (ss-bas2dec 16 (strcat (cadr l) (car l)));_Index numbers
  142.                                 (ss-bas2dec 16 (strcat (cadddr l) (caddr l)));_shape byts
  143.                          )
  144.                  l (cddddr l)
  145.                  b nil)
  146.            (repeat (- sn 4)
  147.              (setq b (cons (car l) b)
  148.                    l (cdr l)))
  149.            (setq b (ss-bas2dec 16 (apply (function strcat) b)));_AbsAddress offset
  150.            (setq a (append a (list b)))
  151.            (if (not (equal '(0 0 0) a));_check effect .
  152.              (setq l1 (cons a l1))))
  153.          (setq l1 (reverse l1))
  154.          (setq i 0)
  155.          (repeat (length l1)
  156.            (setq a (nth i l1)
  157.                  n (cadr a)
  158.                  b nil)
  159.            (repeat n
  160.              (setq b (cons (car l) b)
  161.                    l (cdr l)))
  162.            (setq l2 (cons (reverse b) l2)
  163.                  i (1+ i)))
  164.          (setq l2 (reverse l2))
  165.          ;_(princ (length l2))
  166.          (setq l3 (mapcar (function (lambda (a) (if (/= (car a) "00")  (vl-list->string (mapcar (function(lambda (a) (ss-bas2dec 16 a))) (car (partsplit '("00") a)))) ""))) l2))
  167.          (setq l4 (vl-remove nil (mapcar (function (lambda (a b) (if (and b (/= b "")) (cons (car a) b)))) l1 l3)))|;
  168.          (prompt "\n *** No support bigfont ***")
  169.          )))
  170. ;;;-------------------------------------
  171. ;;; search part of list
  172. (defun partmember (l1 l / is)
  173.   ;; l1 -- part of list
  174.   ;; l  -- a list
  175.   (setq is T)
  176.   (while (and is l (setq l (member (car l1) l)))    
  177.     (if (vl-every (function equal) l1 l) (setq is nil)))
  178.   (if (and (not is) l)  l))
  179.  
  180. ;;; split a list by part of it
  181. (defun partsplit (l1 l / n l2 ret)
  182.   ;; l1 -- part of list
  183.   ;; l  -- a list
  184.   (setq n (length l1))
  185.   (while l    
  186.     (if (and (equal (car l) (car l1))
  187.              (vl-every (function equal)l1 l))
  188.       (progn
  189.         (if l2 (setq ret (cons (reverse l2) ret)
  190.                      l2 nil))
  191.         (repeat n
  192.           (setq l (cdr l))))
  193.       (setq l2 (cons (car l) l2)
  194.             l (cdr l))))
  195.   (if l2 (setq ret (cons (reverse l2) ret)))
  196.   (reverse ret))
  197. ;;; bas string 2 dec
  198. (defun ss-bas2dec (bas str / pos i e tmp)
  199.   (setq pos (1+ (strlen str))
  200.            i   -1
  201.            e   0
  202.            str  (strcase str))
  203.   (while (> (setq pos (1- pos)) 0)
  204.     (setq e
  205.            (+
  206.              e
  207.              (* (if (> (setq tmp (ascii (substr str pos 1))) 64)
  208.                   (- tmp 55)
  209.                   (- tmp 48))
  210.                 (expt bas (setq i (1+ i))))))))
  211. ;;; dec 2 bas string
  212. (defun ss-dec2bas (bas val / res tmp)
  213.   (setq res "")
  214.   (while (> val 0)
  215.     (setq res (strcat (if (> (setq tmp (rem val bas)) 9)
  216.                            (chr (+ tmp 55))
  217.                            (itoa tmp))
  218.                          res)
  219.           val    (fix (/ val bas))))
  220.   res)
  221.  

chlh_jd

  • Guest
Re: Revisit Alan's MakeEntMake.lsp Routine
« Reply #7 on: May 04, 2014, 11:24:45 AM »
New Version :
Code: [Select]
;;; ------------------- 5.4,2014
;;;  1. change table create order : Style --> LineType --> Layer --> Dimstyle(if use block create it first) --> Block
;;;  2. create linetype file in first support filepath , support embeded shape linetype (if it's shape.shx can be found) .
;;;     And reload linetype file into new emperty dwg.
;;; 
;;;  Notice : It just use in a new emperty dwg's modelspace .
;;; 
It need you more test ,  thank you for any suggest .

chlh_jd

  • Guest
Re: Revisit Alan's MakeEntMake.lsp Routine
« Reply #8 on: May 04, 2014, 11:36:05 AM »
Demo