home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p024 / 5.img / R11SUPP.EXE / XDATA.LSP < prev    next >
Encoding:
Text File  |  1990-09-11  |  16.1 KB  |  480 lines
  1. ;;;---------------------------------------------------------------------------;
  2. ;;;
  3. ;;;   XDATA.LSP   Version 1.0
  4. ;;;
  5. ;;;   Copyright (C) 1990 by Autodesk, Inc.
  6. ;;;  
  7. ;;;   Permission to use, copy, modify, and distribute this software and its
  8. ;;;   documentation for any purpose and without fee is hereby granted.  
  9. ;;;
  10. ;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED WARRANTY. 
  11. ;;;   ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR PURPOSE AND OF 
  12. ;;;   MERCHANTABILITY ARE HEREBY DISCLAIMED.
  13. ;;;   
  14. ;;;   by Kieran V. McKeogh, Brad Zehring
  15. ;;;   5 March 1990
  16. ;;;   
  17. ;;;---------------------------------------------------------------------------;
  18. ;;;  DESCRIPTION
  19. ;;;
  20. ;;;   XDATA
  21. ;;;
  22. ;;;   Program that attaches extended data types to a selected entity.  
  23. ;;;
  24. ;;;   After selecting an entity and entering an application name for the 
  25. ;;;   extended data, the following types of extended data are prompted for:
  26. ;;;
  27. ;;;    1)  An ASCII string up to 255 bytes long (group code 1000).
  28. ;;;    2)  A layer name (group code 1003).
  29. ;;;    3)  An entity handle (group code 1005).
  30. ;;;    4)  3 real numbers (group code 1010).
  31. ;;;    5)  A 3D World space position (group code 1011).
  32. ;;;    6)  A 3D World space displacement (group code 1012).
  33. ;;;    7)  A 3D World space direction (group code 1013).
  34. ;;;    8)  A real number (group code 1040).
  35. ;;;    9)  A distance (group code 1041).
  36. ;;;   10)  A scale factor (group code 1042).
  37. ;;;   11)  A 16-bit integer (group code 1070).
  38. ;;;   12)  A 32-bit signed long integer (group code 1071).
  39. ;;;
  40. ;;;   Numbers 5, 6, 7, 9 and 10 are "transformable" data types, and
  41. ;;;   are either moved, scaled, rotated or mirrored along with the parent
  42. ;;;   entity, or possibly some combination of these, depending on the
  43. ;;;   group code and the nature of the operation on the parent entity.
  44. ;;;
  45. ;;;   Binary data chunks (group code 1004) are not supported. 
  46. ;;;
  47. ;;;
  48. ;;;   XDLIST
  49. ;;;
  50. ;;;   Program that lists the Xdata associated with an application for the
  51. ;;;   selected entity.
  52. ;;; 
  53. ;;;   For a complete description of extended data types see the "AutoCAD 
  54. ;;;   Reference Manual."
  55. ;;;
  56. ;;;---------------------------------------------------------------------------;
  57.  
  58.  
  59. ;;;---------------------------------------------------------------------------;
  60. ;;; Internal error handling.
  61. ;;;---------------------------------------------------------------------------;
  62.  
  63. (defun xdataerr(s)
  64.   (if (/= s "Function cancelled")
  65.     (princ (strcat "\nError: " s))
  66.   )
  67.   (setq *error* olderr) 
  68.   (if ename (redraw ename 4))         ; de-highlight entity
  69.   (princ)
  70. )
  71.  
  72. ;;;---------------------------------------------------------------------------;
  73. ;;; Get user input.
  74. ;;;---------------------------------------------------------------------------;
  75.  
  76. (defun getinput (/ cont esel)
  77.  
  78.   ;; Forces selection of an entity and sets ename to the name of the  
  79.   ;; selected entity.
  80.  
  81.   (while
  82.     (not (setq esel (entsel)))
  83.   )
  84.             
  85.   (if (= which 1)                     ; If XDATA() is happening...
  86.     (progn
  87.       (setq ename (car esel))         ; Get entity info...
  88.       (redraw ename 3)                ; ...highlight entity
  89.       (setq elist (entget ename (list "*"))) ; ...including xdata for all 
  90.                                       ; registered applications.    
  91.             
  92.       ;; Force the entry of a registered application name (group code 1001).
  93.    
  94.       (setq cont T)
  95.       (while cont 
  96.         (setq rname (strcase (getstring "\nApplication name: ")))
  97.         (if (/= rname "") 
  98.           (setq cont nil)
  99.         )
  100.       )
  101.     )
  102.   )
  103.   (if (= which 2)                     ; If XDPRINT() is happening...
  104.     (progn                           
  105.       (setq ename (car esel))         ; Get entity info
  106.       (redraw ename 3)                ; ...highlight entity  
  107.       (setq rname (strcase (getstring "\nApplication name <*>: ")))
  108.       (if (= rname "")                ; If null input, get all.
  109.         (setq rname "*")
  110.       )                   
  111.       (setq elist (entget ename (list rname))) 
  112.     ) 
  113.   )
  114. )
  115.  
  116. ;;;---------------------------------------------------------------------------;
  117. ;;; Get user values for extended entity data and build XD_LIST.
  118. ;;;---------------------------------------------------------------------------;
  119.  
  120. (defun getdata (/ xd_type)
  121.  
  122.   (setq xflag 0)
  123.  
  124.   ;; Check whether the selected entity has some extended data already.
  125.  
  126.   (if (assoc -3 elist)
  127.     (progn
  128.       (setq size_old (xdsize (assoc -3 elist)))
  129.       (princ "\nEntity has ") 
  130.       (princ size_old )
  131.       (princ " bytes of Xdata - new Xdata will be appended.\n")
  132.     )
  133.   )
  134.  
  135.   (setq xd_list (list '(1002 . "}"))) ; Initialize list of xdata for this app.
  136.  
  137.   (setq xd_type T)                    ; Initialize loop terminator.
  138.  
  139.   (while (not (or (eq xd_type "EXit") (eq xd_type "Xit") (eq xd_type nil)))
  140.     (setq hand (getvar "handles"))
  141.     (initget                          ; Initialize keyword list.
  142.       (strcat "STring LAyer 3Real Position DISPlacement Handle"
  143.             " DIRection Real DISTance SCale"
  144.             " Integer LOng EXit Xit"
  145.  
  146.       )
  147.     )     
  148.     
  149.     (setq xd_type (getkword (strcat   ; Prompt user to select keyword.
  150.        "\n3Real/DIR/DISP/DIST/Hand/Int/LAyer/LOng/Pos/Real/SCale/STr/<eXit>: "))
  151.     )
  152.  
  153.     ;; Add sub-list to xdata list.
  154.  
  155.     (cond
  156.       ((eq xd_type "3Real")
  157.         (if (/= (setq input (getpoint "\n3 real numbers: ")) nil)  
  158.            (setq xd_list (cons (cons 1010 input) xd_list))
  159.         )    
  160.       )
  161.       ((eq xd_type "DIRection")
  162.         (if (/= (setq input (getpoint "\n3D World space direction: ")) nil)
  163.           (setq xd_list (cons (cons 1013 input) xd_list))
  164.         )      
  165.       )
  166.       ((eq xd_type "DISPlacement")
  167.         (if (/= (setq input (getpoint "\n3D World space displacement: ")) nil)  
  168.           (setq xd_list (cons (cons 1012 input) xd_list))
  169.         )
  170.       )
  171.       ((eq xd_type "DISTance")
  172.         (if (/= (setq input (getdist "\nDistance: ")) nil) 
  173.           (setq xd_list (cons (cons 1041 input) xd_list))
  174.         )
  175.       )
  176.       ((eq xd_type "Handle")
  177.         (if (or ( = (setq hand (getstring "\nDatabase handle: ")) "0")
  178.                 (handent hand) 
  179.             )
  180.           (setq xd_list (cons (cons 1005 hand) xd_list))
  181.           (if (/= hand "") 
  182.             (princ "\nInvalid handle - handle must exist or have a 0 value.")
  183.           )
  184.         )         
  185.       )
  186.       ;; Values entered greater than 32767 cause AutoLISP to issue an
  187.       ;; error message stating "Value must be between -32767 and 32767. "
  188.       ;; Values less than 0 are trapped out by the (initget).  Though the 
  189.       ;; message may be confusing, the values are always correct.  This is
  190.       ;; an AutoLISP limitation.
  191.       ((eq xd_type "Integer")
  192.         (initget 4)
  193.         (if (/= (setq input (getint "\n16-bit integer: ")) nil)
  194.           (setq xd_list (cons (cons 1070 input) xd_list))
  195.         )
  196.       )  
  197.       ((eq xd_type "LAyer")
  198.         (setq input (getstring "\nLayer name: "))
  199.         (if (tblsearch "layer" input)
  200.           (setq xd_list (cons (cons 1003 input) xd_list))
  201.           (if (/= input "")
  202.             (princ "\nInvalid layer name - layer must exist.")
  203.           )
  204.         ) 
  205.       )
  206.       ((eq xd_type "LOng")
  207.         (if (/= (setq input (getint "\n32-bit signed long integer: ")) nil)
  208.           (setq xd_list (cons (cons 1071 input) xd_list))
  209.         )
  210.       )
  211.       ((eq xd_type "Position")
  212.         (if (/= (setq input (getpoint "\n3D World space position: ")) nil) 
  213.           (setq xd_list (cons (cons 1011 input) xd_list))
  214.         )    
  215.       )
  216.       ((eq xd_type "Real")
  217.         (if (/= (setq input (getreal "\nReal number: ")) nil) 
  218.           (setq xd_list (cons (cons 1040 input) xd_list))
  219.         ) 
  220.       )
  221.       ((eq xd_type "SCale")
  222.         (if (/= (setq input (getreal "\nScale factor: ")) nil)
  223.           (setq xd_list (cons (cons 1042 input) xd_list))
  224.         )
  225.       )
  226.       ((eq xd_type "STring")
  227.         (setq xd_list (cons (cons 1000 (getstring T 
  228.           "\nASCII string: ")) xd_list))
  229.       )
  230.       (t)
  231.     )
  232.   )
  233.  
  234.   ;; Was any xdata entered besides a registered application name ??
  235.  
  236.   (setq xflag (length xd_list))
  237.  
  238.   ;; Append opening brace to front of xdata list.
  239.  
  240.   (setq xd_list (cons '(1002 . "{") xd_list))
  241.  
  242.   ;; Append application name to front of xdata list.
  243.  
  244.   (setq xd_list (cons rname xd_list))
  245.  
  246.   ;; Append -3 group code to front of list containing xdata list.
  247.  
  248.   (setq xd_list (list -3 xd_list))
  249. )
  250.  
  251.  
  252. ;-----------------------------------------------------------------------------;
  253. ; XDATA
  254. ;-----------------------------------------------------------------------------;
  255.  
  256. (defun c:xdata (/ all elist ename old olderr new rname size_newedent xd_list
  257.                   xd_list1 xd_list2 xd_list3 xflag)
  258.  
  259.   
  260.  
  261.   (setq olderr *error*                ; Use special error handling function.
  262.         *error* xdataerr)
  263.  
  264.   (setq which 1)                      ; Flag for (getinput)  
  265.  
  266.   (setq regflag 0)                    ; Regapp flag.
  267.  
  268.   (getinput)                          ; Prompt for user input
  269.  
  270.   (redraw ename 4)                    ; De-highlight entity 
  271.  
  272.     
  273.  
  274.   (if (regapp rname)                  ; Register the application name.
  275.     (princ (strcat "\n" rname " new application.\n"))
  276.     (princ (strcat "\nApplication " rname " already registered.\n"))
  277.   )
  278.  
  279.   ;; Prompt for user values for xdata and build xdata list XD_LIST.
  280.  
  281.   (getdata)
  282.  
  283.   ;; The extended data list is now added to the entity data.  This is a
  284.   ;; little more involved if the entity already has extended data.  A check
  285.   ;; of available Xdata space must be made too.
  286.  
  287.   (if (< size_new (xdroom ename))     ; If there is room for more...
  288.     (progn     
  289.       (if (assoc -3 elist)            ; and contains xdata already...
  290.         (progn                                            
  291.           (setq xd_list (cdr xd_list)) ; New xdata.
  292.           (setq xd_ent (cdr (assoc -3 elist))) ; Old xdata.
  293.           ;; Find old xdata with same regapp
  294.           (if (setq old (cddr (assoc rname xd_ent))) 
  295.             (progn                                    
  296.               (setq regflag 1)              
  297.               (setq new (cdr (reverse (cddr (assoc rname xd_list)))))
  298.               (setq all (append new old)) ; Join old and new xdata with 
  299.                                       ; same application name.
  300.               (setq xd_list1 (cons (cons 1002 "{") all)) ; Add open curly
  301.               (setq xd_list2 (cons rname xd_list1)) ; Add regapp
  302.              
  303.               ;; Substitute back into existing xdata list.
  304.              
  305.               (setq xd_list3 (subst xd_list2 (assoc rname xd_ent) 
  306.                                              (assoc -3 elist))) 
  307.            )
  308.             (progn                    ; This is a new regapp...
  309.               (setq xd_list (append xd_ent xd_list)) ; Joins xdata.
  310.               (setq xd_list3 (cons -3 xd_list))
  311.             )
  312.           )
  313.           (setq elist (subst xd_list3 (assoc -3 elist) elist)) ; Joins entity
  314.         )  
  315.         (setq elist (cons xd_list elist)) ; No xdata yet.
  316.       )
  317.       
  318.     )
  319.     (princ (strcat "\nInsufficient Xdata space available on entity"
  320.                    "- no new Xdata appended.")
  321.     )
  322.   )
  323.  
  324.   ;; Finally update the entity in the database to contain the new xdata.
  325.  
  326.   (if (entmod elist)     
  327.     (if (and (= 1 regflag) (<= xflag 1))   ; old application name     
  328.       (princ "\nNo xdata appended.")  
  329.       (princ "\nNew xdata appended.") 
  330.     )
  331.   )
  332.  
  333.   (setq *error* olderr)               ; Reset the error function.
  334.   (redraw ename 4)                    ; Dehighlight entity.
  335.  
  336.   (prin1)
  337. )
  338.  
  339. ;;;---------------------------------------------------------------------------;
  340. ;;;  XDLIST
  341. ;;;---------------------------------------------------------------------------;
  342.  
  343. (defun C:XDLIST (/ linecount xd_list app_list app_sub_list xd_code
  344.         xd_data )
  345.  
  346.   (setq olderr *error*                ; Redefine error handler.
  347.         *error* xdataerr)
  348.  
  349.   (setq which 2)                      ; Flag for (getinput)
  350.  
  351.   (getinput)                          ; Get user input. 
  352.  
  353.   (redraw ename 4)                    ; De-highlight entity.
  354.  
  355.   ;; See if there's any xdata in the selected entity associated with the
  356.   ;; application name.
  357.  
  358.   (if (not (setq xd_list (assoc -3 elist)))
  359.     (progn  
  360.       (princ "\nNo Xdata associated with Application Name(s).")
  361.     )
  362.     (setq xd_list (cdr xd_list))      ; Strip -3 from xd_list
  363.   )
  364.  
  365.   (setq linecount 0)                  ; # of lines printed
  366.  
  367.   (while xd_list                      ; There's any xdata left...
  368.     (setq app_list (car xd_list))           
  369.     (textscr)
  370.     (princ "\n\n* Registered Application Name: ")
  371.     (princ (car app_list))
  372.     (setq app_list (cdr app_list))    ; Strip app name
  373.     (while app_list
  374.       (setq app_sub_list (car app_list))  ; Get sub list
  375.       (setq xd_code (car app_sub_list))   ; Get group code
  376.       (setq xd_data (cdr app_sub_list))   ; Get data
  377.  
  378.       ;; Conditions for all group codes.
  379.       ;; Prints 'em all except binary chunks.
  380.       (cond
  381.         ((= 1000 xd_code)
  382.           (princ "\n* Code 1000, ASCII string: ")
  383.           (princ xd_data)
  384.         )
  385.         ((= 1001 xd_code)
  386.           (princ "\n* Code 1001, Registered application name: ")
  387.           (princ xd_data)
  388.         )
  389.         ((= 1002 xd_code)
  390.           (princ "\n* Code 1002, Starting or ending brace: ")
  391.           (princ xd_data)
  392.         )
  393.         ((= 1003 xd_code)
  394.           (princ "\n* Code 1003, Layer name: ")
  395.          (princ xd_data)
  396.         )
  397.         ((= 1004 xd_code)
  398.           (princ "\n* Code 1004, Binary data not printed.")
  399.         )
  400.         ((= 1005 xd_code)
  401.           (princ "\n* Code 1005, Database handle: ")
  402.           (princ xd_data)
  403.         )
  404.         ((= 1010 xd_code)
  405.           (princ "\n* Code 1010, 3 real numbers: ")
  406.           (princ (strcat "("
  407.                  (rtos (car xd_data)) " " 
  408.                  (rtos (cadr xd_data)) " "
  409.                  (rtos (caddr xd_data)) ")"))
  410.         )
  411.         ((= 1011 xd_code)
  412.           (princ "\n* Code 1011, 3D World space position: ")
  413.           (princ (strcat "("
  414.                  (rtos (car xd_data)) " "
  415.                  (rtos (cadr xd_data)) " "
  416.                  (rtos (caddr xd_data)) ")"))
  417.         )
  418.         ((= 1012 xd_code)
  419.           (princ "\n* Code 1012, 3D World space displacement: ")
  420.           (princ (strcat "("
  421.                  (rtos (car xd_data)) " "
  422.                  (rtos (cadr xd_data)) " "
  423.                  (rtos (caddr xd_data)) ")"))
  424.         )
  425.         ((= 1013 xd_code)
  426.           (princ "\n* Code 1013, 3D World space direction: ")
  427.           (princ (strcat "("
  428.                  (rtos (car xd_data)) " "
  429.                  (rtos (cadr xd_data)) " "
  430.                  (rtos (caddr xd_data)) ")"))
  431.         )
  432.         ((= 1040 xd_code)
  433.           (princ "\n* Code 1040, Real number: ")
  434.           (princ (rtos xd_data))
  435.         )
  436.         ((= 1041 xd_code)
  437.           (princ "\n* Code 1041, Distance: ")
  438.           (princ (rtos xd_data))
  439.         )
  440.         ((= 1042 xd_code)
  441.           (princ "\n* Code 1042, Scale factor: ")
  442.           (princ (rtos xd_data))
  443.         )
  444.         ((= 1070 xd_code)
  445.           (princ "\n* Code 1070, 16-bit integer: ")
  446.           (princ xd_data)
  447.         )
  448.         ((= 1071 xd_code)
  449.           (princ "\n* Code 1071, 32-bit signed long integer: ")
  450.           (princ (rtos xd_data 2 0))
  451.         )
  452.         (t 
  453.           (princ "\n* Unknown xdata code: ") 
  454.           (princ xd_code)
  455.           (princ " *")
  456.         )
  457.       )
  458.       (setq app_list (cdr app_list))
  459.       (setq linecount (1+ linecount))
  460.       (if (>= linecount 20)           ; Pause at 20 lines printed.
  461.         (progn
  462.           (getstring "\n-More-")
  463.           (setq linecount 0)
  464.         )
  465.       )
  466.     )  
  467.   (setq xd_list (cdr xd_list))        ; Get next xdata list.
  468. )  
  469.   
  470.  
  471.   (princ "\n\nEntity has ")                     
  472.   (princ (xdroom ename))              ; Figure how much room is left.
  473.   (princ " bytes of Xdata space available.")
  474.  
  475.   (setq *error* olderr)               ; Reset the error function.
  476.   (prin1)                             ; Quiet exit.
  477.  
  478. )
  479.  
  480.