How to keep custom menu from being killed until all wkbk copys clo

[Hapless]

We use an overly complicated workbook for creating production schedules. A
user grabs a blank version from our network and then uses it to build
whatever schedule he or she needs. They might do this dozens of times to
build schedules for different projects. Furthermore, users might have
multiple schedule workbooks open at the same time, all of them identical
except for the data they contain.

The workbook uses a Workbook_Open event to create some custom menus and a
BeforeClose event to kill the menu. Unfortunately, it seems somewhat volatile
if you have more than one of the workbooks open at the same time, causing
random crashes. Further, since the BeforeClose event kills the custom menu,
you lose it even if you still have other copies of the workbook open, forcing
a user to close and reopen a workbook to get it back.

I guess my question is this: How can I keep the custom menu available until
the last open copy of the workbook is closed? And since the workbooks are all
identical (identical named ranges, code, etc.), is there a way to minimize
the volaltility I've described? I kind of wonder if, when a user clicks from
one workbook window to another, that somehow the identical code, named
ranges, etc. are getting tangled up somehow. Frankly, much of this code has
been cobbled together from different sources over a long period of
time--which is kind of different from actually knowing what I'm doing. Any
help would be much appreciated!

Here's the event code in This Workbook:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
If Not Me.Saved Then
Msg = "Do you want to save the changes you made to "
Msg = Msg & Me.Name & "?"
Ans = MsgBox(Msg, vbQuestion + vbYesNoCancel)
Select Case Ans
Case vbYes
Me.Save
Case vbNo
Me.Saved = True
Case vbCancel
Cancel = True
Exit Sub
End Select
End If
Call DeleteMenu
Call Delete_Controls
End Sub

Private Sub Workbook_Open()
On Error Resume Next
Call CreateMenus
Call Add_Controls
End Sub

And if it's useful, here are the procedures the events are calling:

Sub CreateMenus()
On Error Resume Next
Dim HelpMenu As CommandBarControl
Dim NewMenu As CommandBarPopup
Dim MenuItem As CommandBarControl
Dim Submenuitem As CommandBarButton

Call DeleteMenu

Set HelpMenu = CommandBars(1).FindControl(Id:=30010)

If HelpMenu Is Nothing Then
Set NewMenu = CommandBars(1).Controls _
..Add(Type:=msoControlPopup, temporary:=True)
Else
Set NewMenu = CommandBars(1).Controls _
..Add(Type:=msoControlPopup, Before:=HelpMenu.Index, _
temporary:=True)
End If

NewMenu.Caption = "Schedule Options"

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
..Caption = "WORKDAY Edit"
..OnAction = "InputMacro"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlButton)
With MenuItem
..Caption = "Place Screen Over Selected Area"
..OnAction = "SetRectangle"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..BeginGroup = True
..Caption = "Priority for Goal and Actual Dates"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Use Actuals Only If Later Than Goals (ADP Standard)"
..OnAction = "ActDatePriorityGoal"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Always Use Actuals If Available"
..OnAction = "ActDatePriorityAct"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "Number of Proofs"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "1 Proof + 2 PDFs"
..OnAction = "One_Proof"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "2 Proofs + 2 PDFs"
..OnAction = "Two_Proofs"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "3 Proofs + 2 PDFs"
..OnAction = "Three_Proofs"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "4 Proofs + 2 PDFs"
..OnAction = "Four_Proofs"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "5 Proofs + 2 PDFs"
..OnAction = "Five_Proofs"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "More Than One ISBN?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "MultiISBNYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "MultiISBNNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "More Than One Vendor?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "MultiVendorYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "MultiVendorNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "Need Legacy Files?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "LegacyYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "LegacyNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "Ordering Go-Bys/Templates?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "GoByYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "GoByNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..Caption = "Require Specs for AP?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "AP_SpecsYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "AP_SpecsNo"
End With

Set MenuItem = NewMenu.Controls.Add _
(Type:=msoControlPopup)
With MenuItem
..BeginGroup = True
..Caption = "See Editorial View?"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "Yes"
..OnAction = "Editorial_ViewYes"
End With

Set Submenuitem = MenuItem.Controls.Add _
(Type:=msoControlButton)
With Submenuitem
..Caption = "No"
..OnAction = "Editorial_ViewNo"
End With

End Sub

Sub DeleteMenu()

On Error Resume Next
Application.CommandBars(1).Controls("Schedule Options").Delete

End Sub

Sub Add_Controls()
On Error Resume Next
Dim i As Long
Dim onaction_names As Variant
Dim caption_names As Variant
onaction_names = Array("InputMacro", "SetRectangle")
caption_names = Array("WORKDAY Edit", "Place Screen Over Selected Area")
With Application.CommandBars("Cell")
For i = LBound(onaction_names) To UBound(onaction_names)
With .Controls.Add(Type:=msoControlButton)
.OnAction = ThisWorkbook.Name & "!" & onaction_names(i)
.Caption = caption_names(i)
End With
Next i
End With
End Sub
Sub Delete_Controls()
On Error Resume Next
Dim i As Long
Dim caption_names As Variant
caption_names = Array("WORKDAY Edit", "Place Screen Over Selected Area")
With Application.CommandBars("Cell")
For i = LBound(caption_names) To UBound(caption_names)
On Error Resume Next
.Controls(caption_names(i)).Delete
On Error GoTo 0
Next i
End With
End Sub

Sub SetRectangle()
On Error Resume Next
Set r = Selection
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 46.5, 12#, 193.5, 53.25).Select
Selection.Top = r.Top
Selection.Left = r.Left
Selection.Height = r.Height
Selection.Width = r.Width
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 8
Selection.ShapeRange.Fill.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Fill.Patterned msoPattern25Percent
End Sub
Sub Deleteme()
ActiveSheet.Rectangles(Application.Caller).Delete
End Sub

 

[Bernie Deitrick]

Hapless,

Put the code into an add-in and install the add-in using Tools / Add
Ins..... Then use code to set the commandbar to be visible in the
workbook's activate event, and set visible to false in the de-activate
event.

HTH,
Bernie
MS Excel MVP

 

[Hapless]

I never would have thought of that at all! I think, though, that I'd have to
send the add-in to all of the users (there are a lot, some of them outside
the company), along with directions on how to install it and what it does.
Given some of the departments and users involved, I'm pretty sure there would
be a lot of handwringing and panic (and one of our departments runs on Macs,
which always screws things up).

Thanks so much for the idea, but I really think that whatever "fix" I can do
has to be self-contained within the workbook. Probably I'm screwed.

 

[Bernie Deitrick]

You could have each workbook create its own commandbar - your code just need to be a bit more
flexible. For example, see below.

HTH,
Bernie
MS Excel MVP


'Put this in a regular codemodule

Option Explicit

Dim myBar As CommandBar
Dim myButton As CommandBarButton

Sub CreateCommandbar()
On Error Resume Next
DeleteCommandBar

Set myBar = Application.CommandBars.Add("My Bar" & Replace(ThisWorkbook.Name, ".xls", ""))
With myBar
.Position = msoBarTop
.Visible = True
.Enabled = True
Set myButton = .Controls.Add(Type:=msoControlButton, ID:=23)
With myButton
.Caption = "Hello"
.Style = msoButtonIcon
.FaceId = 137
.Enabled = True
.OnAction = "SayHello"
End With
End With

End Sub

Sub DeleteCommandBar()
'Delete the commandbar if it already exists
On Error Resume Next
Application.CommandBars("My Bar" & Replace(ThisWorkbook.Name, ".xls", "")).Delete
End Sub

Sub SayHello()
MsgBox "Hello there from " & "My Bar" & Replace(ThisWorkbook.Name, ".xls", "")
End Sub


And put this in the codemodule of the Thisworkbook object

Private Sub Workbook_BeforeClose(Cancel As Boolean)
DeleteCommandBar
End Sub

Private Sub Workbook_Open()
CreateCommandbar
End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
On Error GoTo NotThere
Application.CommandBars("My Bar" & Replace(ThisWorkbook.Name, ".xls", "")).Visible = True
Exit Sub
NotThere:
CreateCommandbar
End Sub

Private Sub Workbook_WindowDeactivate(ByVal Wn As Window)
On Error Resume Next
Application.CommandBars("My Bar" & Replace(ThisWorkbook.Name, ".xls", "")).Visible = False
End Sub

 

[Hapless]

Thanks again, Bernie! The toolbar approach works well on the PCs at work--but
unfortunately, not on the Macs. The Replace method seems to work differently
on the two platforms, and it gets hung up on the Macs, which is a dealkiller
for that whole department.

Sigh. You really have been helpful, and I appreciate it so much. If you have
any more suggestions, that would be great. I'll keep futzing around with the
toolbar. I long since passed the limits of what I know how to do, but maybe I
can set the toolbar-build routine to identify the OS first and then rewrite
the REPLACE action in a syntax that OSX understands.

 

[Bernie Deitrick]

Try using

Application.Substitute

in place of Replace:

Set myBar = Application.CommandBars.Add("My Bar" & Replace(ThisWorkbook.Name, ".xls", ""))

becomes

Set myBar = Application.CommandBars.Add("My Bar" & Application.Substitute(ThisWorkbook.Name, ".xls",
""))

That will definitely work on all Windows machines, and should work on Macs as well. I think the
problem is different version of VBA.

HTH,
Bernie
MS Excel MVP