[编程交流] 如何创建*。exe文件到

;;HubbardCADInstall
;;Installs the custom Hubbard menus and commands to AutoCAD
;;Copyright 2008 Hubbard Engineering
;;625 N. Gilbert Road Suite 106
;;Gilbert, Arizona  85234
;;heaz dot us
;;Licensed to the public under the terms of the GNU General Public License
;;This is Free Software. For more info read the license at fsf dot org.
(DEFUN C:HCI () (C:HUBBARDCADINSTALL))
(DEFUN
  C:HUBBARDCADINSTALL ()
 ;;Add to or fix Support Files Search Path
 (HUBBARD-UPDATE-SUPPORTPATHS)
 ;;Add to or fix Printer Support File Path\Plot Style Table Search Path
 (HUBBARD-UPDATE-PLOTSTYLE-PATH)
 ;;Add or reload the Hubbard menus
 (HUBBARD-RELOAD-MENUS)
 ;;Exit quietly
 (PRINC)
)
(DEFUN C:HCM () (C:HUBBARDCADMENUS))
(DEFUN C:HUBBARDCADMENUS () (HUBBARD-RELOAD-MENUS))
(DEFUN
  HUBBARD-UPDATE-SUPPORTPATHS (/ NEWUSERPATH)
 (SETQ NEWUSERPATH (STRCAT "R:\\AutoCADUsers\" (HUBBARD-USERNAME)))
 ;;Remove paths
 (REMOVE-SUPPORTPATH "R:\\HawsEDC")
 (REMOVE-SUPPORTPATH "R:\\AutoCADBlocks")
 (REMOVE-SUPPORTPATH "R:\\AutoCADMenu")
 (REMOVE-SUPPORTPATH "R:\\AutoCADSupport")
 (REMOVE-SUPPORTPATH NEWUSERPATH)
 ;;Remove old user path
 (REMOVE-SUPPORTPATH
   (STRCAT "R:\\AutoCADUsers\" (HUBBARD-USERNAME-2008-05))
 )
 ;;Add paths in reverse order at top
 (ADD-SUPPORTPATH "R:\\HawsEDC")
 (ADD-SUPPORTPATH "R:\\AutoCADBlocks")
 (ADD-SUPPORTPATH "R:\\AutoCADMenu")
 (ADD-SUPPORTPATH "R:\\AutoCADSupport")
 (ADD-SUPPORTPATH NEWUSERPATH)
)
(DEFUN
  HUBBARD-UPDATE-PLOTSTYLE-PATH ()
 (VLA-PUT-PRINTERSTYLESHEETPATH
   (VLA-GET-FILES (VLA-GET-PREFERENCES (ACAD-OBJECT)))
   "R:\\AutoCADSupport"
 )
)
(DEFUN
  HUBBARD-RELOAD-MENUS (/ ISALLMENUSREQUESTED ISMENUREMOVED USERINPUT
                        NMENUS HUBBARDMENUS COUNTER GROUP
                       )
 (SETQ
   HUBBARDMENUS
    '("HawsEDC" "CNM" "FunKy" "Hubbard")
   ISALLMENUSREQUESTED NIL
 )
 (FOREACH
    GROUP HUBBARDMENUS
   (SETQ
     COUNTER -1
     ISMENUREMOVED NIL
     NMENUS
      (VLA-GET-COUNT (VLA-GET-MENUGROUPS (ACAD-OBJECT)))
   )
   (COND
     ;;If user gives permission
     ((OR ISALLMENUSREQUESTED
          (PROGN
            (INITGET "Yes No All")
            (/= "No"
                (SETQ
                  USERINPUT
                   (GETKWORD
                     (STRCAT
                       "\nLoad "
                       GROUP
                       " menu? [Yes/No/All] <Yes>: "
                     )
                   )
                )
            )
          )
      )
      (COND ((= USERINPUT "All") (SETQ ISALLMENUSREQUESTED T)))
      ;;1.  Unload the menu if present
      ;;Loop through load menus to find and unload this menu.
      (WHILE (AND
               (< (SETQ COUNTER (1+ COUNTER)) NMENUS)
               (NOT ISMENUREMOVED)
             )
        (COND
          ((= (STRCASE
                (VLA-GET-NAME
                  (VLA-ITEM (VLA-GET-MENUGROUPS (ACAD-OBJECT)) COUNTER)
                )
              )
              (STRCASE GROUP)
           )
           (VLA-UNLOAD
             (VLA-ITEM (VLA-GET-MENUGROUPS (ACAD-OBJECT)) COUNTER)
           )
           (SETQ ISMENUREMOVED T)
          )
        )
      )
      ;;2.  Load the menu.
      (VLA-LOAD
        (VLA-GET-MENUGROUPS (ACAD-OBJECT))
        (FINDFILE (STRCAT GROUP ".mnu"))
      )
     )
   )
 )
)
(DEFUN
  ACAD-OBJECT ()
 (COND
   (*ACAD-OBJECT*)
   (T (SETQ *ACAD-OBJECT* (VLAX-GET-ACAD-OBJECT)))
 )
)
(DEFUN
  ADD-SUPPORTPATH (NEWSTRING / FILES)
 (SETQ FILES (VLA-GET-FILES (VLA-GET-PREFERENCES (ACAD-OBJECT))))
 (VLA-PUT-SUPPORTPATH
   FILES
   (STRCAT NEWSTRING ";" (VLA-GET-SUPPORTPATH FILES))
 )
)
(DEFUN
  REMOVE-SUPPORTPATH (STRING / FILES OLDSUPPORTPATH POSITION)
 (SETQ
   FILES
    (VLA-GET-FILES (VLA-GET-PREFERENCES (ACAD-OBJECT)))
   OLDSUPPORTPATH
    (VLA-GET-SUPPORTPATH FILES)
   POSITION
    (VL-STRING-SEARCH
      (STRCASE STRING)
      (STRCASE OLDSUPPORTPATH)
    )
 )
 (COND
   (POSITION
    (VLA-PUT-SUPPORTPATH
      FILES
      (STRCAT
        (SUBSTR OLDSUPPORTPATH 1 POSITION)
        (SUBSTR OLDSUPPORTPATH (+ POSITION (STRLEN STRING) 2))
      )
    )
   )
 )
)
(DEFUN
  HUBBARD-USERNAME (/ RDLIN USERLIST)
 (SETQ F1 (OPEN "R:\\Network\\networknames.txt" "r"))
 (WHILE (SETQ RDLIN (READ-LINE F1))
   (SETQ USERLIST (CONS (WIKI-STRTOLST RDLIN "`," """ T) USERLIST))
 )
 (SETQ F1 (CLOSE F1))
 (CADDR (ASSOC (GETVAR "loginname") USERLIST))
)
(DEFUN
  HUBBARD-USERNAME-2008-05 ()
 (CDR
   (ASSOC
     (STRCASE (HAWS-GETCOMPUTERNAME))
     '(("BECKY" . "Becky")
       ("BEN" . "Ben")
       ("BRIDGET" . "Bridget")
       ("CRAIG-D" . "Craig-D")
       ("CRAIG-H" . "Craig-H")
       ("DAVID" . "David")
       ("JEREMYPC" . "Jeremy")
       ("ADMIN-2" . "Kayle")
       ("KENNY" . "Kenny")
       ("MACK" . "Mack")
       ("MIKE" . "Mike")
       ("MICHAEL" . "Michael")
       ("SERVER" . "Server")
       ("TABATHA" . "Tabatha")
       ("TOM" . "Tom")
      )
   )
 )
)
;; See next post for wiki-strtolst function from wikia dot com
;|«Visual LISP© Format Options»
(72 2 40 2 nil "end of " 60 2 2 2 1 nil nil nil T)
;*** DO NOT add text below the comment! ***|;

;;The following function was copied from AutoCAD Wiki at Wikia dot com
;;;WIKI-STRTOLST
;;;Parses a string into a list of fields.
;;;Usage: (wiki-strtolst
;;;         [inputString containing fields]
;;;         [FieldSeparatorWC field delimiter wildcard string
;;;          Use "`," for comma and " ,\t" for white space
;;;         ]
;;;         [TextDelimiter text delimiter character.]
;;;         [EmptyFieldsDoCount flag.
;;;           If nil, consecutive field delimiters are ignored.
;;;           Nil is good for word (white space) delimited strings.
;;;         ]
;;;       )
;|
  Edit the source code for this function at 
  (redacted due to anti-spam measures htt..wikia...com/wiki/Strtolst)
|;
;;;Avoid cleverness.
;;;Human readability trumps elegance and economy and cleverness here.
;;;This should be readable to a programmer familiar with any language.
;;;In this function, I'm trying to honor readability in a new (2008) way.
;;;And I am trying a new commenting style.
;;;Tests
;;;(alert (apply 'strcat (mapcar '(lambda (x) (strcat "\n----\n" x)) (wiki-strtolst "1 John,"2 2"" pipe,\nheated",3 the end,,,,," "`," """ nil))))
;;;(alert (apply 'strcat (mapcar '(lambda (x) (strcat "\n----\n" x)) (wiki-strtolst "1 John,"2 2"" pipe,\nheated",3 the end,,,,," "`," """ T))))
(DEFUN
  WIKI-STRTOLST (INPUTSTRING FIELDSEPARATORWC TEXTDELIMITER
                 EMPTYFIELDSDOCOUNT / CHARACTERCOUNTER CONVERSIONISDONE
                 CURRENTCHARACTER CURRENTFIELD CURRENTFIELDISDONE
                 FIRSTCHARACTERINDEX PREVIOUSCHARACTER RETURNLIST
                 TEXTMODEISON
                )
 ;;Initialize the variables for clarity's sake
 (SETQ
   FIRSTCHARACTERINDEX 1
   CHARACTERCOUNTER
    (1- FIRSTCHARACTERINDEX)
   PREVIOUSCHARACTER ""
   CURRENTCHARACTER ""
   CURRENTFIELD ""
   CURRENTFIELDISDONE NIL
   TEXTMODEISON NIL
   CONVERSIONISDONE NIL
   RETURNLIST NIL
 )
 ;;Make sure that the FieldSeparatorWC is not empty.
 (COND
   ;;If an empty string matches the FieldSeparatorWC,
   ((WCMATCH "" FIELDSEPARATORWC)
    ;;Then
    ;;1. Give an alert about the problem.
    (ALERT
      ;;Include princ to allow user to see and copy error
      ;;after dismissing alert box.
      (PRINC
        (STRCAT
          "\n""
          FIELDSEPARATORWC
          "" is not a valid field delimiter."
        )
      )
    )
    ;;2. Exit with error.
    (EXIT)
   )
 )
 ;;Start the main character-by-character InputString examination loop.
 (WHILE (NOT CONVERSIONISDONE)
   (SETQ
     ;;Save CurrentCharacter as PreviousCharacter.
     PREVIOUSCHARACTER
      CURRENTCHARACTER
     ;;CharacterCounter is initialized above to start 1 before first character.  Increment it.
     CHARACTERCOUNTER
      (1+ CHARACTERCOUNTER)
     ;;Get new CurrentCharacter from InputString.
     CURRENTCHARACTER
      (SUBSTR INPUTSTRING CHARACTERCOUNTER 1)
   )
   ;;Decide what to do with CurrentCharacter.
   (COND
     ;;If
     ((AND
        ;;there is a TextDelimiter,
        (/= TEXTDELIMITER "")
        ;;and CurrentCharacter is a TextDelimiter,
        (= CURRENTCHARACTER TEXTDELIMITER)
      )
      ;;then
      ;;1.  Toggle the TextModeIsOn flag
      (IF (NOT TEXTMODEISON)
        (SETQ TEXTMODEISON T)
        (SETQ TEXTMODEISON NIL)
      )
      ;;2.  If this is the second consecutive TextDelimiter character, then
      (IF (= PREVIOUSCHARACTER TEXTDELIMITER)
        ;;Output it to CurrentField.
        (SETQ CURRENTFIELD (STRCAT CURRENTFIELD CURRENTCHARACTER))
      )
     )
     ;;Else if CurrentCharacter is a FieldDelimiter wildcard match,
     ((WCMATCH CURRENTCHARACTER FIELDSEPARATORWC)
      ;;Then
      (COND
        ;;If TextModeIsOn = True, then 
        ((= TEXTMODEISON T)
         ;;Output CurrentCharacter to CurrentField.
         (SETQ CURRENTFIELD (STRCAT CURRENTFIELD CURRENTCHARACTER))
        )
        ;;Else if
        ((OR ;;EmptyFieldsDoCount, or
             (= EMPTYFIELDSDOCOUNT T)
             ;;the CurrentField isn't empty,
             (/= "" CURRENTFIELD)
         )
         ;;Then
         ;;Set the CurrentFieldIsDone flag to true.
         (SETQ CURRENTFIELDISDONE T)
        )
        (T
         ;;Else do nothing
         ;;Do not flag the CurrentFieldDone,
         ;;nor output the CurrentCharacter.
         NIL
        )
      )
     )
     ;;Else if CurrentCharacter is empty,
     ((= CURRENTCHARACTER "")
      ;;Then
      ;;We are at the end of the string.
      ;;1.  Flag ConversionIsDone.
      (SETQ CONVERSIONISDONE T)
      ;;2.  If
      (IF (OR ;;EmptyFieldsDoCount, or
              EMPTYFIELDSDOCOUNT
              ;;the PreviousCharacter wasn't a FieldSeparatorWC, or
              (NOT (WCMATCH PREVIOUSCHARACTER FIELDSEPARATORWC))
              ;;the ReturnList is still nil due to only empty non-counting fields in string,
              ;;(Added 2008-02-18 TGH. Bug fix.)
              (= RETURNLIST NIL)
          )
        ;;Then flag the CurrentFieldIsDone to wrap up the last field.
        (SETQ CURRENTFIELDISDONE T)
      )
     )
     ;;Else (CurrentCharacter is something else),
     (T
      ;;Output CurrentCharacter to CurrentField.
      (SETQ CURRENTFIELD (STRCAT CURRENTFIELD CURRENTCHARACTER))
     )
   )
   ;;If CurrentFieldIsDone,
   (IF CURRENTFIELDISDONE
     ;;Then
     ;;Output it to the front of ReturnList.
     (SETQ
       RETURNLIST
        (CONS CURRENTFIELD RETURNLIST)
       ;;Start a new CurrentField.
       CURRENTFIELD
        ""
       CURRENTFIELDISDONE NIL
     )
   )
   ;;End the main character-by-character InputString examination loop.
 )
 ;;Reverse the backwards return list and we are done.
 (REVERSE RETURNLIST)
)