home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1998 November / Dppcpro1198.iso / Nov / Intelcad / Uncompressed / API / LISP / SAMPLE.LSP < prev   
Encoding:
Lisp/Scheme  |  1998-02-19  |  10.2 KB  |  250 lines
  1. ; Sample.lsp
  2. ; Release 1.0   
  3. ; Rick Gardner
  4. ;
  5. ; .............................................................................
  6. ;
  7. ; Copyright (c) 1998 by Visio Corporation.  All rights reserved.
  8. ;
  9. ; The Software is subject to the license agreement that accompanies 
  10. ; or is included with the Software, which specifies the permitted 
  11. ; and prohibited uses of the Software. Any unauthorized duplication 
  12. ; or use of Visio Corporation Software, in whole or in part, in print, 
  13. ; or in any other storage and retrieval system is prohibited.
  14. ; 
  15. ; To the maximum extent permitted by applicable law, Visio Corporation
  16. ; and its suppliers disclaim any and all warranties and conditions,
  17. ; either express or implied, including, without limitation, implied
  18. ; warranties of merchantability, fitness for a particular purpose,
  19. ; title, and non-infringement, and those arising out of usage of trade
  20. ; or course of dealing, concerning these materials.  These materials
  21. ; are provided "as is" without warranty of any kind.
  22. ; .............................................................................
  23.  
  24.  
  25. ;*********************************************************************
  26. ;   CAD DXF TRANSLATOR/WRITER FOR STEPPING THROUGH DRAWING ENTITIES
  27. ;*********************************************************************
  28. (defun c:dxfread ( / picklist ans ent vname ss ckent filnam )
  29.     (setq ans "S")
  30.     (while (and (/= ans "") (/= ans "Q"))
  31.         (if (= ans "V")
  32.             (if (setq vname (eval (read (getstring "\nEnter variable name to use: "))))
  33.                   (progn
  34.                       (if (= (type vname) 'ENAME)
  35.                           (setq ent vname)
  36.                       )
  37.                       (if (= (type vname) 'LIST)
  38.                           (setq ent (cdr (assoc -1 vname)))
  39.                       )
  40.                       (setq picklist (cons ent picklist))
  41.                   )
  42.                   (princ "\n**********Variable name not valid**************")
  43.             )
  44.         )
  45.         (if (= ans "D") (progn
  46.              (setq ss (ssget "X")
  47.                    ckent (ssname ss (- (sslength ss) 1))
  48.              )
  49.              (if (eq ckent ent)
  50.                   (princ "\n********First entity in DWG encountered********")
  51.                   (while ckent
  52.                        (if (eq (entnext ckent) ent)
  53.                             (setq ent ckent
  54.                                   picklist (cons ent picklist)
  55.                                   ckent nil
  56.                             )
  57.                             (setq ckent (entnext ckent))
  58.                        )
  59.                   )
  60.              )
  61.         ))
  62.         (if (= ans "W") (progn
  63.              (setq filnam (getstring "\nEnter name of file to write: "))
  64.              (setq fil (open filnam "w"))
  65.              (princ (strcat "\nCommand is EM to read modified entity data from " filnam " and perform entmake."))
  66.         ))
  67.         (if (= ans "P") (if (setq picklist (cdr picklist))
  68.                                             (setq ent (car picklist))
  69.                                             (princ "\n********Beginning of picklist encountered********")
  70.                                   )
  71.         )
  72.         (if (= ans "N") (if (entnext ent) (progn
  73.                                         (setq ent (entnext ent))
  74.                                         (setq picklist (cons ent picklist))
  75.                                         ) ;progn
  76.                                         (princ "\n********Last entity in DWG encountered********")
  77.                                   )
  78.         )
  79.         (if (= ans "L") (progn
  80.                             (setq ent (entlast))
  81.                             (while (entnext ent) (setq ent (entnext ent)))
  82.                             (setq picklist (cons ent picklist))
  83.         ))
  84.         (if (= ans "S") (progn
  85.                                   (setq ent (car (entsel)))
  86.                                   (if picklist
  87.                                         (setq picklist (cons ent picklist))
  88.                                         (setq picklist (list ent))
  89.                                   ); if
  90.                                   );progn
  91.         )
  92.         (setq elist (entget ent (list "*")))
  93.         (if (not (member (cdr (assoc 0 elist)) '("VERTEX" "ATTRIB" "SEQEND")))
  94.             (redraw ent 3)
  95.         )
  96.         (setq count 1)
  97.         (while (car elist)
  98.             (if (= (caar elist) -3) (progn
  99.                 (setq elist (cdar elist))
  100.                 (while (setq xlist (car elist))
  101.                     (while (car xlist)
  102.                          (if (= ans "W")(progn
  103.                               (prin1 (car xlist) fil)
  104.                               (write-char 10 fil)
  105.                               )(progn
  106.                               (print (car xlist))
  107.                          ))
  108.                          (setq xlist (cdr xlist))
  109.                          (setq count (+ 1 count))
  110.                          ;(if (and (/= ans "W") (> count 23)) (progn
  111.                          ;    (TEXTSCR)
  112.                          ;    (getstring "\nHit enter to continue")
  113.                          ;    (setq count 1)
  114.                          ;))
  115.                     )
  116.                     (setq elist (cdr elist))
  117.                 )
  118.                 (if (car elist)
  119.                     (if (= ans "W") (progn
  120.                          (prin1 (car elist) fil)
  121.                          (write-char 10 fil)
  122.                          )(progn
  123.                          (print (car elist))
  124.                     ))
  125.                 )
  126.             )(progn
  127.                 (if (= ans "W") (progn
  128.                     (prin1 (car elist) fil)
  129.                     (write-char 10 fil)
  130.                     )(progn
  131.                     (print (car elist))
  132.                 ))
  133.             ));progn,if
  134.             (princ)
  135.             (setq count (+ 1 count))
  136.             ;(if (and (/= ans "W") (> count 23)) (progn
  137.             ;    (TEXTSCR)
  138.             ;    (getstring "\nHit enter to continue")
  139.             ;    (setq count 1)
  140.             ;))
  141.             (setq elist (cdr elist))
  142.         )
  143.         (TEXTSCR)
  144.         (if (= ans "W") (close fil))
  145.         (setq ans (strcase (getstring "\nWrite, Next, Select, prev Pick, prev Dwg, Last dwg, Var or Quit? <Q> ")))
  146.     );while
  147.     (GRAPHSCR)
  148.     (redraw)
  149. ) ;defun
  150. (princ "\nDXFREAD loaded")
  151. ;*********************************************************************
  152. ;COMPANION TO PREVIOUS FUNCTION FOR MAKING ENT FROM A FILE
  153. ;*********************************************************************
  154. (defun c:dxfemake ( / )
  155.     (setq filnam (findfile (getstring "\nEnter name of file to read for entmake: ")))
  156.     (if (not filnam) (progn
  157.         (alert (strcat "File " filnam " not found."))
  158.         (quit)
  159.     ))
  160.     (setq elist nil xlist nil)
  161.     (setq fil (open filnam "r"))
  162.     (while (setq ln (read-line fil))
  163.         (if (not (wcmatch ln "*<Entity name:*"))(progn
  164.             (setq ln (read ln))
  165.             (if (and (not xlist) (= (type ln) 'LIST)) ;std cad data
  166.                (if elist (setq elist (cons ln elist))
  167.                    (setq elist (list ln))
  168.                 )
  169.             )
  170.             (if (and xlist (= (type ln) 'STR))(progn  ;not 1st xdata appname
  171.               (setq xlist (reverse xlist))
  172.               (setq xlist (cons (list ln) xlist))
  173.               (setq xlist (reverse xlist))
  174.               (regapp ln)
  175.             ))
  176.             (if (and (not xlist) (= (type ln) 'STR))(progn;1st xdata appname
  177.                (setq xlist (list -3 (list ln)))
  178.                (regapp ln)
  179.             ))
  180.             (if (and xlist (= (type ln) 'LIST))(progn  ;xdata info
  181.                (setq xlist (reverse xlist))
  182.                (setq xlist (cons (reverse (cons ln (reverse (car xlist)))) (cdr xlist)))
  183.                (setq xlist (reverse xlist))
  184.             ))
  185.         ));progn,if
  186.     );while
  187.     (close fil)
  188.     (if xlist (setq elist (cons xlist elist)))
  189.     (setq elist (reverse elist))
  190.     (if (entmake elist)
  191.         (princ (strcat "\nEntmake successful from file " filnam "."))
  192.     (progn
  193.         (princ (strcat "\nEntmake failed from file " filnam ".  ERRNO is: "))
  194.     (princ (getvar "ERRNO"))
  195.     ))
  196.     (princ)
  197. );defun
  198. (princ "\tDXFEMAKE loaded")
  199. ;*********************************************************************
  200. ;FUNCTION TO UPDATE ALL BLOCK DEFINITIONS IN DRAWING
  201. ;*********************************************************************
  202. (defun c:redoblks ( / blist belist rauto)
  203.         (if (setq blist (cdr (assoc 2 (tblnext "BLOCK" T)))) (progn
  204.                 (setq blist (list blist))
  205.                 (while (setq belist (tblnext "BLOCK"))
  206.                         (setq blist (cons (cdr (assoc 2 belist)) blist))
  207.                 )
  208.                 (setq rauto (getvar "regenmode"))
  209.                 (setvar "regenmode" 0)
  210.                 (foreach blk blist
  211.                         (if (findfile (strcat blk ".DWG")) (progn
  212.                             (setq blk (strcat blk "="))
  213.                             (command "insert" blk)
  214.                             (command)
  215.                         ))
  216.                 )
  217.                 (setvar "regenmode" rauto)
  218.                 (COMMAND "REGEN")
  219.                 (PRINC "\nAll block definitions updated.")
  220.         ))
  221.         (princ)
  222. );DEFUN
  223. (princ "\nREDOBLKS loaded")
  224.  
  225. ;*********************************************************************
  226. ;COMMAND TO ECHO BACK BLOCK AND FILE DATA
  227. ;*********************************************************************
  228. (defun c:find ( / filenam gotit count)
  229.     (setq filenam (getstring "\nEnter name and extension (if not .DWG) to locate: "))
  230.     (setq count 1 gotit nil)
  231.     (while (< count (strlen filenam))
  232.         (setq x (substr filenam count 1))
  233.         (if (= x ".") (setq gotit 1))
  234.         (setq count (+ 1 count))
  235.     )
  236.     (if (not gotit) (setq filenam (strcat filenam ".DWG")))
  237.     (if (findfile filenam) (progn
  238.         (princ (strcat "\nFile found file as " (findfile filenam)))
  239.         (if (tblsearch "block" (substr filenam 1 (- (strlen filenam) 4)))
  240.             (princ " and as block in current drawing")
  241.         )
  242.         (princ ".")
  243.         ) ;progn
  244.         (princ (strcat "\nFile " filenam " not found."))
  245.     )
  246. (princ)
  247. );defun
  248. (princ "\tFIND loaded")
  249. (princ)
  250.