Topic: Making blocks using LISP

[squirreldip]

I've been using this program for many years and though it may be useful for others.

The problem is needing to remember to include blocks for your programs to use.  I have a number of Civil Transportation design tools that require certain blocks in order to run - these blocks always seem to go missing.  To solve the problem I have two routines.  First is MAKEENT which can be called within other routines which will create the block entities via entmake.

Second is a routine WBlockList to create a text file formatted such that it can be cut/past between the (progn ...) and then change the "PROTOTYPE" to whatever you want to identify the block.

WBlockList is only used when new blocks are needing to be added to MakeEnt - MakeEnt is added to my vlx project.  I will do a TBLSEARCH to see if the block already exists in the drawing and if not call (MAKENT "BlockName").

Code - Auto/Visual Lisp: [Select]

1. ;
2. ;
3. ;     Program written by Robert Livingston, 2002-10-21
4. ;
5. ;     MAKEENT is a utility for creating blocks within lisp
6. ;
7. ;
8. (defun MAKEENT (BLKNAME / )
9.  (cond ((= (strcase BLKNAME) "PROTOTYPE")
10.         (progn
11.  
12.  
13.         )
14.        )
15.        ((= (strcase BLKNAME) "PROTOTYPE")
16.         (progn
17.  
18.  
19.         )
20.        )
21.        ((= (strcase BLKNAME) "PROTOTYPE")
22.         (progn
23.  
24.  
25.         )
26.        )
27.        (T
28.         (progn
29.          (alert (strcat "!!! BLOCK DOES NOT EXIST - " BLKNAME " !!!"))
30.         )
31.        )
32.  )
33. )

Code - Auto/Visual Lisp: [Select]

1. ;
2. ;
3. ;     Program written by Robert Livingston, 2002/10/18
4. ;
5. ;     WBLOCKLIST writes lisp code to create a selected block
6. ;
7. ;
8. (defun C:WBLOCKLIST (/ *error* BLOCKNAME CMDECHO CODE DIMZIN ENT ENTLIST NODE OUTFILE VAL)
9.  (setq CMDECHO (getvar "CMDECHO"))
10.  (setvar "CMDECHO" 0)
11.  (setq DIMZIN (getvar "DIMZIN"))
12.  (setvar "DIMZIN" 8)
13.  
14.  (defun *error* (msg)
15.   (if (/= nil OUTFILE) (close OUTFILE))
16.   (setvar "CMDECHO" CMDECHO)
17.   (setvar "DIMZIN" DIMZIN)
18.   (setq *error* nil)
19.   (princ msg)
20.  )
21.  
22.  (if (/= nil (setq ENT (car (entsel "\nSelect block : "))))
23.   (if (= "INSERT" (cdr (assoc 0 (setq ENTLIST (entget ENT)))))
24.    (if (/= nil (setq OUTFILE (getfiled "Select a block file" "" "" 1)))
25.     (progn
26.      (setq OUTFILE (open OUTFILE "a"))
27.      (princ "         (entmake)\n" OUTFILE)
28.      (princ "         (entmake\n" OUTFILE)
29.      (princ "          (list\n" OUTFILE)
30.      (setq ENTLIST (tblsearch "BLOCK" (cdr (assoc 2 ENTLIST))))
31.      (setq ENT (cdr (assoc -2 ENTLIST)))
32.      (while (/= nil ENTLIST)
33.       (setq NODE (car ENTLIST))
34.       (setq ENTLIST (cdr ENTLIST))
35.       (setq CODE (car NODE))
36.       (if (and (>= CODE 0) (<= CODE 100) (/= CODE 5))
37.        (if (= (vl-list-length NODE) nil)
38.         (progn
39.          (princ
40.           (strcat "           (cons "
41.                   (itoa CODE)
42.                   " "
43.                   (if (numberp (cdr NODE))
44.                    (rtos (cdr NODE) 2 8)
45.                    (strcat "\"" (cdr NODE) "\"")
46.                   )
47.                   ")\n"
48.           )
49.           OUTFILE
50.          )
51.         )
52.         (progn
53.          (princ "           (list" OUTFILE)
54.          (foreach VAL NODE (princ " " OUTFILE)
55.                            (if (numberp VAL)
56.                                (princ (rtos VAL 2 8) OUTFILE)
57.                                (princ (strcat "\"" VAL "\"") OUTFILE)
58.                            )
59.          )
60.          (princ ")\n" OUTFILE)
61.         )
62.        )
63.       )
64.      )
65.  
66.      (princ "          )\n" OUTFILE)
67.      (princ "         )\n" OUTFILE)
68.  
69.      (while (/= ENT nil)
70.       (setq ENTLIST (entget ENT))
71.       (setq ENT (entnext ENT))
72.       (princ "         (entmake\n" OUTFILE)
73.       (princ "          (list\n" OUTFILE)
74.       (while (/= ENTLIST nil)
75.        (setq NODE (car ENTLIST))
76.        (setq ENTLIST (cdr ENTLIST))
77.        (setq CODE (car NODE))
78.        (if (and (>= CODE 0) (<= CODE 100) (/= CODE 5))
79.         (if (= (vl-list-length NODE) nil)
80.          (progn
81.           (princ
82.            (strcat "           (cons "
83.                    (itoa CODE)
84.                    " "
85.                    (if (numberp (cdr NODE))
86.                     (rtos (cdr NODE) 2 8)
87.                     (strcat "\"" (cdr NODE) "\"")
88.                    )
89.                    ")\n"
90.            )
91.            OUTFILE
92.           )
93.          )
94.          (progn
95.           (princ "           (list" OUTFILE)
96.           (foreach VAL NODE (princ " " OUTFILE)
97.                             (if (numberp VAL)
98.                                 (princ (rtos VAL 2 8) OUTFILE)
99.                                 (princ (strcat "\"" VAL "\"") OUTFILE)
100.                             )
101.           )
102.           (princ ")\n" OUTFILE)
103.          )
104.         )
105.        )
106.       )
107.       (princ "          )\n" OUTFILE)
108.       (princ "         )\n" OUTFILE)
109.      )
110.      (princ "         (entmake (list (cons 0 \"ENDBLK\")))\n" OUTFILE)
111.  
112.      (close OUTFILE)
113.     )
114.    )
115.    (princ "\n*** Entity not a block ***")
116.   )
117.  )
118.  
119.  (setvar "CMDECHO" CMDECHO)
120.  (setvar "DIMZIN" DIMZIN)
121. )

[roy_043]

In Line 27 of the 2nd code block you call entmake without an argument. I didn't know you could do that, but what is that line for?

[squirreldip]

In Line 27 of the 2nd code block you call entmake without an argument. I didn't know you could do that, but what is that line for?

This is old code...  I believe it was used to clear memory - resetting the entmake so to speak.  May not be necessary now so that line can probable be removed.

[Lee Mac]

In Line 27 of the 2nd code block you call entmake without an argument. I didn't know you could do that, but what is that line for?

From the dev docs:

No portion of a complex entity is displayed on your drawing until its definition is complete. The entity does not appear in the drawing database until the final SEQEND or ENDBLK subentity has been passed to entmake. The entlast function cannot retrieve the most recently created subentity for a complex entity that has not been completed. You can cancel the creation of a complex entity by entering entmake with no arguments. This clears the temporary file and returns nil.

So effectively similar to calling (command) to cancel any running commands.

[roy_043]

Thanks guys.

[squirreldip]

Expanding on this idea and using code from:
http://www.theswamp.org/index.php?topic=17465.0

I've started using the code below to create missing files (i.e. support dll, sld/slb etc).

FILE2BINARY is used to create a text file which can be cut/pasted into MAKEXXX.  MAKEXXX can be renamed and added into the vlx project.  Obviously the vlx increases in size substantially but now I no longer have to ensure I include the additional files (nor ensure they are in searchable paths).

The file will be broken into 64x64 chunks - I had compile errors when trying to use entire files in a vlx.

It uses FILE as in input as I'm using it in conjunction with (vl-filename-mktemp)...  Routines can search for files like slide libraries and if not found can create them temporarily.

Code - Auto/Visual Lisp: [Select]

1. ;
2. ;
3. ;     Program written by Robert Livingston, 2015-07-21
4. ;
5. ;     FILE2BINARY is a routine to create hex codes from a file to be used in MAKExxx.lsp
6. ;
7. ;
8. (defun C:FILE2BINARY (/ *error* C1 C2 CODE FILE FILEBINARY FLAG OUTFILE _ReadStream)
9.  (defun *error* (msg)
10.   (close OUTFILE)
11.   (setq *error* nil)
12.   (print msg)
13.  )
14.  (defun _ReadStream ( path len / fso file stream result )
15.  
16.      ;;  If the file is successful read the data is returned as
17.      ;;  a string. Won't be tripped up by nulls, control chars
18.      ;;  including ctrl z (eof marker). Pretty fast (feel free
19.      ;;  to bench mark / compare to alternates).
20.      ;;
21.      ;;  If the caller wants the result as a list of byte values
22.      ;;  simply use vl-string->list on the result:
23.      ;;
24.      ;;      (setq bytes
25.      ;;          (if (setq stream (_ReadStream path len))
26.      ;;              (vl-string->list stream)
27.      ;;          )
28.      ;;      )            
29.      ;;
30.      ;;  Arguments:
31.      ;;
32.      ;;      path  <duh>
33.      ;;      len   Number of bytes to read. If non numeric, less
34.      ;;            than 1 or greater than the number of bytes in
35.      ;;            the file everything is returned.
36.    
37.      (vl-catch-all-apply
38.         '(lambda ( / iomode format size )
39.              (setq
40.                  iomode   1 ;; 1 = read, 2 = write, 8 = append
41.                  format   0 ;; 0 = ascii, -1 = unicode, -2 = system default
42.                  fso      (vlax-create-object "Scripting.FileSystemObject")
43.                  file     (vlax-invoke fso 'GetFile path)
44.                  stream   (vlax-invoke fso 'OpenTextFile path iomode format)
45.                  size     (vlax-get file 'Size)
46.                  len      (if (and (numberp len) (< 0 len size)) (fix len) size)
47.                  result   (vlax-invoke stream 'read len)
48.              )
49.              (vlax-invoke stream 'Close)
50.          )
51.      )
52.    
53.      (if stream (vlax-release-object stream))
54.      (if file (vlax-release-object file))
55.      (if fso (vlax-release-object fso))
56.    
57.      result
58.  
59.  )
60.  (setq FLAG "w")
61.  (setq FILE (getfiled "Select a file" "" "" 4))
62.  (setq FILEBINARY (vl-string->list (_ReadStream FILE T)))
63.  (setq OUTFILE (open (getfiled "Select a file to write" "" "txt" 1) "w"))
64.  (while (/= nil FILEBINARY)
65.   (princ " (_WriteStream FILE (vl-list->string (list " OUTFILE)
66.   (setq C1 0)
67.   (while (and (/= nil FILEBINARY) (< C1 64))
68.    (setq C1 (+ C1 1))
69.    (setq C2 0)
70.    (while (and (/= nil FILEBINARY) (< C2 64))
71.     (setq C2 (+ C2 1))
72.     (setq CODE (car FILEBINARY))
73.     (setq FILEBINARY (cdr FILEBINARY))
74.     (princ (itoa CODE) OUTFILE)
75.     (if (>= CODE 100)
76.      (princ " " OUTFILE)
77.      (if (>= CODE 10)
78.       (princ "  " OUTFILE)
79.       (princ "   " OUTFILE)
80.      )
81.     )
82.    )
83.    (princ "\n                                           " OUTFILE)
84.    (setq C2 0)
85.   )
86.   (princ (strcat ")) \"" FLAG "\")\n") OUTFILE)
87.   (setq FLAG "a")
88.  )
89.  (close OUTFILE)
90. )

and

Code - Auto/Visual Lisp: [Select]

1. (defun MAKEXXX (FILE / C FILEBINARY _WriteStream)
2.  (defun _WriteStream ( path text mode / fso stream file result )
3.  
4.      ;;  Return the file size if the file is successfully written
5.      ;;  to, otherwise nil. Will write all ascii chars to file
6.      ;;  including nulls. If the caller wants to pass a list of
7.      ;;  byte values to the function just call it like so:
8.      ;;
9.      ;;      (_WriteStream
10.      ;;          path
11.      ;;          (vl-list->string '(87 111 111 116 33))
12.      ;;          mode
13.      ;;      )
14.      ;;
15.      ;;  Arguments:
16.      ;;
17.      ;;      path  <duh>
18.      ;;      text  <duh>
19.      ;;      mode  "a" to create/append,
20.      ;;            "w" to create/overwrite (default)
21.    
22.      (setq mode (if (member mode '("a" "A")) "a" "w"))
23.    
24.      (vl-catch-all-apply
25.         '(lambda ( / format )
26.              (setq fso (vlax-create-object "Scripting.FileSystemObject"))
27.              (cond
28.                  (   (or (null (findfile path)) (eq "w" mode))
29.                      (setq stream
30.                          (vlax-invoke
31.                              fso
32.                             'CreateTextFile
33.                              path
34.                             -1 ;; 0 (false) = don't overwrite , -1 (true) = overwrite
35.                              0 ;; 0 (false) = ascii, -1 (true) = unicode
36.                          )
37.                      )
38.                      (setq file (vlax-invoke fso 'GetFile path))
39.                  )
40.                  (   (setq file (vlax-invoke fso 'GetFile path))
41.                      (setq stream
42.                          (vlax-invoke
43.                              file
44.                             'OpenAsTextStream
45.                              8 ;; 1 = read, 2 = write, 8 = append
46.                              0 ;; 0 = ascii, -1 = unicode, -2 system default
47.                          )
48.                      )      
49.                  )
50.              )
51.              (vlax-invoke stream 'Write text)
52.              (vlax-invoke stream 'Close)
53.              (setq result (vlax-get file 'Size))
54.          )
55.      )
56.  
57.      (if file (vlax-release-object file))
58.      (if stream (vlax-release-object stream))
59.      (if fso (vlax-release-object fso))
60.    
61.      result
62.    
63.  )
64.  ;--------------------------------- PASTE CODE HERE ---------------------------------
65.  
66.  
67.  
68.  
69.  ;--------------------------------- PASTE CODE HERE ---------------------------------
70. )