View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
GB GB is offline
external usenet poster
 
Posts: 230
Default custom toolbar for each sheet in workbook?

Yes it is. I have implemented something similar. I will go ahead and
include my full Toolbar code, but I must preface it by saying that it is not
REALLY clean. I have to handle errors, because I never figured out how to
prevent them, or predetermine that they would exist to prevent them.
Basically to implement my version, when leaving the current sheet, you need
to hide the associated toolbar. When entering the new sheet, you need to
show the associated toolbar. My version will cause the toolbar to move down
and to the right until it hits a lower/right limit then begin showing it up
towards the left, although I have made my version dockable/removable. You
sound like you would want to place the toolbar at the top of the screen and
prevent a user from separating the toolbar from the menu area.

That would "fix" my problem.

Here goes and this is the entire module, so you could insert a new module,
then copy and paste the following into it. I have reused this code for
various applications, so there are several lines commented out. I also have
left some commented lessons learned in here, so that I do not duplicate the
mistake. The end of the module is designated with a very long series of -'s:

Option Explicit

' Written at Norfolk Naval Shipyard (NNSY)
' Code Written by GB
' E-mail:
' Phone #:
' Fax #:
'Version 2.1

Private Const MAX_BARS As Integer = 10

Public Sub All_Bars()
Tool_Bar1_Create
'Dim sheetActivated As Worksheet
'Set sheetActivated = ActiveSheet
Sheet1.Activate
'sheetActivated.Activate
End Sub

Public Sub All_Bars_Delete()
Dim I As Integer

I = 0

On Error GoTo Out
Err.Clear

While (Name(I) < "" And I < Max_Tool_Bars)

Application.CommandBars(Name(I)).Delete

Out:
I = I + 1
Wend

Err.Clear
On Error GoTo 0
End Sub

Public Sub All_Bars_Hide()
Dim I As Integer
I = 0
While (Name(I) < "" And I < Max_Tool_Bars)
On Error GoTo Hide
Err.Clear
If Application.CommandBars(Name(I)).Visible = True Then
CommandBars(Name(I)).Visible = False
End If
Hide:
I = I + 1
Wend

Err.Clear
On Error GoTo 0

End Sub

Public Function Exist(ToolName As String)
Dim FoundMenu As Variant
Dim FoundItem As Variant
Dim I As Integer

Set FoundMenu = CommandBars.ActiveMenuBar.Controls(3)
Set FoundItem = FoundMenu.Controls(3)

For I = 1 To FoundItem.Controls.Count
If (FoundItem.Controls(I).Caption = ToolName) Then
Exist = True
Exit For
'delete the name
End If
Exist = False
Next I

End Function

Public Function Max_Tool_Bars()
Max_Tool_Bars = MAX_BARS
End Function

Public Function Name(Value As Integer)
Select Case Value
Case 0
Name = "First Tool Bar"
Case 1
Name = ""
Case Else
MsgBox "That Value is not yet supported"
End Select
End Function

Public Sub Tool_Bar1_Create()
Tool_Bar1_Props
End Sub

Public Sub Tool_Bar1_Hide()
On Error GoTo HideErr
Err.Clear
Application.CommandBars(Name(0)).Visible = False
Exit Sub
HideErr:
All_Bars_Delete

Err.Clear
On Error GoTo 0
End Sub

Private Sub Tool_Bar1_Props()
Dim NameBar As String
Dim MenuBar As CommandBar
Dim NewItem As Variant
Dim ctrl1 As Variant
Dim Found As Variant
Dim RowNum As Integer

NameBar = ToolBars.Name(0)
On Error GoTo AddErr
Err.Clear

Application.ShowToolTips = True

Set MenuBar = Application.CommandBars.Add(Name:=Name(0),
Position:=msoBarFloating, MenuBar:=False)

With MenuBar
.Protection = msoBarNoCustomize
.Visible = True
End With

' -----------Update Database Code Button
'Call Sheet1Code.FindNextAddRow(Sheet1)
'RowNum = Sheet1Code.GetLastAddRow

' Set Found = Sheet1.Range(Sheet1.Cells(Variables.GetSheet1RowSt art, _
' Variables.GetSheet1_Name_Col), Sheet1.Cells(RowNum, _
' Variables.GetSheet1_Name_Col)).Find("Freelance", LookIn:=xlValues,
LookAt:=xlWhole)

' Stop Below text DOES NOT WORK, do not try to use it again.
' Set Found = Sheet1.Cells(Variables.GetSheet1RowStart, _
' Variables.GetSheet1_Name_Col).Find("Freelance", LookIn:=xlValues,
Lookat:=xlWhole)

' If Not Found Is Nothing Then
' Set NewItem =
Application.CommandBars(Name(0)).Controls.Add(Type :=msoControlButton)
' With NewItem
' .BeginGroup = True
' .Caption = "Update Code"
' .FaceId = 454
' .OnAction = "CodeUpdate.CopyNewCode" '""
' .Style = msoButtonIconAndCaption
' End With
'End If
' -----------End Update Database Code Button

' -----------Move Selected Row(s) to Delete
' Set NewItem =
Application.CommandBars(Name(0)).Controls.Add(Type :=msoControlButton)
' With NewItem
' .BeginGroup = True
' .Caption = "Move Selected Row(s) to Delete"
' .FaceId = 67
' .OnAction = "ModuleName.Move2Del" '""
' .Style = msoButtonIconAndCaption
' End With
' -----------End Move Selected Row(s) to Delete

' -----------Move Selected Row(s) to Keep
' Set NewItem =
Application.CommandBars(Name(0)).Controls.Add(Type :=msoControlButton)
' With NewItem
' .BeginGroup = True
' .Caption = "Move Selected Row(s) to Keep"
' .FaceId = 270
' .OnAction = "ModuleName.Move2Keep" '""
' .Style = msoButtonIconAndCaption
' End With
' -----------End Move Selected Row(s) to Keep

' -----------Mark Selected Row(s) for Deletion
Set NewItem =
Application.CommandBars(Name(0)).Controls.Add(Type :=msoControlButton)
With NewItem
.BeginGroup = True
.Caption = "Mark the Selected Row(s) for Deletion"
.FaceId = 31
.OnAction = "DeleteMarker.MarkData" '""
.Style = msoButtonIconAndCaption
End With
' -----------End Mark Selected Row(s) for Deletion

' -----------Move Button
Set NewItem =
Application.CommandBars(Name(0)).Controls.Add(Type :=msoControlPopup,
Temporary:=True)
With NewItem
.Caption = "&Move"
.BeginGroup = True
.TooltipText = "Move: Move the Selected Row(s) to the Delete Sheet,"
+ _
Chr(13) + Chr(10) + _
"Move the Selected Row(s) to the Keep Sheet."
End With

Set ctrl1 = NewItem.Controls.Add(Type:=msoControlButton, Id:=1)
With ctrl1
.DescriptionText = "Move the Selected Row(s) to the Delete Worksheet."
.Caption = "To Delete Sheet"
.FaceId = 67
.OnAction = "ModuleName.Move2Del" '""
.TooltipText = "Move the Selected Row(s) to the Delete Worksheet."
End With

Set ctrl1 = NewItem.Controls.Add(Type:=msoControlButton, Id:=1)
With ctrl1
.DescriptionText = "Move the Selected Row(s) to the Keep Worksheet."
.Caption = "To Keep Sheet"
.FaceId = 270
.OnAction = "ModuleName.Move2Keep" '""
.TooltipText = "Move the Selected Row(s) to the Keep Worksheet."
End With

Set NewItem =
Application.CommandBars(Name(0)).Controls.Add(Type :=msoControlButton)
With NewItem
.BeginGroup = True
.Caption = "Setup the Worksheet Data"
.FaceId = 2151
.OnAction = "ModuleName.A_SetupDatabase" '""
.Style = msoButtonIconAndCaption
End With

' Set ctrl1 = NewItem.Controls.Add(Type:=msoControlButton, Id:=1)
' With ctrl1
' .FaceId = 2174
' .Caption = "&Any Single Selected FY"
' .OnAction = "Fiscal.FiscalSortEnter"
' .TooltipText = "Create or modify a FY Spreadsheet."
' End With

' Set ctrl1 = NewItem.Controls.Add(Type:=msoControlButton, Id:=1)
' With ctrl1
' .FaceId = 480
' .Caption = "&Year from Today"
' .OnAction = "Fiscal.CalculateYearSort"
' .TooltipText = "Update the Spreadsheet representing a year from
today."
' End With

' Set ctrl1 = NewItem.Controls.Add(Type:=msoControlButton, Id:=1)
' With ctrl1
' .FaceId = 480
' .Caption = "&Upcoming Payments by Selected Month"
' .OnAction = "MonthReport.Start"
' .TooltipText = "Update the Spreadsheet representing a year from
today."
' End With

' -----------End Calculate Button

' -----------Print Button
' Set newItem =
Application.CommandBars(Name(0)).Controls.Add(Type :=msoControlPopup,
Temporary:=True)
' With newItem
' .Caption = "&Print"
' .BeginGroup = True
' End With

' Set ctrl1 = newItem.Controls.Add(Type:=msoControlButton, Id:=1)
' With ctrl1
' .FaceId = 2174
' .Caption = "&Main Print"
' .OnAction = ""
' End With

' Set ctrl1 = newItem.Controls.Add(Type:=msoControlButton, Id:=1)
' With ctrl1
' .FaceId = 480
' .Caption = "P&rint All"
' .OnAction = ""
' End With

' Set ctrl1 = newItem.Controls.Add(Type:=msoControlButton, Id:=1)
' With ctrl1
' .FaceId = 2144
' .Caption = "Print &This Sheet"
' .OnAction = ""
' End With

' Set NewItem =
Application.CommandBars(Name(0)).Controls.Add(Type :=msoControlButton, Id:=4)
' With NewItem
' .BeginGroup = True
'.Caption = "Enter Data"
'.FaceId = 479
'.OnAction = "ThisWorkbook.ShowNameForm" '""
' .Style = msoButtonIconAndCaption
' End With
'Set ctrl1 = newItem.Controls.Add(Type:=msoControlButton, Id:=4)
' -----------End Print Button

Err.Clear
On Error GoTo 0

Exit Sub

AddErr:
All_Bars_Delete
Resume
'All_Bars
End Sub

Public Sub Tool_Bar1_Show()
On Error GoTo ShowErr
Err.Clear
Application.CommandBars(Name(0)).Visible = True

Err.Clear
On Error GoTo 0
Exit Sub
ShowErr:
All_Bars

Err.Clear
On Error GoTo 0
End Sub

-------------------------------------------------------------------------------------------------------------------------------------



"davegb" wrote:

Before I invest a lot of time, I just want to verify that what I want
to do is possible. I have a series of sheets in a workbook. I want to
have some of the tools to be the same with every sheet. But I want
certain tools to appear on the toolbar only when a specific sheet is
selected. Is this doable? I haven't done anything with VBA and toolbars
yet, but have done macros that run when a specific sheet is selected.