Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Menu Bar Moving On It's Own!

Status
Not open for further replies.

snikde

Programmer
Mar 13, 2002
35
US
Here is an interesting one. I create a menu bar with the code below. It works fine. When I run one of the menu selections that opens a modeless dialog from this menu bar after the box is dismissed the menu bar resets its position up at the top vs. where I last left it. Any thoughts?


Sub CreateCustomCommandBar()
' creates a new custom commandbar
Dim cb As CommandBar, cbMenu As CommandBarPopup, cbButton As CommandBarButton
DeleteCustomCommandBar ' delete the commandbar if it already exists
' create the new commandbar
Set cb = Application.CommandBars.Add(ThisCommandBarName, msoBarTop, False, True)
' add a menu to the new commandbar
Set cbMenu = cb.Controls.Add(msoControlPopup, , , , True)
With cbMenu
.Caption = "&BOM Query Tools"
'.Tag = "MyTag"
End With
' add a menu item to the menu
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "&Get 4D Pricing"
.OnAction = ThisWorkbook.Name & "!GetCosts"
shtCustomIcons.Shapes("4D").Copy ' copy the custom icon
.PasteFace ' paste the custom icon
End With
' add a menu item to the menu
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "Override Item Master Pricing"
.OnAction = ThisWorkbook.Name & "!OverRide"
.FaceId = 319
.BeginGroup = True
End With
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "Reset to Item Master Pricing"
.FaceId = 320
.OnAction = ThisWorkbook.Name & "!Reset"
End With
' add a menu item to the menu
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "Price Differences - 2 BOM's"
.OnAction = ThisWorkbook.Name & "!PrepForList"
.FaceId = 531
.BeginGroup = True
End With
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "Find Parts With No Price"
shtCustomIcons.Shapes("parts").Copy ' copy the custom icon
.PasteFace ' paste the custom icon
.OnAction = ThisWorkbook.Name & "!ListOfNonPricedParts"
.BeginGroup = True
End With
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
.Caption = "Find Assemblies With No Price"
shtCustomIcons.Shapes("assys").Copy ' copy the custom icon
.PasteFace ' paste the custom icon
.OnAction = ThisWorkbook.Name & "!ListOfNonPricedAssys"
End With

'---------------------------------------------------------------------------------
' add a button to the commandbar, use a built-in FaceId
Set cbButton = cb.Controls.Add(msoControlButton, , , , True)
With cbButton
.Caption = "&Display Color Legend"
shtCustomIcons.Shapes("colorlegend").Copy ' copy the custom icon
.PasteFace ' paste the custom icon
.Style = msoButtonIconAndCaption
.OnAction = ThisWorkbook.Name & "!ShowLegend"
.TooltipText = "Display Color Legend for Cells"
End With

Set cbButton = cb.Controls.Add(msoControlButton, , , , True)
With cbButton
.Caption = "Display Hierarchial List"
.FaceId = 632 ' trash bin
'shtCustomIcons.Shapes("listview").Copy ' copy the custom icon
'.PasteFace ' paste the custom icon
.Style = msoButtonIconAndCaption
.OnAction = ThisWorkbook.Name & "!ViewTree"
.TooltipText = "View A Hierarchial List"
End With


cb.Visible = True ' display the custom commandbar
Set cbButton = Nothing
Set cbMenu = Nothing
Set cb = Nothing
End Sub

Sub DeleteCustomCommandBar()
' delete the commandbar if it already exists
On Error Resume Next
Application.CommandBars(ThisCommandBarName).Delete
On Error GoTo 0
End Sub

Function CopyPictureFromFile(TargetWS As Worksheet, SourceFile As String) As Boolean
' inserts a picture from SourceFile into TargetWS
' copies the picture to the clipboard
' deletes the inserted picture
' returns TRUE if a picture is copied to the clipboard
' the picture can be pasted from the clipboard e.g. to a custom commbarbutton
Dim p As Object
CopyPictureFromFile = False
If TargetWS Is Nothing Then Exit Function
If Len(Dir(SourceFile)) = 0 Then Exit Function
On Error GoTo NoPicture
Set p = TargetWS.Pictures.Insert(SourceFile)
p.CopyPicture xlScreen, xlPicture
p.Delete
Set p = Nothing
On Error GoTo 0
CopyPictureFromFile = True
Exit Function
NoPicture:
End Function
 
Sorry Figured it out , was recreating the menu by accident on window activate!!
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top