是plz 好啊我将直接在这里粘贴代码，然后我们可以了解细节。
;;HubbardCADInstall
;;Installs the custom Hubbard menus and commands to AutoCAD
;;Copyright 2008 Hubbard Engineering
;;625 N. Gilbert Road Suite 106
;;Gilbert, Arizona85234
;;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>: "
)
)
)
)
)
)
(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! ***|;
以下是不适用的wiki功能：
;;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
;;;
;;; [FieldSeparatorWC field delimiter wildcard string
;;; Use "`," for comma and " ,\t" for white space
;;; ]
;;;
;;; [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)
)
页:
1
[2]