[求助]：如何用Vlisp添加自定义局部菜单

sqmjk01 · 发表于 2003-7-26 20:17:07

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

如何用Vlisp往CAD菜单中添加自定义局部菜单？请各位高人帮忙！

eachy · 发表于 2003-7-26 20:19:50

最初由 sqmjk01 发布
[B]如何用Vlisp往CAD菜单中添加自定义局部菜单？请各位高人帮忙！ [/B]

参考这个

;;;*************************************************************************;;;
;;; API-MENUS.LSP ;;;
;;; Visual LISP ActiveX Menu/Toolbar Method Utilities ;;;
;;; Copyright (C)2001 David M. Stein, All Rights Reserved. ;;;
;;;*************************************************************************;;;
;;; Version 2001.00 06/06/01: Initial release ;;;
;;;*************************************************************************;;;
(vl-load-com)
(setq $acad (vlax-get-acad-object)
$adoc (vla-get-activedocument $acad)
)
;;;*************************************************************************
;;; DESCRIPTION: Returns vla-object to menugroups collection
;;;*************************************************************************
(defun Get-MenuGroups ()
(vla-get-MenuGroups $acad)
)
;;;*************************************************************************
;;; DESCRIPTION: Returns menugroup object for given menugroup name (string)
;;;*************************************************************************
(defun Get-MenuGroup (mgname)
(if (menugroup mgname)
(vla-item (Get-MenuGroups) mgname)
)
)
;;;*************************************************************************
;;; DESCRIPTION: Adds new menugroup to menugroup collection, returns menugroup object
;;;*************************************************************************
(defun MenuGroup-Add (mgname)
(vla-Add (Get-MenuGroups) mgname)
)
;;;*************************************************************************
;;; DESCRIPTION: Removes named menugroup from menugroups collection
;;;*************************************************************************
(defun MenuGroup-Delete (mgname)
(if (setq mg (Get-MenuGroup mgname))
(vla-Delete mg)
)
)
;;;*************************************************************************
;;; MODULE: MenuGroups-ListAll
;;; DESCRIPTION: Returns list of all menugroup names in current application session
;;; ARGS: none
;;; EXAMPLE: (Get-MenuGroups-ListAll) --> ("ACAD" "ASW2K" "ASW2K-P" ...)
;;;*************************************************************************
(defun MenuGroups-ListAll ( / out)
(vlax-for each (Get-MenuGroups)
(setq out (cons (vla-get-name each) out))
)
out
)
;;;*************************************************************************
;;; DESCRIPTION: Boolean test for existence of named menugroup, returns menugroup object if found
;;;*************************************************************************
(defun MenuGroup-Exists-p (name)
(Get-MenuGroup name)
)
;;;*************************************************************************
;;; DESCRIPTION: Returns vla-object to popupmenus collection for named menugroup
;;;*************************************************************************
(defun PopupMenus (mgroup / mg)
(if (setq mg (Get-MenuGroup mgroup))
(vla-get-Menus mg)
(princ (strcat "\nMenugroup not found: " mgroup))
)
)
;;;*************************************************************************
;;; DESCRIPTION: Returns list of all popup menu names for given menugroup
;;;*************************************************************************
(defun PopupMenus-ListAll (mgroup / pm out)
(if (setq pm (ASW-PopupMenus mgroup))
(vlax-for each pm
(setq out (cons (vla-get-Name each) out))
)
)
out
)
;;;*************************************************************************
;;; DESCRIPTION: Returns popupmenu object from specified menugroup object
;;;*************************************************************************
(defun PopupMenu (mgroup popname)
(vla-item (ASW-PopupMenus mgroup) popname)
)
;;;*************************************************************************
;;; MODULE: PopupMenu-ListSubs
;;; DESCRIPTION: Returns list of submenu captions (not labels) for popupmenu object
;;; ARGS: popupmenu-object
;;; EXAMPLE: (ASW-PopupMenu myPopMenu) --> ("File" "Edit" "View" "Draw" "Modify"...)
;;;*************************************************************************
(defun PopupMenu-ListSubs (oPopupMenu / i out)
(setq i 0)
(repeat (vla-get-Count oPopupMenu)
(setq out
(cons
(vla-get-Caption (vla-Item oPopupMenu i))
out
)
i (1+ i)
)
); repeat
(if out (reverse out))
)
; IAcadPopupMenu: An AutoCAD cascading menu
;
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Count (RO) = 20
; Name = "&ShipWorks"
; NameNoMnemonic (RO) = "ShipWorks"
; OnMenuBar (RO) = -1
; Parent (RO) = #<VLA-OBJECT IAcadPopupMenus 00f648b4>
; ShortcutMenu (RO) = 0
; TagString (RO) = "ID_ASW000"
; Methods supported:
; AddMenuItem (3)
; AddSeparator (1)
; AddSubMenu (2)
; InsertInMenuBar (1)
; Item (1)
; RemoveFromMenuBar ()
; IAcadPopupMenuItem: A single menu item on an AutoCAD pull-down menu
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Caption (RO) = "File..."
; Check = 0
; Enable = -1
; EndSubMenuLevel = 0
; HelpString = ""
; Index (RO) = 0
; Label = "File..."
; Macro = ""
; Parent (RO) = #<VLA-OBJECT IAcadPopupMenu 00ecc9f8>
; SubMenu (RO) = #<VLA-OBJECT IAcadPopupMenu 00ecc998>
; TagString = ""
; Type (RO) = 2
; Methods supported:
; Delete ()
; IAcadPopupMenuItem: A single FLY-OUT menu item on an AutoCAD pull-down menu
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Caption (RO) = "Fast-Plot..."
; Check = 0
; Enable = -1
; EndSubMenuLevel = 0
; HelpString = "Execute one-click plot to selected device: FPLOT"
; Index (RO) = 5
; Label = "Fast-Plot..."
; Macro = "\003\003\020FPLOT "
; Parent (RO) = #<VLA-OBJECT IAcadPopupMenu 00ecc9f8>
; SubMenu (RO) = Exception occurred
; TagString = "ID_Print1"
; Type (RO) = 0
; Methods supported:
; Delete ()
;;;*************************************************************************
;;; MODULE: PopupMenu-SubMenu
;;; DESCRIPTION: Returns submenu object for given submenu within a PopupMenu object
;;; ARGS: popupmenu-object, submenu-name
;;; EXAMPLE: (ASW-PopupMenu-SubMenu myPopMenu "Flyout1...")
;;;*************************************************************************
(defun PopupMenu-SubMenu
(oPopupMenu subname / tries out looked found)
(setq tries (vla-get-Count oPopupMenu) looked 0)
(while
(and
(< looked tries)
(not found)
)
(if (= subname (vla-get-Label (vla-item oPopupMenu looked)))
(progn
(setq found T)
(vla-get-SubMenu (vla-item oPopupMenu looked))
)
(setq looked (1+ looked))
)
)
)
;;;*************************************************************************
;;; MODULE: Toolbars
;;; DESCRIPTION: Returns toolbars collection object for specified menugroup
;;; ARGS: menugroup-name (string)
;;; EXAMPLE: (ASW-Toolbars "ASW2K") --> [vla-object]
;;;*************************************************************************
(defun Toolbars (mgroup / mg)
(if (setq mg (ASW-MenuGroup mgroup))
(vla-get-Toolbars mg)
(princ (strcat "\nMenugroup not found: " mgroup))
)
)
;;;*************************************************************************
;;; MODULE: Toolbars-ListAll
;;; DESCRIPTION: Returns list of toolbar names for specified menugroup
;;; ARGS: menugroup-name (string)
;;; EXAMPLE: (ASW-Toolbars-ListAll "ASW2K") --> ("Toolbar1" "Toolbar2" ...)
;;;*************************************************************************
(defun Toolbars-ListAll (mgroup / tb out)
(if (setq tb (ASW-Toolbars mgroup))
(vlax-for each tb
(setq out (cons (vla-get-name each) out))
)
)
out
)
;;;*************************************************************************
;;; MODULE: Toolbar-Exists-p
;;; DESCRIPTION: Returns T if toolbar exists within name menugroup toolbar collection
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Exists-p "ASW2K" "ASW: Sheets") returns T
;;;*************************************************************************
(defun Toolbar-Exists-p (mgroup tbname)
(and
(ASW-MenuGroup mgroup)
(ASW-Toolbar mgroup tbname)
)
)
;;;*************************************************************************
;;; MODULE: Toolbar
;;; DESCRIPTION: Returns vla-object to a named toolbar within a named menugroup
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar myMenuGroup "ASW: Sheets") --> [vla-object]
;;;*************************************************************************
(defun Toolbar (mgroup tbname / loc)
(vla-item (ASW-Toolbars mgroup) tbname)
)
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Count (RO) = 0
; DockStatus (RO) = 4
; FloatingRows = 1
; Height (RO) = 52
; HelpString = ""
; LargeButtons (RO) = 0
; left = 212
; Name = "Foo"
; Parent (RO) = #<VLA-OBJECT IAcadToolbars 00f6b924>
; TagString (RO) = "ID_Foo_0"
; top = 186
; Visible = -1
; Width (RO) = 27
; Methods supported:
; AddSeparator (1)
; AddToolbarButton (5)
; Delete ()
; Dock (1)
; Float (3)
; Item (1)
;;;*************************************************************************
;;; MODULE: Toolbar-Add
;;; DESCRIPTION: Adds toolbar to given menugroup, returns toolbar object
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Add "ASW2K" "MyToolbar1")
;;;*************************************************************************
(defun Toolbar-Add (mgroup name)
(vla-Add (ASW-Toolbars mgroup) name)
)
;;;*************************************************************************
;;; MODULE: Toolbar-Delete
;;; DESCRIPTION: Removes named toolbar from menugroup object collection
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Delete "ASW2K" "MyToolbar1")
;;;*************************************************************************
(defun Toolbar-Delete (mgroup tbname / tb)
(if (setq tb (ASW-Toolbar mgroup tbname))
(vla-Delete tb)
)
)
;;;*************************************************************************
;;; MODULE: Toolbar-ButtonNames
;;; DESCRIPTION: Returns list of button names for a given toolbar object
;;; ARGS: toolbar (vla-object)
;;; EXAMPLE: (ASW-Toolbar-ButtonNames myToolbar) --> ("Button1" "Button2" ...)
;;;*************************************************************************
(defun Toolbar-ButtonNames (tbobject / i out)
(setq i 0)
(repeat (vla-get-count tbobject)
(setq out (cons (vla-get-Name (vla-Item tbobject i)) out))
(setq i (1+ i))
)
out
)
;;;*************************************************************************
;;; MODULE: Toolbar-Button
;;; DESCRIPTION: Returns button object from given toolbar using button name
;;; ARGS: toolbar (vla-object), button-name (string)
;;; EXAMPLE: (ASW-Toolbar-Button myToolbar "Button1")
;;;*************************************************************************
(defun Toolbar-Button (tbobject btname / out)
(vla-Item tbobject btname)
)
; IAcadToolbarItem: A single button item on an AutoCAD toolbar
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Flyout (RO) = AutoCAD: The toolbar item is not a flyout button
; HelpString = "Insert a plain or reducing coupling: CPL"
; Index (RO) = 0
; Macro = "\003\003\020(ASWLF (list '(c:pff07 "pff07")))\npff07 "
; Name = "Coupling"
; Parent (RO) = #<VLA-OBJECT IAcadToolbar 00f676bc>
; TagString = "ID_ASWP023"
; Type (RO) = 0
; Methods supported:
; AttachToolbarToFlyout (2)
; Delete ()
; GetBitmaps (2)
; SetBitmaps (2)
;;;*************************************************************************
;;; MODULE: Toolbar-ButtonAdd
;;; DESCRIPTION: Add new button to given toolbar object, returns button object
;;; ARGS: toolbar-object, button-name, macro-string, bitmap-name, tagstring, helpstring
;;; EXAMPLE: (ASW-Toolbar-ButtonAdd myToolbar "Button1" "\003\003\020\nLine" "ICON_16_LINE" "Button001" "Draws a line: LINE")
;;;*************************************************************************
(defun Toolbar-ButtonAdd
(tbobject name macro bitmap1 tagstring helpstring / newButton index)
(setq index (vla-get-Count tbobject))
(cond
( (setq newButton (vla-AddToolbarButton tbobject
(vlax-make-variant index vlax-vbInteger)
name
helpstring
macro
)
)
(vla-put-TagString newButton tagstring)
(vla-SetBitMaps newButton bitmap1 bitmap1)
newButton
)
)
)
(defun C:ADDTB ( / tb buttons)
(if
(or
(setq tb (ASW-Toolbar G$APP "Foo"))
(setq tb (ASW-Toolbar-Add G$APP "Foo"))
)
(progn
(setq buttons (vla-get-Count tb))
(ASW-Toolbar-ButtonAdd tb (strcat "Button" (itoa buttons))
"\003\003\020\nLINE"
"ICON_16_LINE"
(strcat "FooButton" (itoa buttons))
"Draws a line: LINE"
)
)
)
(princ)
)
(defun C:DELTB ( / tb buttons)
(if (setq tb (ASW-Toolbar G$APP "Foo"))
(progn
(vla-Delete tb)
(vlax-release-object tb)
)
)
(princ)
)
;;;*************************************************************************
;;; MODULE: Toolbar-ButtonDelete
;;; DESCRIPTION: Removes named button from given toolbar object
;;; ARGS: toolbar-object, button-name
;;; EXAMPLE: (ASW-Toolbar-ButtonDelete myToolbar "Button1")
;;;*************************************************************************
(defun Toolbar-ButtonDelete (tbobject name / btn)
(if (setq btn (ASW-Toolbar-Button tbobject name))
(progn
(vla-Delete btn)
(vlax-release-object btn)
)
)
)
;;;*************************************************************************
;;; MODULE: Toolbar-Show
;;; DESCRIPTION: Un-Hides a named toolbar
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Show "ASW2K" "ASW: Sheets")
;;;*************************************************************************
(defun Toolbar-Show (mgroup tbname / tb)
(if (setq tb (ASW-Toolbar mgroup tbname))
(if (= (vla-get-Visible tb) :vlax-False)
(progn
(vla-put-Visible tb :vlax-True)
T
)
)
)
)
;;;*************************************************************************
;;; MODULE: Toolbar-Hide
;;; DESCRIPTION: Hides a named toolbar
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Hide "ASW2K" "ASW: Sheets")
;;;*************************************************************************
(defun Toolbar-Hide (mgroup tbname / tb)
(if (setq tb (ASW-Toolbar mgroup tbname))
(if (= (vla-get-Visible tb) :vlax-True)
(progn
(vla-put-Visible tb :vlax-False)
T
)
)
)
)
;;;*************************************************************************
;;; MODULE: Toolbar-Dock
;;; DESCRIPTION: Dock named toolbar in one of four locations
;;; ARGS: menugroup-name, toolbar-name, location (acToolbarDockTop, acToolbarDockBottom, acToolbarDockLeft, acToolbarDockRight)
;;; EXAMPLE: (ASW-Toolbar-Dock "ASW2K" "Sheets" 2) --> docks on left side of window
;;;*************************************************************************;;;
(defun Toolbar-Dock (mgroup tbname dock / tb)
(if (setq tb (ASW-Toolbar mgroup tbname))
(if (= (vla-get-Visible tb) :vlax-True)
(if (member dock '(0 1 2 3))
(progn
(vla-Dock tb dock)
1
)
-2 ;; invalid parameter value
)
-1 ;; toolbar not visible
)
0 ;; toolbar not found
)
)
;;;*************************************************************************
;;; MODULE: Toolbar-DockTop
;;; DESCRIPTION: Dock named toolbar at top of screen
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-DockTop "ASW2K" "ASW: PowerPlot")
;;;*************************************************************************
(defun Toolbar-DockTop (mgroup tbname)
(if (setq tbobject (ASW-Toolbar mgroup tbname))
(vla-Dock tbobject acToolbarDockTop)
(princ (strcat "\nToolbar (" tbname ") not found."))
)
)
;;;*************************************************************************
;;; MODULE: Toolbar-DockBottom
;;; DESCRIPTION: Dock named toolbar at bottom of screen
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-DockBottom "ASW2K" "ASW: PowerPlot")
;;;*************************************************************************
(defun Toolbar-DockBottom (mgroup tbname)
(if (setq tbobject (ASW-Toolbar mgroup tbname))
(vla-Dock tbobject acToolbarDockBottom)
(princ (strcat "\nToolbar (" tbname ") not found."))
)
)
;;;*************************************************************************
;;; MODULE: Toolbar-DockLeft
;;; DESCRIPTION: Dock named toolbar at left of screen
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-DockLeft "ASW2K" "ASW: PowerPlot")
;;;*************************************************************************
(defun Toolbar-DockLeft (mgroup tbname)
(if (setq tbobject (ASW-Toolbar mgroup tbname))
(vla-Dock tbobject acToolbarDockLeft)
(princ (strcat "\nToolbar (" tbname ") not found."))
)
)
;;;*************************************************************************
;;; MODULE: Toolbar-DockRight
;;; DESCRIPTION: Dock named toolbar at right of screen
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-DockRight "ASW2K" "ASW: PowerPlot")
;;;*************************************************************************
(defun Toolbar-DockRight (mgroup tbname)
(if (setq tbobject (ASW-Toolbar mgroup tbname))
(vla-Dock tbobject acToolbarDockRight)
(princ (strcat "\nToolbar (" tbname ") not found."))
)
)
;;;*************************************************************************
;;; MODULE: Toolbar-Float
;;; DESCRIPTION: Position named toolbar at specified location
;;; ARGS: menugroup-name, toolbar-name, top-int, left-int, rows-int
;;; EXAMPLE: (ASW-Toolbar-Float "ASW2K" "Sheets" 200 300 1)
;;;*************************************************************************
(defun Toolbar-Float (mgroup tbname top left rows)
(if (setq tb (ASW-Toolbar mgroup tbname))
(if (= (vla-get-Visible tb) :vlax-True)
(progn
(vla-Float tb top left rows)
1
)
-1 ;; toolbar not visible
)
0 ;; toolbar not found
)
)
;;;*************************************************************************\
;;; MODULE: Menu-Locate
;;; DESCRIPTION: Returns full path+filename for named menu file
;;; ARGS: menu-filename (without extension)
;;; EXAMPLE: (ASW-Menu-Locate "asw2k")
;;;************************************************************************;;;
(defun MENU-LOCATE (mnfn)
(DPR "\n(ASW-MENU-LOAD)")
(cond
;( (findfile (strcat mnfn ".mnc")) )
;( (findfile (strcat mnfn ".mns")) )
( (findfile (strcat mnfn ".mnu")) )
( (findfile (strcat G$MENU "\" mnfn ".mnu")) )
( (findfile (strcat G$ASL "\" mnfn ".mnu")) )
( (findfile (strcat G$SYS "\\Menu\" mnfn ".mnu")) )
( T nil )
)
)
;;;********************************************************************
;;; Force menu reload/recompile
;;;********************************************************************
(if (null C:UPDATE)
(defun C:UPDATE ()
(load "update.vlx")
(C:UPDATE)
(princ)
)
)
;;;*************************************************************************
;;; MODULE: Menu-ReLoadAll
;;; DESCRIPTION: Reloads and repositions (merges) all ShipWorks menu stubs
;;; ARGS: none
;;; EXAMPLE: (ASW-Menu-ReLoadAll)
;;;********************************************************************
(defun MENU-RELOADALL ( / cmdstr appkey local_copy client-menu)
(DPR "\n(ASW-MENU-RELOADALL)")
(setq client-menu (vl-filename-base G$PRO))
(setq cmdstr (strcat "COPY " G$MENU "\\ASW2K.MNU " G$DAT "\\ASW2K.MNU"))
(vl-cmdf "SHELL" cmdstr)
(setq cmdstr (strcat "COPY " G$ASL "\" G$APP ".MNU " G$DAT "\" G$APP ".MNU"))
(vl-cmdf "SHELL" cmdstr)
(cond
( (findfile (strcat G$MENU "\" client-menu ".MNU"))
(setq cmdstr (strcat "COPY " G$MENU "\" client-menu ".MNU " G$DAT "\" client-menu ".MNU"))
(vl-cmdf "SHELL" cmdstr)
)
)
(princ "\nMenus downloaded to client folder.")
(cond
( (menugroup "ASW2K")
(DPR "\nRemoving base services menu stub...")
(vl-cmdf "MENUUNLOAD" "ASW2K")
)
)
(cond
( (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup "ASW2K")
(menucmd "P4=+ASW2K.POP1")
(princ "\nFailed (1)!")
)
)
( T (princ "\nFailed (2)!") )
)
(cond
( (menugroup G$APP)
(foreach appkey '("ASW2K-S" "ASW2K-E" "ASW2K-P" "ASW2K-V")
(if (menugroup appkey)
(vl-cmdf "MENUUNLOAD" appkey)
)
)
)
)
(cond
( (setq local_copy (findfile (strcat G$DAT "\" G$APP ".mnu")))
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup G$APP)
(menucmd (strcat "P5=+" G$APP ".POP1"))
(princ "\nFailed (3)!")
)
)
( T
(princ "\nFailed (4)!")
)
)
(cond
( (menugroup client-menu)
(DPR "\nRemoving client-specific menu stub...")
(vl-cmdf "MENUUNLOAD" client-menu)
)
)
(cond
( (setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu")))
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup client-menu)
(menucmd (strcat "P6=+" client-menu ".POP1"))
(princ "\nFailed (5)!")
)
)
( T
(princ "\nFailed (6)!")
)
)
)
;;;*************************************************************************
;;; MODULE: MenuMerge
;;; DESCRIPTION: Loads and positions all ShipWorks menu stubs
;;; ARGS: none
;;; EXAMPLE: (ASW-MenuMerge)
;;;********************************************************************
(defun MenuMerge
( / local_copy remote_copy client-menu)
(DPR "\n(ASW-MenuMerge)")
(cond
( (menugroup "ASW2K")
(vl-cmdf "MENUUNLOAD" "ASW2K")
(if (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
(vl-File-Delete local_copy)
)
(vl-File-Copy (strcat G$MENU "\\asw2k.mnu") (strcat G$DAT "\\asw2k.mnu"))
(if (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
(progn
(vl-cmdf "MENULOAD" local_copy)
(menucmd "P4=+ASW2K.POP1")
)
(princ "\nFailed to reload new base menu update.")
)
)
;; Cond-2: Local MNU exists, load it
( (and
(not (menugroup "ASW2K"))
(setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
)
(DPR "\nReloading from local directory...")
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup "ASW2K")
(menucmd "P4=+ASW2K.POP1")
(princ "\nFailed to load local copy of ShipWorks Base menu.")
)
)
;; Cond-3: Remote MNU exists, copy to local, load local copy
( (and
(not (menugroup "ASW2K"))
(setq remote_copy (findfile (strcat G$MENU "\\asw2k.mnu")))
(vl-File-Copy remote_copy (strcat G$DAT "\\asw2k.mnu"))
(setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
)
;(vl-cmdf "delay" 400)
(DPR "\nReloading from new download copy...")
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup "ASW2K")
(menucmd "P4=+ASW2K.POP1")
(princ "\nFailed to load remote copy of ShipWorks Base menu.")
)
)
;; Cond-4: Horrible failure, cry in shame
( T (princ "\nSystem failure: Unable to download server menu update."))
); cond
(setq remote_copy nil local_copy nil)
(cond
( (menugroup G$APP)
(vl-cmdf "MENUUNLOAD" G$APP)
(if (setq local_copy (findfile (strcat G$DAT "\" G$APP ".mnu")))
(vl-File-Delete local_copy)
)
(vl-File-Copy (strcat G$ASL "\" G$APP ".mnu") (strcat G$DAT "\" G$APP ".mnu"))
(if (setq local_copy (findfile (strcat G$DAT "\" G$APP ".mnu")))
(progn
(vl-cmdf "MENULOAD" local_copy)
(menucmd (strcat "P5=+" G$APP ".POP1"))
)
(princ "\nFailed to reload new extended services menu update.")
)
);; Cond-2: Local MNU exists, load it
( (and
(not (menugroup G$APP))
(setq local_copy (findfile (strcat G$DAT "\" G$DAT ".mnu")))
)
(DPR "\nReloading from local directory...")
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup G$APP)
(menucmd (strcat "P5=+" G$APP ".POP1"))
(princ "\nFailed to load local copy of extended services menu.")
)
)
;; Cond-3: Remote MNU exists, copy to local, load local copy
( (and
(not (menugroup G$APP))
(setq remote_copy (findfile (strcat G$ASL "\" G$APP ".mnu")))
(vl-File-Copy remote_copy (strcat G$DAT "\" G$APP ".mnu"))
(setq local_copy (findfile (strcat G$DAT "\" G$APP ".mnu")))
)
;(vl-cmdf "delay" 400)
(DPR "\nReloading from downloaded copy...")
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup G$APP)
(menucmd (strcat "P5=+" G$APP ".POP1"))
(princ "\nFailed to load remote copy of extended services menu.")
)
)
;; Cond-4: Oh my God, two failures? What a shame
( T (princ "\nSystem Failure: Unable to download server menu update.") )
); cond
(DPR "\nChecking for project-based client menus...")
(setq client-menu (vl-filename-base G$PRO))
(cond
( (menugroup client-menu)
(vl-cmdf "MENUUNLOAD" client-menu)
(if (setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu")))
(vl-File-Delete local_copy)
)
(vl-File-Copy (strcat G$MENU "\" G$APP ".mnu") (strcat G$DAT "\" client-menu ".mnu"))
(if (setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu")))
(progn
(vl-cmdf "MENULOAD" local_copy)
(menucmd (strcat "P6=+" client-menu ".POP1"))
)
(princ "\nFailed to reload new client-specific menu update.")
)
);; Cond-2: Local MNU exists, load it
( (and
(not (menugroup client-menu))
(setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu")))
)
(DPR "\nReloading from local directory...")
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup client-menu)
(menucmd (strcat "P6=+" client-menu ".POP1"))
(princ "\nFailed to load local copy of client-specific menu.")
)
)
;; Cond-3: Remote MNU exists, copy to local, load local copy
( (and
(not (menugroup client-menu))
(setq remote_copy (findfile (strcat G$MENU "\" client-menu ".mnu")))
(vl-File-Copy remote_copy (strcat G$DAT "\" client-menu ".mnu"))
(setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu")))
)
;(vl-cmdf "delay" 400)
(DPR "\nReloading from downloaded copy...")
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup client-menu)
(menucmd (strcat "P6=+" client-menu ".POP1"))
(princ "\nFailed to load remote copy of client-specific menu.")
)
)
;; Cond-4: Oh my God, two failures? What a shame
( T (princ "\nSystem Failure: Unable to download server menu update.") )
)
(DPR "\nSearching for Express Tools stub menu to load...")
(cond
( (and
(not (menugroup "EXPRESS"))
(or
(setq expmn (findfile "acetmain.mnu"))
(setq expmn (findfile "express.mnu"))
)
)
(princ "\nLoading AutoCAD Express Tools menus...")
(vl-cmdf "_.MENULOAD" expmn)
(if (menugroup "EXPRESS")
(menucmd "P9=+EXPRESS.POP1")
(alert "Failed to load Express Tools menus...")
)
)
)
); defun
;;;*************************************************************************
;;; MODULE: Menu-DeleteFiles
;;; DESCRIPTION: Deletes all four extension-type files for named menu file
;;; ARGS: basename (without extension), pathname
;;; EXAMPLE: (ASW-Menu-DeleteFiles "mymenu" "c:\\mystuff")
;;;*************************************************************************
(defun MENU-DeleteFiles
(menubase pathname / mnuext mnu)
(DPR "\n(ASW-MENU-DeleteFiles)")
(foreach mnuext '(".mnu" ".mns" ".mnc" ".mnr")
(if (setq mnu (findfile (strcat pathname "\" menubase mnuext)))
(progn
(DPR (strcat "\nDeleting menu file: " mnu))
(vl-File-Delete mnu)
)
)
)
)
;;;*************************************************************************
;;; MODULE: Menu-CompareDates
;;; DESCRIPTION: Compare file dates, returns T if file1 is same or newer than file2
;;; ARGS: filename1, filename2
;;; EXAMPLE: (ASW-Menu-CompareDates localMenu serverMenu) returns T (filename1 is same or newer than filename2)
;;;*************************************************************************
(defun Menu-CompareDates (f1 f2 / st1 st2)
(if
(and
(setq f1 (findfile f1))
(setq f2 (findfile f2))
(setq st1 (vl-file-systime f1)); (2001 2 2 13 10 53 12 855)
(setq st2 (vl-file-systime f2)); (2001 2 2 13 10 53 12 855)
)
(if (> (nth 0 st1) (nth 0 st2));; newer year?
T
(if (= (nth 0 st1) (nth 0 st2));; same year?
(if (> (nth 1 st1) (nth 1 st2));; newer month?
T
(if (> (nth 3 st1) (nth 3 st2));; newer day of month?
T
(if (= (nth 3 st1) (nth 3 st2));; same day of month?
(if (> (nth 4 st1) (nth 4 st2));; newer hour of day?
T
(if (= (nth 4 st1) (nth 4 st2));; same hour of day?
(if (>= (nth 5 st1) (nth 5 st1));; newer minutes of same hour?
T
)
)
)
)
)
)
)
)
)
)
;;;*************************************************************************
;;; MODULE: Menu-CheckDates
;;; DESCRIPTION: Compare menu filenames dates between two folders
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************
(defun Menu-CheckDates
(forceload / choice fail)
(DPR "\n(ASW-Menu-CheckDates)")
(cond
( (not
(ASW-Menu-CompareDates
(strcat G$DAT "\\asw2k.mnu")
(strcat G$MENU "\\asw2k.mnu")
)
)
(setq fail 1)
)
)
(cond
( (not
(ASW-Menu-CompareDates
(strcat G$DAT "\" G$APP ".mnu")
(strcat G$ASL "\" G$APP ".mnu")
)
)
(if fail
(setq fail 2)
(setq fail -1)
)
)
)
(cond
( (= fail 1) (DPR "\nBase menu failed comparison.") )
( (= fail 2) (DPR "\nBoth menus failed comparison.") )
( (= fail -1)(DPR "\nExtended menu failed comparison.") )
( T (DPR "\nMenus are up to date.") )
)
(cond
( (and fail (not forceload))
(setq choice
(DOS_MsgBox
(strcat
"One of your ShipWorks menus is out of date."
"\nYou can update it now by picking the Yes"
"\nbutton, or pick No to defer until later.\n"
"\nIf you defer now, you will be reminded each"
"\ntime you open a drawing until you update."
)
"ShipWorks Menu Update"
4 3
)
)
(if (= 6 choice)
(ASW-MENU-RELOADALL)
(princ "\nShipWorks menu update notice deferred.")
)
)
)
)
;;;*************************************************************************
;;; MODULE: Toolbars-HideAll
;;; DESCRIPTION: Hide all toolbars related to specified menugroup
;;; ARGS: menugroup-name
;;; EXAMPLE: (ASW-Toolbars-HideAll "ASW2K")
;;;*************************************************************************
(defun Toolbars-HideAll (mgroup / tbars)
(cond
( (setq tbars (asw-toolbars-listall mgroup))
(foreach tbar tbars
(ASW-Toolbar-Hide mgroup tbar)
)
)
)
)
;;;*************************************************************************
;;; MODULE: Toolbars-ShowAll
;;; DESCRIPTION: Show all toolbars related to specified menugroup
;;; ARGS: menugroup-name
;;; EXAMPLE: (ASW-Toolbars-ShowAll "ASW2K")
;;;*************************************************************************
(defun Toolbars-ShowAll (mgroup / tbars)
(cond
( (setq tbars (asw-toolbars-listall mgroup))
(foreach tbar tbars
(ASW-Toolbar-Show mgroup tbar)
)
)
)
)
;;;*************************************************************************
;;; MODULE: Toolbars-Hidden
;;; DESCRIPTION: Returns list of toolbars that are hidden for a specified menugroup
;;; ARGS: menugroup-name
;;; EXAMPLE: (ASW-Toolbars-Hidden "ASW2K") returns ("toolbar1" "toolbar2"...)
;;;*************************************************************************
(defun Toolbars-Hidden (mgroup / tbars each tbar)
(cond
( (setq tbars (ASW-Toolbars-ListAll mgroup))
(foreach each tbars
(setq tbar (ASW-Toolbar mgroup each))
(if (= :vlax-True (vla-get-Visible tbar))
(setq out (cons (vla-get-name tbar) out))
)
)
)
)
)
;;;*************************************************************************
;;; MODULE: C:TBOFF
;;; DESCRIPTION: Turns off ShipWorks toolbars
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************
(defun C:TBOFF ( / hbars1 hbars2)
(setq G$TBOFF1 (KWORD '("A""V") "Hide All toolbars or Visible toolbars only..." G$TBOFF1 T))
(cond
( (= G$TBOFF1 "V")
(setq G$TBOFF2 (ASW-Toolbars-Hidden "ASW2K"))
(setq G$TBOFF3 (ASW-Toolbars-Hidden G$APP))
)
)
(ASW-Toolbars-HideAll "ASW2K")
(ASW-Toolbars-HideAll G$APP)
(princ)
)
;;;*************************************************************************
;;; MODULE: C:TBON
;;; DESCRIPTION: Turns on ShipWorks toolbars
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************
(defun C:TBON ( / opt)
(cond
( (and G$TBOFF1 (= G$TBOFF1 "V") (or G$TBOFF2 G$TBOFF3))
(setq opt (KWORD '("A""H") "Display All toolbars or only those Hidden before..." opt T))
(cond
( (= opt "A")
(ASW-Toolbars-ShowAll "ASW2K")
(ASW-Toolbars-ShowAll G$APP)
)
( T
(if G$TBOFF2
(vlax-for each (ASW-Toolbars "ASW2K")
(setq tbname (vla-get-name each))
(if (member tbname G$TBOFF2)
(ASW-Toolbar-Show "ASW2K" tbname)
)
)
)
(if G$TBOFF3
(vlax-for each (ASW-Toolbars G$APP)
(setq tbname (vla-get-name each))
(if (member tbname G$TBOFF3)
(ASW-Toolbar-Show G$APP tbname)
)
)
)
)
); cond
)
( T
(ASW-Toolbars-ShowAll "ASW2K")
(ASW-Toolbars-ShowAll G$APP)
)
)
(princ)
)
;;;*************************************************************************
;;; MODULE: Menu-SaveAll
;;; DESCRIPTION: Saves all ShipWorks menu settings to MNS or MNC files
;;; ARGS: menu-type ("mns" or "mnc") not case sensitive, nil = "mns"
;;; EXAMPLE: (ASW-Menu-SaveAll "mnc") returns nil
;;;*************************************************************************
(defun MENU-SAVEALL (mtype)
(DPR "\n(ASW-MENU-SAVEALL)")
(vlax-for each (Get-MenuGroups)
(if (wcmatch (strcase (vla-get-name each)) "ASW2K*")
(if (= (strcase mtype) "MNC")
(vla-save each acMenuFileCompiled)
(vla-save each acMenuFileSource)
)
)
)
)
;;;*************************************************************************
;;; MODULE: MenuUpdate-LoadClientMenus
;;; DESCRIPTION: Loads client menu files as menugroups for ShipWorks session
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************
(defun MenuUpdate-LoadClientMenus
( / mg svclist svcmnu)
(ASW-PRINC "\n(ASW-MenuUpdate-LoadClientMenus)")
(princ "\nLoading ShipWorks menugroups from client folder...")
(setq svclist
'("ASW2K-E" "&Electrical" "ASW2K-P" "&Piping" "ASW2K-S" "&Structure" "ASW2K-V" "HVAC")
svcmnu (cadr (member G$APP svclist))
)
(cond
( (not (menugroup "asw2k"))
(if (setq mg (asw-menu-load "asw2k" (strcat G$DAT "\\asw2k.mnu")))
(progn
(if (ASW-PopMenu-Insert "asw2k" "&ShipWorks" 4)
(princ "\nBase menubar loaded from file.")
)
(vlax-release-object mg)
)
)
)
( T
(if (not (ASW-PopMenu-MenuBar-p "&ShipWorks"))
(if (ASW-PopMenu-Insert "asw2k" "&ShipWorks" 4)
(princ "\nBase menubar loaded.")
(princ "\nFailed to get base popmenu from menugroup collection.")
)
)
)
)
(if
(and
(/= G$APP "ASW2K-E")
(menugroup "ASW2K-E")
)
(ASW-Menu-UnLoad "ASW2K-E")
)
(if
(and
(/= G$APP "ASW2K-P")
(menugroup "ASW2K-P")
)
(ASW-Menu-Unload "ASW2K-P")
)
(if
(and
(/= G$APP "ASW2K-S")
(menugroup "ASW2K-S")
)
(ASW-Menu-Unload "ASW2K-S")
)
(if
(and
(/= G$APP "ASW2K-V")
(menugroup "ASW2K-V")
)
(ASW-Menu-Unload "ASW2K-V")
)
(cond
( (not (menugroup G$APP))
(if (setq mg (asw-menu-load G$APP (strcat G$DAT "\" G$APP ".mnu")))
(progn
(if (ASW-PopMenu-Insert G$APP svcmnu 5)
(princ (strcat "\nService menubar loaded from file: " G$APP))
)
(vlax-release-object mg)
)
)
)
( T
(if (not (ASW-PopMenu-MenuBar-p svcmnu))
(if (ASW-PopMenu-Insert G$APP svcmnu 5)
(princ "\nServer menubar loaded.")
(princ "\nFailed to get service popmenu from menugroup collection.")
)
)
)
)
)
;;;*************************************************************************
;;; MODULE: MenuUpdate-DeleteClientFiles
;;; DESCRIPTION: Deletes client-side menu files for ShipWorks
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************
(defun MenuUpdate-DeleteClientFiles
( / mfile)
(ASW-PRINC "\n(ASW-MenuUpdate-DeleteClientFiles)")
(foreach mext '(".mnu" ".mns" ".mnc" ".mnr")
(if (setq mfile (findfile (strcat G$DAT "\\asw2k" mext)))
(if (vl-file-delete mfile)
(princ);(princ (strcat "\nDeleted menu file: " mfile))
(princ (strcat "\nFailed to delete menu file: " mfile))
)
)
)
(foreach mext '(".mnu" ".mns" ".mnc" ".mnr")
(if (setq mfile (findfile (strcat G$DAT "\" G$APP mext)))
(if (vl-file-delete mfile)
(princ);(princ (strcat "\nDeleted menu file: " mfile))
(princ (strcat "\nFailed to delete menu file: " mfile))
)
)
)
)
;;;*************************************************************************
;;; MODULE: MenuUpdate-UnloadMenus
;;; DESCRIPTION: Unloads all ShipWorks menugroups
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************
(defun MenuUpdate-UnloadMenus ()
(ASW-PRINC "\n(ASW-MenuUpdate-UnloadMenus)")
(princ "\nUnloading ShipWorks menugroups...")
(ASW-Menu-Unload "asw2k")
(foreach n '("ASW2K-E" "ASW2K-P" "ASW2K-S" "ASW2K-V")
(ASW-Menu-Unload n)
)
)
;;;*************************************************************************
;;; MODULE: MenuUpdate-DownloadMenus
;;; DESCRIPTION: Downloads server files to client for all ShipWorks menus
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************
(defun MenuUpdate-DownloadMenus
( / msrc1 msrc2 mtarget1 mtarget2 go)
(ASW-PRINC "\n(ASW-MenuUpdate-DownloadMenus)")
(cond
( (setq msrc1 (findfile (strcat G$MENU "\\asw2k.mnu")))
(if (setq mtarget1 (findfile (strcat G$DAT "\\asw2k.mnu")))
(if (vl-file-delete mtarget1)
(setq go T)
)
(setq go T)
)
(if go
(if (vl-file-copy msrc1 (strcat G$DAT "\\asw2k.mnu"))
(princ "\nBase menu file downloaded successfully.")
(princ "\nFailed to download base menu file!")
)
(princ "\nFailed to remove client base menu cache, download failed.")
)
)
)
(setq go nil)
(cond
( (setq msrc2 (findfile (strcat G$MENU "\" G$APP ".mnu")))
(if (setq mtarget2 (findfile (strcat G$DAT "\" G$APP ".mnu")))
(if (vl-file-delete mtarget2)
(setq go T)
)
(setq go T)
)
(if go
(if (vl-file-copy msrc2 (strcat G$DAT "\" G$APP ".mnu"))
(princ "\nService menu file downloaded successfully.")
(princ "\nFailed to download service menu file!")
)
(princ "\nFailed to remove client service menu cache, download failed.")
)
)
)
)
(defun ObjErr (errobj)
(princ (strcat "\nError: " (vl-catch-all-error-message errobj)))
)
(defun Obj-ReleaseAll (objects)
(foreach obj objects
(if (= (type obj) 'vla-object); symbol bound to vla-object type?
(if (not (vlax-object-released-p obj)); not already released?
(vlax-release-object obj); release it!
)
)
(set (quote obj) nil)
)
)
;;;*************************************************************************
;;; MODULE: Menu-LoadPartialMenus
;;; DESCRIPTION: Loads default menu items for ShipWorks at start-up
;;; ARGS: none
;;; EXAMPLE: (ASW-Menu-LoadPartialMenus)
;;;*************************************************************************
(defun Menu-LoadPartialMenus
( / mgroups mgnames omg mgf)
(ASW-Princ "\n(ASW-Menu-LoadPartialMenus)")
(if (not (menugroup "asw2k"))
(progn
(ASW-MenuUpdate-UnloadMenus)
(ASW-MenuUpdate-DeleteClientFiles)
(ASW-MenuUpdate-DownloadMenus)
(ASW-MenuUpdate-LoadClientMenus)
)
(ASW-MenuUpdate-LoadClientMenus)
)
(setq mgroups (Get-MenuGroups)
mgnames (Get-MenuGroups-listall)
)
(if (and C:UPDATE (null (menugroup "asw2k"))) (C:UPDATE))
(if (not (menugroup G$APP))
(progn
(princ "\nReloading extended services menu group...")
(foreach mg '("ASW2K-E" "ASW2K-P" "ASW2K-S" "ASW2K-V")
(if
(and
(member mg mgnames)
(setq omg (vla-item mg mgroups))
)
(vla-unload omg)
(vlax-release-object omg)
)
); foreach - unload
(cond
( (or
(setq mgf (findfile (strcat G$APP ".mns")))
(setq mgf (findfile (strcat G$APP ".mnc")))
)
(princ "\nLoading ShipWorks partial menu data...")
(vla-load mgroups mgf)
(if (menugroup G$APP)
(menucmd (strcat "P5=+" G$APP ".POP1"))
(princ (strcat "\nUnable to load partial menu for service: " G$APP))
)
)
( T
(C:UPDATE)
)
)
)
(princ "\nMenugroup already loaded."); menugroup already loaded, do nothing
)
(princ)
)
;;;*************************************************************************
;;; MODULE: Menu-Unload
;;; DESCRIPTION: Unloads specified menugroup, returns if successful or menugroup not loaded
;;; ARGS: menugroup-name
;;; EXAMPLE: (ASW-Menu-Unload "ASW2K")
;;;*************************************************************************
(defun Menu-Unload (name / omg)
(ASW-PRINC "\n(ASW-Menu-Unload)")
(if (menugroup name)
(if (setq omg (vla-item (Get-MenuGroups) name))
(progn
(vla-unload omg)
(vlax-release-object omg)
T
)
)
T
)
)
;;;*************************************************************************
;;; MODULE: Menu-Reload
;;; DESCRIPTION: Reloads menugroup popmenu if loaded, loads otherwise
;;; ARGS: menugroup-name, path to menufile
;;; EXAMPLE:
;;;*************************************************************************
(defun Menu-Reload (name path / mnu1)
(ASW-PRINC "\n(ASW-Menu-Reload)")
(cond
( (menugroup name)
(menucmd (strcat "P5=+" name ".POP1"))
)
( (or
(setq mnu1 (findfile (strcat path "\" name ".mns")))
(setq mnu1 (findfile (strcat path "\" name ".mnc")))
)
(vl-cmdf "_.menuload" mnu1)
(menucmd (strcat "P5=+" name ".POP1"))
)
( T (C:UPDATE) )
)
)
(defun PopMenu-Insert (mgroup name loc / pmnu)
(ASW-PRINC "\n(ASW-PopMenu-Insert)")
(if (not (ASW-PopMenu-MenuBar-p name))
(if (setq pmnu (ASW-PopupMenu mgroup name))
(progn
(vla-insertinmenubar pmnu loc)
(vlax-release-object pmnu)
T
)
(princ (strcat "\nMenugroup or popmenu not loaded or defined: " name))
)
(princ (strcat "\nPopmenu already loaded: " name))
)
)
;;;*************************************************************************
;;; MODULE: PopMenu-Remove
;;; DESCRIPTION: Removes specified popmenu from menubar, returns nil
;;; ARGS: menugroup-name, pop-menu-name
;;; EXAMPLE: (ASW-PopMenu-Remove "ASW2K" "&ShipWorks")
;;;*************************************************************************
(defun PopMenu-Remove (mgname name / pmnu)
(ASW-PRINC "\n(ASW-PopMenu-Remove)")
(if (menugroup mgname)
(if (ASW-PopMenu-MenuBar-p name)
(if (setq pmnu (vla-item (vla-get-menubar (ASW-AcadObject)) name))
(progn
(vla-removefrommenubar pmnu)
(vlax-release-object pmnu)
(princ (strcat "\nPopmenu successfully removed: " name))
)
(princ (strcat "\nPopmenu not found/Unable to remove: " name))
)
(princ (strcat "\nPopmenu not loaded/Unable to remove: " name))
)
)
)
;;;*************************************************************************
;;; MODULE: PopMenu-MenuBar-p
;;; DESCRIPTION: Returns T if menubar contains specified pop-menu item
;;; ARGS: pop-menu-name (string, case sensitive, includes mnemonics if used)
;;; EXAMPLE: (ASW-PopMenu-MenuBar-p "&ShipWorks") returns T or nil
;;;*************************************************************************
(defun PopMenu-MenuBar-p (name / mbar i found)
(ASW-PRINC "\n(ASW-PopMenuLoaded)")
(setq mbar (vla-get-menubar (asw-acadobject)) i 0)
(while (and (not found) (< i (1- (vla-get-count mbar))))
(if (= (strcase name) (strcase (vla-get-name (vla-item mbar i))))
(setq found T)
)
(setq i (1+ i))
)
(vlax-release-object mbar)
found
)
;;;*************************************************************************
;;;*************************************************************************
(defun Toolbars-Backup (mgroup / tbars name show pair out $regpath)
(ASW-PRINC "\n(ASW-Toolbars-Backup)")
(setq $regpath (strcat "Menus\\Toolbars\" mgroup))
(cond
( (setq tbars (ASW-Toolbars mgroup))
(vlax-for each tbars
(setq name (vla-get-name each)
show (vla-get-visible each)
pair (list name (if (= show :vlax-true) "1" "0"))
out (cons pair out)
)
)
(vlax-release-object tbars)
(if out
(progn
(foreach tb out
(ASW-RegSet (strcat $regpath "\" (car tb)) (cadr tb))
)
)
)
)
( T (princ (strcat "\nMenugroup (" mgroup ") has no toolbars.")) )
)
out
)
;;;*************************************************************************
;;;*************************************************************************
(defun Toolbars-Restore (mgroup / keys $regpath dat out)
(ASW-PRINC "\n(ASW-Toolbars-Restore)")
(setq $regpath (strcat G$REGROOT "\\Menus\\Toolbars\" mgroup))
(cond
( (menugroup mgroup)
(cond
( (setq keys (vl-registry-descendents $regpath))
(foreach key keys
(setq dat (vl-registry-read (strcat $regpath "\" key) nil)
out (cons (list key dat) out)
)
)
)
( T (princ (strcat "\nNo saved toolbar info to retrieve: " mgroup)) )
)
)
)
out
)
;;;*************************************************************************
;;; MODULE: Menu-Load
;;; DESCRIPTION: Loads menugroup from specified MNU, MNS or MNC file
;;; ARGS: menugroup-name, menufile
;;; EXAMPLE:
;;;*************************************************************************
(defun Menu-Load (mgroup mfile / mgroups omg)
(ASW-PRINC "\n(ASW-Menu-Load)")
(cond
( (not (menugroup mgroup))
(setq mgroups (Get-MenuGroups))
(if (findfile mfile)
(setq omg (vla-load mgroups (findfile mfile)))
(princ (strcat "\nUnable to load menu file: " mfile))
)
)
( T (princ (strcat "\nMenugroup (" mgroup ") is alread loaded.")) )
)
omg
)
(princ)

;;;*************************************************************************;;; 
;;; API-MENUS.LSP                                                           ;;; 
;;; Visual LISP ActiveX Menu/Toolbar Method Utilities                       ;;; 
;;; Copyright (C)2001 David M. Stein, All Rights Reserved.                  ;;; 
;;;*************************************************************************;;; 
;;; Version 2001.00 06/06/01: Initial release                               ;;; 
;;;*************************************************************************;;; 
 
(vl-load-com) 
(setq $acad (vlax-get-acad-object) 
      $adoc (vla-get-activedocument $acad) 
) 
 
;;;************************************************************************* 
;;; DESCRIPTION: Returns vla-object to menugroups collection 
;;;************************************************************************* 
 
(defun Get-MenuGroups () 
  (vla-get-MenuGroups $acad) 
) 
 
;;;************************************************************************* 
;;; DESCRIPTION: Returns menugroup object for given menugroup name (string) 
;;;************************************************************************* 
 
(defun Get-MenuGroup (mgname) 
        (if (menugroup mgname) 
                (vla-item (Get-MenuGroups) mgname) 
        ) 
) 
 
;;;************************************************************************* 
;;; DESCRIPTION: Adds new menugroup to menugroup collection, returns menugroup object 
;;;************************************************************************* 
 
(defun MenuGroup-Add (mgname) 
        (vla-Add (Get-MenuGroups) mgname) 
) 
 
;;;************************************************************************* 
;;; DESCRIPTION: Removes named menugroup from menugroups collection 
;;;************************************************************************* 
 
(defun MenuGroup-Delete (mgname) 
        (if (setq mg (Get-MenuGroup mgname)) 
                (vla-Delete mg) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: MenuGroups-ListAll 
;;; DESCRIPTION: Returns list of all menugroup names in current application session 
;;; ARGS: none 
;;; EXAMPLE: (Get-MenuGroups-ListAll) --> ("ACAD" "ASW2K" "ASW2K-P" ...) 
;;;************************************************************************* 
 
(defun MenuGroups-ListAll ( / out) 
  (vlax-for each (Get-MenuGroups) 
                (setq out (cons (vla-get-name each) out)) 
        ) 
        out 
) 
 
;;;************************************************************************* 
;;; DESCRIPTION: Boolean test for existence of named menugroup, returns menugroup object if found 
;;;************************************************************************* 
 
(defun MenuGroup-Exists-p (name) 
        (Get-MenuGroup name) 
) 
 
;;;************************************************************************* 
;;; DESCRIPTION: Returns vla-object to popupmenus collection for named menugroup 
;;;************************************************************************* 
 
(defun PopupMenus (mgroup / mg) 
        (if (setq mg (Get-MenuGroup mgroup)) 
                (vla-get-Menus mg) 
                (princ (strcat "\nMenugroup not found: " mgroup)) 
        ) 
) 
 
;;;************************************************************************* 
;;; DESCRIPTION: Returns list of all popup menu names for given menugroup 
;;;************************************************************************* 
 
(defun PopupMenus-ListAll (mgroup / pm out) 
  (if (setq pm (ASW-PopupMenus mgroup)) 
                (vlax-for each pm 
                        (setq out (cons (vla-get-Name each) out)) 
                ) 
        ) 
        out 
) 
 
;;;************************************************************************* 
;;; DESCRIPTION: Returns popupmenu object from specified menugroup object 
;;;************************************************************************* 
 
(defun PopupMenu (mgroup popname) 
        (vla-item (ASW-PopupMenus mgroup) popname) 
) 
 
;;;************************************************************************* 
;;; MODULE: PopupMenu-ListSubs 
;;; DESCRIPTION: Returns list of submenu captions (not labels) for popupmenu object 
;;; ARGS: popupmenu-object 
;;; EXAMPLE: (ASW-PopupMenu myPopMenu) --> ("File" "Edit" "View" "Draw" "Modify"...) 
;;;************************************************************************* 
 
(defun PopupMenu-ListSubs (oPopupMenu / i out) 
        (setq i 0) 
        (repeat (vla-get-Count oPopupMenu) 
                (setq out 
                                                (cons 
                                                        (vla-get-Caption (vla-Item oPopupMenu i)) 
                                                        out 
                                                ) 
                                        i (1+ i) 
                ) 
        ); repeat 
        (if out (reverse out)) 
) 
 
; IAcadPopupMenu: An AutoCAD cascading menu 
; 
; Property values: 
;   Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8> 
;   Count (RO) = 20 
;   Name = "&ShipWorks" 
;   NameNoMnemonic (RO) = "ShipWorks" 
;   OnMenuBar (RO) = -1 
;   Parent (RO) = #<VLA-OBJECT IAcadPopupMenus 00f648b4> 
;   ShortcutMenu (RO) = 0 
;   TagString (RO) = "ID_ASW000" 
; Methods supported: 
;   AddMenuItem (3) 
;   AddSeparator (1) 
;   AddSubMenu (2) 
;   InsertInMenuBar (1) 
;   Item (1) 
;   RemoveFromMenuBar () 
 
; IAcadPopupMenuItem: A single menu item on an AutoCAD pull-down menu 
; Property values: 
;   Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8> 
;   Caption (RO) = "File..." 
;   Check = 0 
;   Enable = -1 
;   EndSubMenuLevel = 0 
;   HelpString = "" 
;   Index (RO) = 0 
;   Label = "File..." 
;   Macro = "" 
;   Parent (RO) = #<VLA-OBJECT IAcadPopupMenu 00ecc9f8> 
;   SubMenu (RO) = #<VLA-OBJECT IAcadPopupMenu 00ecc998> 
;   TagString = "" 
;   Type (RO) = 2 
; Methods supported: 
;   Delete () 
 
; IAcadPopupMenuItem: A single FLY-OUT menu item on an AutoCAD pull-down menu 
; Property values: 
;   Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8> 
;   Caption (RO) = "Fast-Plot..." 
;   Check = 0 
;   Enable = -1 
;   EndSubMenuLevel = 0 
;   HelpString = "Execute one-click plot to selected device: FPLOT" 
;   Index (RO) = 5 
;   Label = "Fast-Plot..." 
;   Macro = "\003\003\020FPLOT " 
;   Parent (RO) = #<VLA-OBJECT IAcadPopupMenu 00ecc9f8> 
;   SubMenu (RO) = Exception occurred 
;   TagString = "ID_Print1" 
;   Type (RO) = 0 
; Methods supported: 
;   Delete () 
 
;;;************************************************************************* 
;;; MODULE: PopupMenu-SubMenu 
;;; DESCRIPTION: Returns submenu object for given submenu within a PopupMenu object 
;;; ARGS: popupmenu-object, submenu-name 
;;; EXAMPLE: (ASW-PopupMenu-SubMenu myPopMenu "Flyout1...") 
;;;************************************************************************* 
 
(defun PopupMenu-SubMenu 
        (oPopupMenu subname / tries out looked found) 
        
        (setq tries (vla-get-Count oPopupMenu) looked 0) 
        
        (while 
                (and 
                        (< looked tries) 
                        (not found) 
                ) 
                (if (= subname (vla-get-Label (vla-item oPopupMenu looked))) 
                        (progn 
                                (setq found T) 
                                (vla-get-SubMenu (vla-item oPopupMenu looked)) 
                        ) 
                        (setq looked (1+ looked)) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbars 
;;; DESCRIPTION: Returns toolbars collection object for specified menugroup 
;;; ARGS: menugroup-name (string) 
;;; EXAMPLE: (ASW-Toolbars "ASW2K") --> [vla-object] 
;;;************************************************************************* 
 
(defun Toolbars (mgroup / mg) 
        (if (setq mg (ASW-MenuGroup mgroup)) 
                (vla-get-Toolbars mg) 
                (princ (strcat "\nMenugroup not found: " mgroup)) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbars-ListAll 
;;; DESCRIPTION: Returns list of toolbar names for specified menugroup 
;;; ARGS: menugroup-name (string) 
;;; EXAMPLE: (ASW-Toolbars-ListAll "ASW2K") --> ("Toolbar1" "Toolbar2" ...) 
;;;************************************************************************* 
 
(defun Toolbars-ListAll (mgroup / tb out) 
  (if (setq tb (ASW-Toolbars mgroup)) 
                (vlax-for each tb 
                        (setq out (cons (vla-get-name each) out)) 
                ) 
        ) 
        out 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-Exists-p 
;;; DESCRIPTION: Returns T if toolbar exists within name menugroup toolbar collection 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar-Exists-p "ASW2K" "ASW: Sheets") returns T 
;;;************************************************************************* 
 
(defun Toolbar-Exists-p (mgroup tbname) 
        (and 
                (ASW-MenuGroup mgroup) 
                (ASW-Toolbar mgroup tbname) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar 
;;; DESCRIPTION: Returns vla-object to a named toolbar within a named menugroup 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar myMenuGroup "ASW: Sheets") --> [vla-object] 
;;;************************************************************************* 
 
(defun Toolbar (mgroup tbname / loc) 
  (vla-item (ASW-Toolbars mgroup) tbname) 
) 
 
; Property values: 
;   Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8> 
;   Count (RO) = 0 
;   DockStatus (RO) = 4 
;   FloatingRows = 1 
;   Height (RO) = 52 
;   HelpString = "" 
;   LargeButtons (RO) = 0 
;   left = 212 
;   Name = "Foo" 
;   Parent (RO) = #<VLA-OBJECT IAcadToolbars 00f6b924> 
;   TagString (RO) = "ID_Foo_0" 
;   top = 186 
;   Visible = -1 
;   Width (RO) = 27 
; Methods supported: 
;   AddSeparator (1) 
;   AddToolbarButton (5) 
;   Delete () 
;   Dock (1) 
;   Float (3) 
;   Item (1) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-Add 
;;; DESCRIPTION: Adds toolbar to given menugroup, returns toolbar object 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar-Add "ASW2K" "MyToolbar1") 
;;;************************************************************************* 
 
(defun Toolbar-Add (mgroup name) 
        (vla-Add (ASW-Toolbars mgroup) name) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-Delete 
;;; DESCRIPTION: Removes named toolbar from menugroup object collection 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar-Delete "ASW2K" "MyToolbar1") 
;;;************************************************************************* 
 
(defun Toolbar-Delete (mgroup tbname / tb) 
        (if (setq tb (ASW-Toolbar mgroup tbname)) 
                (vla-Delete tb) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-ButtonNames 
;;; DESCRIPTION: Returns list of button names for a given toolbar object 
;;; ARGS: toolbar (vla-object) 
;;; EXAMPLE: (ASW-Toolbar-ButtonNames myToolbar) --> ("Button1" "Button2" ...) 
;;;************************************************************************* 
 
(defun Toolbar-ButtonNames (tbobject / i out) 
        (setq i 0) 
        (repeat (vla-get-count tbobject) 
                (setq out (cons (vla-get-Name (vla-Item tbobject i)) out)) 
                (setq i (1+ i)) 
        ) 
        out 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-Button 
;;; DESCRIPTION: Returns button object from given toolbar using button name 
;;; ARGS: toolbar (vla-object), button-name (string) 
;;; EXAMPLE: (ASW-Toolbar-Button myToolbar "Button1") 
;;;************************************************************************* 
 
(defun Toolbar-Button (tbobject btname / out) 
        (vla-Item tbobject btname) 
) 
 
; IAcadToolbarItem: A single button item on an AutoCAD toolbar 
; Property values: 
;   Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8> 
;   Flyout (RO) = AutoCAD: The toolbar item is not a flyout button 
;   HelpString = "Insert a plain or reducing coupling: CPL" 
;   Index (RO) = 0 
;   Macro = "\003\003\020(ASWLF (list '(c:pff07 "pff07")))\npff07 " 
;   Name = "Coupling" 
;   Parent (RO) = #<VLA-OBJECT IAcadToolbar 00f676bc> 
;   TagString = "ID_ASWP023" 
;   Type (RO) = 0 
; Methods supported: 
;   AttachToolbarToFlyout (2) 
;   Delete () 
;   GetBitmaps (2) 
;   SetBitmaps (2) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-ButtonAdd 
;;; DESCRIPTION: Add new button to given toolbar object, returns button object 
;;; ARGS: toolbar-object, button-name, macro-string, bitmap-name, tagstring, helpstring 
;;; EXAMPLE: (ASW-Toolbar-ButtonAdd myToolbar "Button1" "\003\003\020\nLine" "ICON_16_LINE" "Button001" "Draws a line: LINE") 
;;;************************************************************************* 
 
(defun Toolbar-ButtonAdd 
        (tbobject name macro bitmap1 tagstring helpstring / newButton index) 
        (setq index (vla-get-Count tbobject)) 
        (cond 
                ( (setq newButton (vla-AddToolbarButton tbobject 
                                                                                                (vlax-make-variant index vlax-vbInteger) 
                                                                                                name 
                                                                                                helpstring 
                                                                                                macro 
                                                                                        ) 
                        ) 
                  (vla-put-TagString newButton tagstring) 
                  (vla-SetBitMaps newButton bitmap1 bitmap1) 
                  newButton 
                ) 
        ) 
) 
 
(defun C:ADDTB ( / tb buttons) 
        (if 
                (or 
                        (setq tb (ASW-Toolbar G$APP "Foo")) 
                        (setq tb (ASW-Toolbar-Add G$APP "Foo")) 
                ) 
                (progn 
                        (setq buttons (vla-get-Count tb)) 
                        (ASW-Toolbar-ButtonAdd tb (strcat "Button" (itoa buttons)) 
                                "\003\003\020\nLINE" 
                                "ICON_16_LINE" 
                                (strcat "FooButton" (itoa buttons)) 
                                "Draws a line: LINE" 
                        ) 
                ) 
        ) 
        (princ) 
) 
 
(defun C:DELTB ( / tb buttons) 
        (if (setq tb (ASW-Toolbar G$APP "Foo")) 
                (progn 
                        (vla-Delete tb) 
                        (vlax-release-object tb) 
                ) 
        ) 
         (princ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-ButtonDelete 
;;; DESCRIPTION: Removes named button from given toolbar object 
;;; ARGS: toolbar-object, button-name 
;;; EXAMPLE: (ASW-Toolbar-ButtonDelete myToolbar "Button1") 
;;;************************************************************************* 
 
(defun Toolbar-ButtonDelete (tbobject name / btn) 
        (if (setq btn (ASW-Toolbar-Button tbobject name)) 
                (progn 
                        (vla-Delete btn) 
                        (vlax-release-object btn) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-Show 
;;; DESCRIPTION: Un-Hides a named toolbar 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar-Show "ASW2K" "ASW: Sheets") 
;;;************************************************************************* 
 
(defun Toolbar-Show (mgroup tbname / tb) 
  (if (setq tb (ASW-Toolbar mgroup tbname)) 
          (if (= (vla-get-Visible tb) :vlax-False) 
                        (progn 
                                (vla-put-Visible tb :vlax-True) 
                                T 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-Hide 
;;; DESCRIPTION: Hides a named toolbar 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar-Hide "ASW2K" "ASW: Sheets") 
;;;************************************************************************* 
 
(defun Toolbar-Hide (mgroup tbname / tb) 
  (if (setq tb (ASW-Toolbar mgroup tbname)) 
          (if (= (vla-get-Visible tb) :vlax-True) 
                        (progn 
                          (vla-put-Visible tb :vlax-False) 
                                T 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-Dock 
;;; DESCRIPTION: Dock named toolbar in one of four locations 
;;; ARGS: menugroup-name, toolbar-name, location (acToolbarDockTop, acToolbarDockBottom, acToolbarDockLeft, acToolbarDockRight) 
;;; EXAMPLE: (ASW-Toolbar-Dock "ASW2K" "Sheets" 2) --> docks on left side of window 
;;;*************************************************************************;;; 
 
(defun Toolbar-Dock (mgroup tbname dock / tb) 
  (if (setq tb (ASW-Toolbar mgroup tbname)) 
          (if (= (vla-get-Visible tb) :vlax-True) 
                        (if (member dock '(0 1 2 3)) 
                                (progn 
                                        (vla-Dock tb dock) 
                                        1 
                                ) 
                                -2 ;; invalid parameter value 
                        ) 
                        -1 ;; toolbar not visible 
          ) 
                0 ;; toolbar not found 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-DockTop 
;;; DESCRIPTION: Dock named toolbar at top of screen 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar-DockTop "ASW2K" "ASW: PowerPlot") 
;;;************************************************************************* 
 
(defun Toolbar-DockTop (mgroup tbname) 
        (if (setq tbobject (ASW-Toolbar mgroup tbname)) 
                (vla-Dock tbobject acToolbarDockTop) 
                (princ (strcat "\nToolbar (" tbname ") not found.")) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-DockBottom 
;;; DESCRIPTION: Dock named toolbar at bottom of screen 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar-DockBottom "ASW2K" "ASW: PowerPlot") 
;;;************************************************************************* 
 
(defun Toolbar-DockBottom (mgroup tbname) 
        (if (setq tbobject (ASW-Toolbar mgroup tbname)) 
                (vla-Dock tbobject acToolbarDockBottom) 
                (princ (strcat "\nToolbar (" tbname ") not found.")) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-DockLeft 
;;; DESCRIPTION: Dock named toolbar at left of screen 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar-DockLeft "ASW2K" "ASW: PowerPlot") 
;;;************************************************************************* 
 
(defun Toolbar-DockLeft (mgroup tbname) 
        (if (setq tbobject (ASW-Toolbar mgroup tbname)) 
                (vla-Dock tbobject acToolbarDockLeft) 
                (princ (strcat "\nToolbar (" tbname ") not found.")) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-DockRight 
;;; DESCRIPTION: Dock named toolbar at right of screen 
;;; ARGS: menugroup-name, toolbar-name 
;;; EXAMPLE: (ASW-Toolbar-DockRight "ASW2K" "ASW: PowerPlot") 
;;;************************************************************************* 
 
(defun Toolbar-DockRight (mgroup tbname) 
        (if (setq tbobject (ASW-Toolbar mgroup tbname)) 
                (vla-Dock tbobject acToolbarDockRight) 
                (princ (strcat "\nToolbar (" tbname ") not found.")) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbar-Float 
;;; DESCRIPTION: Position named toolbar at specified location 
;;; ARGS: menugroup-name, toolbar-name, top-int, left-int, rows-int 
;;; EXAMPLE: (ASW-Toolbar-Float "ASW2K" "Sheets" 200 300 1) 
;;;************************************************************************* 
 
(defun Toolbar-Float (mgroup tbname top left rows) 
  (if (setq tb (ASW-Toolbar mgroup tbname)) 
                (if (= (vla-get-Visible tb) :vlax-True) 
                        (progn 
                                (vla-Float tb top left rows) 
                                1 
                        ) 
                        -1 ;; toolbar not visible 
                ) 
                0 ;; toolbar not found 
        ) 
) 
 
;;;*************************************************************************\ 
;;; MODULE: Menu-Locate 
;;; DESCRIPTION: Returns full path+filename for named menu file 
;;; ARGS: menu-filename (without extension) 
;;; EXAMPLE: (ASW-Menu-Locate "asw2k") 
;;;************************************************************************;;; 
 
(defun MENU-LOCATE (mnfn) 
        (DPR "\n(ASW-MENU-LOAD)") 
        
        (cond 
                ;( (findfile (strcat mnfn ".mnc")) ) 
                ;( (findfile (strcat mnfn ".mns")) ) 
                ( (findfile (strcat mnfn ".mnu")) ) 
                ( (findfile (strcat G$MENU "\" mnfn ".mnu")) ) 
                ( (findfile (strcat G$ASL  "\" mnfn ".mnu")) ) 
                ( (findfile (strcat G$SYS "\\Menu\" mnfn ".mnu")) ) 
                ( T nil ) 
        ) 
) 
 
;;;******************************************************************** 
;;; Force menu reload/recompile 
;;;******************************************************************** 
 
(if (null C:UPDATE) 
        (defun C:UPDATE () 
                (load "update.vlx") 
                (C:UPDATE) 
                (princ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Menu-ReLoadAll 
;;; DESCRIPTION: Reloads and repositions (merges) all ShipWorks menu stubs 
;;; ARGS: none 
;;; EXAMPLE: (ASW-Menu-ReLoadAll) 
;;;******************************************************************** 
 
(defun MENU-RELOADALL ( / cmdstr appkey local_copy client-menu) 
        (DPR "\n(ASW-MENU-RELOADALL)") 
        (setq client-menu (vl-filename-base G$PRO)) 
        (setq cmdstr (strcat "COPY " G$MENU "\\ASW2K.MNU " G$DAT "\\ASW2K.MNU")) 
        (vl-cmdf "SHELL" cmdstr) 
        (setq cmdstr (strcat "COPY " G$ASL "\" G$APP ".MNU " G$DAT "\" G$APP ".MNU")) 
        (vl-cmdf "SHELL" cmdstr) 
        (cond 
                ( (findfile (strcat G$MENU "\" client-menu ".MNU")) 
                  (setq cmdstr (strcat "COPY " G$MENU "\" client-menu ".MNU " G$DAT "\" client-menu ".MNU")) 
                  (vl-cmdf "SHELL" cmdstr) 
                ) 
        ) 
                
        (princ "\nMenus downloaded to client folder.") 
        (cond 
                ( (menugroup "ASW2K") 
                  (DPR "\nRemoving base services menu stub...") 
                  (vl-cmdf "MENUUNLOAD" "ASW2K") 
           ) 
        ) 
        (cond 
                ( (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu"))) 
                  (vl-cmdf "MENULOAD" local_copy) 
                        (if (menugroup "ASW2K") 
                                (menucmd "P4=+ASW2K.POP1") 
                                (princ "\nFailed (1)!") 
                        ) 
          ) 
          ( T (princ "\nFailed (2)!") ) 
        ) 
        
        (cond 
                ( (menugroup G$APP) 
                  (foreach appkey '("ASW2K-S" "ASW2K-E" "ASW2K-P" "ASW2K-V") 
                                (if (menugroup appkey) 
                                        (vl-cmdf "MENUUNLOAD" appkey) 
                                ) 
                        ) 
                ) 
        ) 
        (cond 
                ( (setq local_copy (findfile (strcat G$DAT "\" G$APP ".mnu"))) 
                  (vl-cmdf "MENULOAD" local_copy) 
                  (if (menugroup G$APP) 
                          (menucmd (strcat "P5=+" G$APP ".POP1")) 
                                (princ "\nFailed (3)!") 
                        ) 
                ) 
                ( T 
                  (princ "\nFailed (4)!") 
                ) 
        ) 
        (cond 
                ( (menugroup client-menu) 
                  (DPR "\nRemoving client-specific menu stub...") 
                  (vl-cmdf "MENUUNLOAD" client-menu) 
                ) 
        ) 
        (cond 
                ( (setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu"))) 
                  (vl-cmdf "MENULOAD" local_copy) 
                  (if (menugroup client-menu) 
                          (menucmd (strcat "P6=+" client-menu ".POP1")) 
                                (princ "\nFailed (5)!") 
                        ) 
                ) 
                ( T 
                  (princ "\nFailed (6)!") 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: MenuMerge 
;;; DESCRIPTION: Loads and positions all ShipWorks menu stubs 
;;; ARGS: none 
;;; EXAMPLE: (ASW-MenuMerge) 
;;;******************************************************************** 
 
(defun MenuMerge 
        ( / local_copy remote_copy client-menu) 
  (DPR "\n(ASW-MenuMerge)") 
        (cond 
                ( (menugroup "ASW2K") 
                  (vl-cmdf "MENUUNLOAD" "ASW2K") 
                  (if (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu"))) 
                                (vl-File-Delete local_copy) 
                        ) 
                  (vl-File-Copy (strcat G$MENU "\\asw2k.mnu") (strcat G$DAT "\\asw2k.mnu")) 
                  (if (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu"))) 
                          (progn 
                                        (vl-cmdf "MENULOAD" local_copy) 
                                        (menucmd "P4=+ASW2K.POP1") 
                                ) 
                                (princ "\nFailed to reload new base menu update.") 
                        ) 
                ) 
                ;; Cond-2: Local MNU exists, load it 
                ( (and 
                                (not (menugroup "ASW2K")) 
                                (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu"))) 
                        ) 
                  (DPR "\nReloading from local directory...") 
                  (vl-cmdf "MENULOAD" local_copy) 
                  (if (menugroup "ASW2K") 
                                (menucmd "P4=+ASW2K.POP1") 
                                (princ "\nFailed to load local copy of ShipWorks Base menu.") 
                        ) 
                ) 
                ;; Cond-3: Remote MNU exists, copy to local, load local copy 
                ( (and 
                                (not (menugroup "ASW2K")) 
                                (setq remote_copy (findfile (strcat G$MENU "\\asw2k.mnu"))) 
                                (vl-File-Copy remote_copy (strcat G$DAT "\\asw2k.mnu")) 
                                (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu"))) 
                        ) 
                  ;(vl-cmdf "delay" 400) 
                  (DPR "\nReloading from new download copy...") 
                        (vl-cmdf "MENULOAD" local_copy) 
                  (if (menugroup "ASW2K") 
                                (menucmd "P4=+ASW2K.POP1") 
                                (princ "\nFailed to load remote copy of ShipWorks Base menu.") 
                        ) 
                ) 
                ;; Cond-4: Horrible failure, cry in shame 
                ( T (princ "\nSystem failure: Unable to download server menu update.")) 
        ); cond 
        (setq remote_copy nil local_copy nil) 
        (cond 
                ( (menugroup G$APP) 
                  (vl-cmdf "MENUUNLOAD" G$APP) 
                  (if (setq local_copy (findfile (strcat G$DAT "\" G$APP ".mnu"))) 
                                (vl-File-Delete local_copy) 
                        ) 
                  (vl-File-Copy (strcat G$ASL "\" G$APP ".mnu") (strcat G$DAT "\" G$APP ".mnu")) 
                  (if (setq local_copy (findfile (strcat G$DAT "\" G$APP ".mnu"))) 
                          (progn 
                                        (vl-cmdf "MENULOAD" local_copy) 
                                        (menucmd (strcat "P5=+" G$APP ".POP1")) 
                                ) 
                                (princ "\nFailed to reload new extended services menu update.") 
                        ) 
                );; Cond-2: Local MNU exists, load it 
                ( (and 
                                (not (menugroup G$APP)) 
                                (setq local_copy (findfile (strcat G$DAT "\" G$DAT ".mnu"))) 
                        ) 
                  (DPR "\nReloading from local directory...") 
                        (vl-cmdf "MENULOAD" local_copy) 
                        (if (menugroup G$APP) 
                                (menucmd (strcat "P5=+" G$APP ".POP1")) 
                                (princ "\nFailed to load local copy of extended services menu.") 
                        ) 
                ) 
                ;; Cond-3: Remote MNU exists, copy to local, load local copy 
                ( (and 
                                (not (menugroup G$APP)) 
                                (setq remote_copy (findfile (strcat G$ASL "\" G$APP ".mnu"))) 
                                (vl-File-Copy remote_copy (strcat G$DAT "\" G$APP ".mnu")) 
                                (setq local_copy (findfile (strcat G$DAT "\" G$APP ".mnu"))) 
                        ) 
                  ;(vl-cmdf "delay" 400) 
                  (DPR "\nReloading from downloaded copy...") 
                  (vl-cmdf "MENULOAD" local_copy) 
                  (if (menugroup G$APP) 
                          (menucmd (strcat "P5=+" G$APP ".POP1")) 
                                (princ "\nFailed to load remote copy of extended services menu.") 
                        ) 
                ) 
                ;; Cond-4: Oh my God, two failures?  What a shame 
                ( T (princ "\nSystem Failure: Unable to download server menu update.") ) 
        ); cond 
        (DPR "\nChecking for project-based client menus...") 
        (setq client-menu (vl-filename-base G$PRO)) 
        (cond 
                ( (menugroup client-menu) 
                  (vl-cmdf "MENUUNLOAD" client-menu) 
                  (if (setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu"))) 
                                (vl-File-Delete local_copy) 
                        ) 
                  (vl-File-Copy (strcat G$MENU "\" G$APP ".mnu") (strcat G$DAT "\" client-menu ".mnu")) 
                  (if (setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu"))) 
                          (progn 
                                        (vl-cmdf "MENULOAD" local_copy) 
                                        (menucmd (strcat "P6=+" client-menu ".POP1")) 
                                ) 
                                (princ "\nFailed to reload new client-specific menu update.") 
                        ) 
                );; Cond-2: Local MNU exists, load it 
                ( (and 
                                (not (menugroup client-menu)) 
                                (setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu"))) 
                        ) 
                  (DPR "\nReloading from local directory...") 
                        (vl-cmdf "MENULOAD" local_copy) 
                        (if (menugroup client-menu) 
                                (menucmd (strcat "P6=+" client-menu ".POP1")) 
                                (princ "\nFailed to load local copy of client-specific menu.") 
                        ) 
                ) 
                ;; Cond-3: Remote MNU exists, copy to local, load local copy 
                ( (and 
                                (not (menugroup client-menu)) 
                                (setq remote_copy (findfile (strcat G$MENU "\" client-menu ".mnu"))) 
                                (vl-File-Copy remote_copy (strcat G$DAT "\" client-menu ".mnu")) 
                                (setq local_copy (findfile (strcat G$DAT "\" client-menu ".mnu"))) 
                        ) 
                  ;(vl-cmdf "delay" 400) 
                  (DPR "\nReloading from downloaded copy...") 
                  (vl-cmdf "MENULOAD" local_copy) 
                  (if (menugroup client-menu) 
                          (menucmd (strcat "P6=+" client-menu ".POP1")) 
                                (princ "\nFailed to load remote copy of client-specific menu.") 
                        ) 
                ) 
                ;; Cond-4: Oh my God, two failures?  What a shame 
                ( T (princ "\nSystem Failure: Unable to download server menu update.") ) 
        )        
        (DPR "\nSearching for Express Tools stub menu to load...") 
        
  (cond 
    ( (and 
        (not (menugroup "EXPRESS")) 
                                (or 
                (setq expmn (findfile "acetmain.mnu")) 
                                        (setq expmn (findfile "express.mnu")) 
                                ) 
                        ) 
                  (princ "\nLoading AutoCAD Express Tools menus...") 
      (vl-cmdf "_.MENULOAD" expmn) 
      (if (menugroup "EXPRESS") 
        (menucmd "P9=+EXPRESS.POP1") 
        (alert "Failed to load Express Tools menus...") 
      ) 
    ) 
  ) 
); defun 
 
;;;************************************************************************* 
;;; MODULE: Menu-DeleteFiles 
;;; DESCRIPTION: Deletes all four extension-type files for named menu file 
;;; ARGS: basename (without extension), pathname 
;;; EXAMPLE: (ASW-Menu-DeleteFiles "mymenu" "c:\\mystuff") 
;;;************************************************************************* 
 
(defun MENU-DeleteFiles 
        (menubase pathname / mnuext mnu) 
        (DPR "\n(ASW-MENU-DeleteFiles)") 
        (foreach mnuext '(".mnu" ".mns" ".mnc" ".mnr") 
                (if (setq mnu (findfile (strcat pathname "\" menubase mnuext))) 
                        (progn 
                                (DPR (strcat "\nDeleting menu file: " mnu)) 
                                (vl-File-Delete mnu) 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Menu-CompareDates 
;;; DESCRIPTION: Compare file dates, returns T if file1 is same or newer than file2 
;;; ARGS: filename1, filename2 
;;; EXAMPLE: (ASW-Menu-CompareDates localMenu serverMenu) returns T (filename1 is same or newer than filename2) 
;;;************************************************************************* 
 
(defun Menu-CompareDates (f1 f2 / st1 st2) 
        (if 
          (and 
                        (setq f1 (findfile f1)) 
                        (setq f2 (findfile f2)) 
                        (setq st1 (vl-file-systime f1)); (2001 2 2 13 10 53 12 855) 
                        (setq st2 (vl-file-systime f2)); (2001 2 2 13 10 53 12 855) 
                ) 
                (if (> (nth 0 st1) (nth 0 st2));; newer year? 
                        T 
                        (if (= (nth 0 st1) (nth 0 st2));; same year? 
                                (if (> (nth 1 st1) (nth 1 st2));; newer month? 
                                        T 
                                        (if (> (nth 3 st1) (nth 3 st2));; newer day of month? 
                                                T 
                                                (if (= (nth 3 st1) (nth 3 st2));; same day of month? 
                                                        (if (> (nth 4 st1) (nth 4 st2));; newer hour of day? 
                                                                T 
                                                                (if (= (nth 4 st1) (nth 4 st2));; same hour of day? 
                                                                        (if (>= (nth 5 st1) (nth 5 st1));; newer minutes of same hour? 
                                                                                T 
                                                                        ) 
                                                                ) 
                                                        ) 
                                                ) 
                                        ) 
                                ) 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Menu-CheckDates 
;;; DESCRIPTION: Compare menu filenames dates between two folders 
;;; ARGS: none 
;;; EXAMPLE: 
;;;************************************************************************* 
 
(defun Menu-CheckDates 
        (forceload / choice fail) 
        (DPR "\n(ASW-Menu-CheckDates)") 
        (cond 
                ( (not 
                                (ASW-Menu-CompareDates 
                                        (strcat G$DAT "\\asw2k.mnu") 
                                        (strcat G$MENU "\\asw2k.mnu") 
                                ) 
                        ) 
                  (setq fail 1) 
                ) 
        ) 
        (cond 
                ( (not 
                                (ASW-Menu-CompareDates 
                                        (strcat G$DAT "\" G$APP ".mnu") 
                                        (strcat G$ASL "\" G$APP ".mnu") 
                                ) 
                        ) 
                  (if fail 
                                (setq fail 2) 
                                (setq fail -1) 
                        ) 
                ) 
        ) 
        (cond 
                ( (= fail 1) (DPR "\nBase menu failed comparison.") ) 
                ( (= fail 2) (DPR "\nBoth menus failed comparison.") ) 
                ( (= fail -1)(DPR "\nExtended menu failed comparison.") ) 
                ( T (DPR "\nMenus are up to date.") ) 
        ) 
        (cond 
                ( (and fail (not forceload)) 
                        (setq choice 
                                (DOS_MsgBox 
                                        (strcat 
                                                        "One of your ShipWorks menus is out of date." 
                                                "\nYou can update it now by picking the Yes" 
                                                "\nbutton, or pick No to defer until later.\n" 
                                                "\nIf you defer now, you will be reminded each" 
                                                "\ntime you open a drawing until you update." 
                                        ) 
                                        "ShipWorks Menu Update" 
                                        4 3 
                                ) 
                        ) 
                  (if (= 6 choice) 
                                (ASW-MENU-RELOADALL) 
                                (princ "\nShipWorks menu update notice deferred.") 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbars-HideAll 
;;; DESCRIPTION: Hide all toolbars related to specified menugroup 
;;; ARGS: menugroup-name 
;;; EXAMPLE: (ASW-Toolbars-HideAll "ASW2K") 
;;;************************************************************************* 
 
(defun Toolbars-HideAll (mgroup / tbars) 
        (cond 
                ( (setq tbars (asw-toolbars-listall mgroup)) 
                  (foreach tbar tbars 
                                (ASW-Toolbar-Hide mgroup tbar) 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbars-ShowAll 
;;; DESCRIPTION: Show all toolbars related to specified menugroup 
;;; ARGS: menugroup-name 
;;; EXAMPLE: (ASW-Toolbars-ShowAll "ASW2K") 
;;;************************************************************************* 
 
(defun Toolbars-ShowAll (mgroup / tbars) 
        (cond 
                ( (setq tbars (asw-toolbars-listall mgroup)) 
                  (foreach tbar tbars 
                                (ASW-Toolbar-Show mgroup tbar) 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Toolbars-Hidden 
;;; DESCRIPTION: Returns list of toolbars that are hidden for a specified menugroup 
;;; ARGS: menugroup-name 
;;; EXAMPLE: (ASW-Toolbars-Hidden "ASW2K") returns ("toolbar1" "toolbar2"...) 
;;;************************************************************************* 
 
(defun Toolbars-Hidden (mgroup / tbars each tbar) 
        (cond 
                ( (setq tbars (ASW-Toolbars-ListAll mgroup)) 
                  (foreach each tbars 
                                (setq tbar (ASW-Toolbar mgroup each)) 
                                (if (= :vlax-True (vla-get-Visible tbar)) 
                                        (setq out (cons (vla-get-name tbar) out)) 
                                ) 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: C:TBOFF 
;;; DESCRIPTION: Turns off ShipWorks toolbars 
;;; ARGS: none 
;;; EXAMPLE: 
;;;************************************************************************* 
 
(defun C:TBOFF ( / hbars1 hbars2) 
        (setq G$TBOFF1 (KWORD '("A""V") "Hide All toolbars or Visible toolbars only..." G$TBOFF1 T)) 
        (cond 
                ( (= G$TBOFF1 "V") 
                  (setq G$TBOFF2 (ASW-Toolbars-Hidden "ASW2K")) 
                  (setq G$TBOFF3 (ASW-Toolbars-Hidden G$APP)) 
                ) 
        ) 
        (ASW-Toolbars-HideAll "ASW2K") 
        (ASW-Toolbars-HideAll G$APP) 
        (princ) 
) 
 
;;;************************************************************************* 
;;; MODULE: C:TBON 
;;; DESCRIPTION: Turns on ShipWorks toolbars 
;;; ARGS: none 
;;; EXAMPLE: 
;;;************************************************************************* 
 
(defun C:TBON ( / opt) 
        (cond 
                ( (and G$TBOFF1 (= G$TBOFF1 "V") (or G$TBOFF2 G$TBOFF3)) 
                  (setq opt (KWORD '("A""H") "Display All toolbars or only those Hidden before..." opt T)) 
                  (cond 
                                ( (= opt "A") 
                                        (ASW-Toolbars-ShowAll "ASW2K") 
                                        (ASW-Toolbars-ShowAll G$APP) 
                                ) 
                                ( T 
                                  (if G$TBOFF2 
                                          (vlax-for each (ASW-Toolbars "ASW2K") 
                                                        (setq tbname (vla-get-name each)) 
                                                        (if (member tbname G$TBOFF2) 
                                                                (ASW-Toolbar-Show "ASW2K" tbname) 
                                                        ) 
                                                ) 
                                        ) 
                                  (if G$TBOFF3 
                                          (vlax-for each (ASW-Toolbars G$APP) 
                                                        (setq tbname (vla-get-name each)) 
                                                        (if (member tbname G$TBOFF3) 
                                                                (ASW-Toolbar-Show G$APP tbname) 
                                                        ) 
                                                ) 
                                        ) 
                                ) 
                        ); cond 
                ) 
                ( T 
                        (ASW-Toolbars-ShowAll "ASW2K") 
                        (ASW-Toolbars-ShowAll G$APP) 
                ) 
        ) 
        (princ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Menu-SaveAll 
;;; DESCRIPTION: Saves all ShipWorks menu settings to MNS or MNC files 
;;; ARGS: menu-type ("mns" or "mnc") not case sensitive, nil = "mns" 
;;; EXAMPLE: (ASW-Menu-SaveAll "mnc") returns nil 
;;;************************************************************************* 
 
(defun MENU-SAVEALL (mtype) 
        (DPR "\n(ASW-MENU-SAVEALL)") 
        (vlax-for each (Get-MenuGroups) 
                (if (wcmatch (strcase (vla-get-name each)) "ASW2K*") 
                        (if (= (strcase mtype) "MNC") 
                                (vla-save each acMenuFileCompiled) 
                                (vla-save each acMenuFileSource) 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: MenuUpdate-LoadClientMenus 
;;; DESCRIPTION: Loads client menu files as menugroups for ShipWorks session 
;;; ARGS: none 
;;; EXAMPLE: 
;;;************************************************************************* 
 
(defun MenuUpdate-LoadClientMenus 
        ( / mg svclist svcmnu) 
        (ASW-PRINC "\n(ASW-MenuUpdate-LoadClientMenus)") 
        (princ "\nLoading ShipWorks menugroups from client folder...") 
        (setq svclist 
                '("ASW2K-E" "&Electrical" "ASW2K-P" "&Piping" "ASW2K-S" "&Structure" "ASW2K-V" "HVAC") 
                                svcmnu (cadr (member G$APP svclist)) 
        ) 
        (cond 
                ( (not (menugroup "asw2k")) 
                  (if (setq mg (asw-menu-load "asw2k" (strcat G$DAT "\\asw2k.mnu"))) 
                                (progn 
                                        (if (ASW-PopMenu-Insert "asw2k" "&ShipWorks" 4) 
                                                (princ "\nBase menubar loaded from file.") 
                                        ) 
                                        (vlax-release-object mg) 
                                ) 
                        ) 
                ) 
                ( T 
                  (if (not (ASW-PopMenu-MenuBar-p "&ShipWorks")) 
                                (if (ASW-PopMenu-Insert "asw2k" "&ShipWorks" 4) 
                                        (princ "\nBase menubar loaded.") 
                                        (princ "\nFailed to get base popmenu from menugroup collection.") 
                                ) 
                        ) 
                ) 
        ) 
        (if 
                (and 
                        (/= G$APP "ASW2K-E") 
                        (menugroup "ASW2K-E") 
                ) 
                (ASW-Menu-UnLoad "ASW2K-E") 
        ) 
        (if 
                (and 
                        (/= G$APP "ASW2K-P") 
                        (menugroup "ASW2K-P") 
                ) 
                (ASW-Menu-Unload "ASW2K-P") 
        ) 
        (if 
                (and 
                        (/= G$APP "ASW2K-S") 
                        (menugroup "ASW2K-S") 
                ) 
                (ASW-Menu-Unload "ASW2K-S") 
        ) 
        (if 
                (and 
                        (/= G$APP "ASW2K-V") 
                        (menugroup "ASW2K-V") 
                ) 
                (ASW-Menu-Unload "ASW2K-V") 
        ) 
        (cond 
                ( (not (menugroup G$APP)) 
                  (if (setq mg (asw-menu-load G$APP (strcat G$DAT "\" G$APP ".mnu"))) 
                                (progn 
                                        (if (ASW-PopMenu-Insert G$APP svcmnu 5) 
                                                (princ (strcat "\nService menubar loaded from file: " G$APP)) 
                                        ) 
                                        (vlax-release-object mg) 
                                ) 
                        ) 
                ) 
                ( T 
                         (if (not (ASW-PopMenu-MenuBar-p svcmnu)) 
                                (if (ASW-PopMenu-Insert G$APP svcmnu 5) 
                                        (princ "\nServer menubar loaded.") 
                                        (princ "\nFailed to get service popmenu from menugroup collection.") 
                                ) 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: MenuUpdate-DeleteClientFiles 
;;; DESCRIPTION: Deletes client-side menu files for ShipWorks 
;;; ARGS: none 
;;; EXAMPLE: 
;;;************************************************************************* 
 
(defun MenuUpdate-DeleteClientFiles 
        ( / mfile) 
        (ASW-PRINC "\n(ASW-MenuUpdate-DeleteClientFiles)") 
        (foreach mext '(".mnu" ".mns" ".mnc" ".mnr") 
                (if (setq mfile (findfile (strcat G$DAT "\\asw2k" mext))) 
                        (if (vl-file-delete mfile) 
                                (princ);(princ (strcat "\nDeleted menu file: " mfile)) 
                                (princ (strcat "\nFailed to delete menu file: " mfile)) 
                        ) 
                ) 
        ) 
        (foreach mext '(".mnu" ".mns" ".mnc" ".mnr") 
                (if (setq mfile (findfile (strcat G$DAT "\" G$APP mext))) 
                        (if (vl-file-delete mfile) 
                                (princ);(princ (strcat "\nDeleted menu file: " mfile)) 
                                (princ (strcat "\nFailed to delete menu file: " mfile)) 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: MenuUpdate-UnloadMenus 
;;; DESCRIPTION: Unloads all ShipWorks menugroups 
;;; ARGS: none 
;;; EXAMPLE: 
;;;************************************************************************* 
 
(defun MenuUpdate-UnloadMenus () 
        (ASW-PRINC "\n(ASW-MenuUpdate-UnloadMenus)") 
        (princ "\nUnloading ShipWorks menugroups...") 
        (ASW-Menu-Unload "asw2k") 
        (foreach n '("ASW2K-E" "ASW2K-P" "ASW2K-S" "ASW2K-V") 
                (ASW-Menu-Unload n) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: MenuUpdate-DownloadMenus 
;;; DESCRIPTION: Downloads server files to client for all ShipWorks menus 
;;; ARGS: none 
;;; EXAMPLE: 
;;;************************************************************************* 
 
(defun MenuUpdate-DownloadMenus 
        ( / msrc1 msrc2 mtarget1 mtarget2 go) 
        (ASW-PRINC "\n(ASW-MenuUpdate-DownloadMenus)") 
        (cond 
                ( (setq msrc1 (findfile (strcat G$MENU "\\asw2k.mnu"))) 
                  (if (setq mtarget1 (findfile (strcat G$DAT "\\asw2k.mnu"))) 
                                (if (vl-file-delete mtarget1) 
                                        (setq go T) 
                                ) 
                                (setq go T) 
                        ) 
                  (if go 
                                (if (vl-file-copy msrc1 (strcat G$DAT "\\asw2k.mnu")) 
                                        (princ "\nBase menu file downloaded successfully.") 
                                        (princ "\nFailed to download base menu file!") 
                                ) 
                                (princ "\nFailed to remove client base menu cache, download failed.") 
                        ) 
                ) 
        ) 
        (setq go nil) 
        (cond 
                ( (setq msrc2 (findfile (strcat G$MENU "\" G$APP ".mnu"))) 
                  (if (setq mtarget2 (findfile (strcat G$DAT "\" G$APP ".mnu"))) 
                                (if (vl-file-delete mtarget2) 
                                        (setq go T) 
                                ) 
                                (setq go T) 
                        ) 
                  (if go 
                                (if (vl-file-copy msrc2 (strcat G$DAT "\" G$APP ".mnu")) 
                                        (princ "\nService menu file downloaded successfully.") 
                                        (princ "\nFailed to download service menu file!") 
                                ) 
                                (princ "\nFailed to remove client service menu cache, download failed.") 
                        ) 
                ) 
        ) 
) 
                  
(defun ObjErr (errobj) 
        (princ (strcat "\nError: " (vl-catch-all-error-message errobj))) 
) 
 
(defun Obj-ReleaseAll (objects) 
        (foreach obj objects 
                (if (= (type obj) 'vla-object); symbol bound to vla-object type? 
                        (if (not (vlax-object-released-p obj)); not already released? 
                                (vlax-release-object obj); release it! 
                        ) 
                ) 
                (set (quote obj) nil) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Menu-LoadPartialMenus 
;;; DESCRIPTION: Loads default menu items for ShipWorks at start-up 
;;; ARGS: none 
;;; EXAMPLE: (ASW-Menu-LoadPartialMenus) 
;;;************************************************************************* 
 
(defun Menu-LoadPartialMenus 
        ( / mgroups mgnames omg mgf) 
        (ASW-Princ "\n(ASW-Menu-LoadPartialMenus)") 
        (if (not (menugroup "asw2k")) 
                (progn 
                        (ASW-MenuUpdate-UnloadMenus) 
                        (ASW-MenuUpdate-DeleteClientFiles) 
                        (ASW-MenuUpdate-DownloadMenus) 
                        (ASW-MenuUpdate-LoadClientMenus) 
                ) 
                (ASW-MenuUpdate-LoadClientMenus) 
        ) 
        (setq mgroups (Get-MenuGroups) 
                                mgnames (Get-MenuGroups-listall) 
        ) 
        (if (and C:UPDATE (null (menugroup "asw2k"))) (C:UPDATE)) 
        (if (not (menugroup G$APP)) 
                (progn 
                        (princ "\nReloading extended services menu group...") 
                        (foreach mg '("ASW2K-E" "ASW2K-P" "ASW2K-S" "ASW2K-V") 
                                (if 
                                        (and 
                                                (member mg mgnames) 
                                                (setq omg (vla-item mg mgroups)) 
                                        ) 
                                        (vla-unload omg) 
                                        (vlax-release-object omg) 
                                ) 
                        ); foreach - unload 
                        (cond 
                                ( (or 
                                                (setq mgf (findfile (strcat G$APP ".mns"))) 
                                                (setq mgf (findfile (strcat G$APP ".mnc"))) 
                                        ) 
                                  (princ "\nLoading ShipWorks partial menu data...") 
                                  (vla-load mgroups mgf) 
                                  (if (menugroup G$APP) 
                                                (menucmd (strcat "P5=+" G$APP ".POP1")) 
                                                (princ (strcat "\nUnable to load partial menu for service: " G$APP)) 
                                        ) 
                                ) 
                                ( T 
                                  (C:UPDATE) 
                                ) 
                        ) 
                ) 
                (princ "\nMenugroup already loaded."); menugroup already loaded, do nothing 
        ) 
        (princ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Menu-Unload 
;;; DESCRIPTION: Unloads specified menugroup, returns if successful or menugroup not loaded 
;;; ARGS: menugroup-name 
;;; EXAMPLE: (ASW-Menu-Unload "ASW2K") 
;;;************************************************************************* 
 
(defun Menu-Unload (name / omg) 
        (ASW-PRINC "\n(ASW-Menu-Unload)") 
        (if (menugroup name) 
                (if (setq omg (vla-item (Get-MenuGroups) name)) 
                        (progn 
                                (vla-unload omg) 
                                (vlax-release-object omg) 
                                T 
                        ) 
                ) 
                T 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: Menu-Reload 
;;; DESCRIPTION: Reloads menugroup popmenu if loaded, loads otherwise 
;;; ARGS: menugroup-name, path to menufile 
;;; EXAMPLE: 
;;;************************************************************************* 
 
(defun Menu-Reload (name path / mnu1) 
        (ASW-PRINC "\n(ASW-Menu-Reload)") 
  (cond 
                ( (menugroup name) 
                  (menucmd (strcat "P5=+" name ".POP1")) 
                ) 
                ( (or 
                                (setq mnu1 (findfile (strcat path "\" name ".mns"))) 
                                (setq mnu1 (findfile (strcat path "\" name ".mnc"))) 
                        ) 
                  (vl-cmdf "_.menuload" mnu1) 
                  (menucmd (strcat "P5=+" name ".POP1")) 
                ) 
                ( T (C:UPDATE) ) 
        ) 
) 
 
(defun PopMenu-Insert (mgroup name loc / pmnu) 
        (ASW-PRINC "\n(ASW-PopMenu-Insert)") 
        (if (not (ASW-PopMenu-MenuBar-p name)) 
          (if (setq pmnu (ASW-PopupMenu mgroup name)) 
                        (progn 
                                (vla-insertinmenubar pmnu loc) 
                                (vlax-release-object pmnu) 
                                T 
                        ) 
                        (princ (strcat "\nMenugroup or popmenu not loaded or defined: " name)) 
                ) 
                (princ (strcat "\nPopmenu already loaded: " name)) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: PopMenu-Remove 
;;; DESCRIPTION: Removes specified popmenu from menubar, returns nil 
;;; ARGS: menugroup-name, pop-menu-name 
;;; EXAMPLE: (ASW-PopMenu-Remove "ASW2K" "&ShipWorks") 
;;;************************************************************************* 
 
(defun PopMenu-Remove (mgname name / pmnu) 
        (ASW-PRINC "\n(ASW-PopMenu-Remove)") 
        (if (menugroup mgname) 
                (if (ASW-PopMenu-MenuBar-p name) 
                        (if (setq pmnu (vla-item (vla-get-menubar (ASW-AcadObject)) name)) 
                                (progn 
                                        (vla-removefrommenubar pmnu) 
                                        (vlax-release-object pmnu) 
                                        (princ (strcat "\nPopmenu successfully removed: " name)) 
                                ) 
                                (princ (strcat "\nPopmenu not found/Unable to remove: " name)) 
                        ) 
                        (princ (strcat "\nPopmenu not loaded/Unable to remove: " name)) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: PopMenu-MenuBar-p 
;;; DESCRIPTION: Returns T if menubar contains specified pop-menu item 
;;; ARGS: pop-menu-name (string, case sensitive, includes mnemonics if used) 
;;; EXAMPLE: (ASW-PopMenu-MenuBar-p "&ShipWorks") returns T or nil 
;;;************************************************************************* 
 
(defun PopMenu-MenuBar-p (name / mbar i found) 
        (ASW-PRINC "\n(ASW-PopMenuLoaded)") 
        (setq mbar (vla-get-menubar (asw-acadobject)) i 0) 
        (while (and (not found) (
                (if (= (strcase name) (strcase (vla-get-name (vla-item mbar i)))) 
                        (setq found T) 
                ) 
                (setq i (1+ i)) 
        ) 
        (vlax-release-object mbar) 
        found 
) 
 
;;;************************************************************************* 
;;;************************************************************************* 
 
(defun Toolbars-Backup (mgroup / tbars name show pair out $regpath) 
        (ASW-PRINC "\n(ASW-Toolbars-Backup)") 
        (setq $regpath (strcat "Menus\\Toolbars\" mgroup)) 
        (cond 
                ( (setq tbars (ASW-Toolbars mgroup)) 
                  (vlax-for each tbars 
                                (setq name (vla-get-name each) 
                                                        show (vla-get-visible each) 
                                                        pair (list name (if (= show :vlax-true) "1" "0")) 
                                                        out  (cons pair out) 
                                ) 
                        ) 
                  (vlax-release-object tbars) 
                  (if out 
                                (progn 
                                        (foreach tb out 
                                                (ASW-RegSet (strcat $regpath "\" (car tb)) (cadr tb)) 
                                        ) 
                                ) 
                        ) 
                ) 
                ( T (princ (strcat "\nMenugroup (" mgroup ") has no toolbars.")) ) 
        ) 
        out 
) 
 
;;;************************************************************************* 
;;;************************************************************************* 
 
(defun Toolbars-Restore (mgroup / keys $regpath dat out) 
        (ASW-PRINC "\n(ASW-Toolbars-Restore)") 
        (setq $regpath (strcat G$REGROOT "\\Menus\\Toolbars\" mgroup)) 
        (cond 
                ( (menugroup mgroup) 
                  (cond 
                                ( (setq keys (vl-registry-descendents $regpath)) 
                                  (foreach key keys 
                                                (setq dat (vl-registry-read (strcat $regpath "\" key) nil) 
                                                                        out (cons (list key dat) out) 
                                                ) 
                                        ) 
                                ) 
                                ( T (princ (strcat "\nNo saved toolbar info to retrieve: " mgroup)) ) 
                        ) 
                ) 
        ) 
        out 
) 
 
;;;************************************************************************* 
;;; MODULE: Menu-Load 
;;; DESCRIPTION: Loads menugroup from specified MNU, MNS or MNC file 
;;; ARGS: menugroup-name, menufile 
;;; EXAMPLE: 
;;;************************************************************************* 
 
(defun Menu-Load (mgroup mfile / mgroups omg) 
        (ASW-PRINC "\n(ASW-Menu-Load)") 
        (cond 
                ( (not (menugroup mgroup)) 
                  (setq mgroups (Get-MenuGroups)) 
                  (if (findfile mfile) 
                          (setq omg (vla-load mgroups (findfile mfile))) 
                                (princ (strcat "\nUnable to load menu file: " mfile)) 
                        ) 
                ) 
                ( T (princ (strcat "\nMenugroup (" mgroup ") is alread loaded.")) ) 
        ) 
        omg 
) 
 
(princ)

sqmjk01 · 发表于 2003-7-26 21:25:27

难题终于解决了，谢谢斑竹了！

秋枫 · 发表于 2007-11-28 19:55:08

如何给指定的MenuItem加加速键？比如：
Shift+Ctrl+P

cadmap · 发表于 2007-11-30 16:47:49

经典啊，顶楼主

账号		自动登录	找回密码
密码			立即注册

[求助] [求助]：如何用Vlisp添加自定义局部菜单

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

Re: [求助]：[求助]：如何用Vlisp添加自定义局部菜单