PDA

View Full Version : [SOLVED] Can I shorten This



Erays
04-13-2005, 12:46 PM
Sub BuildEdsMenuItem()
Dim newCtrl As CommandBarControl
Set newCtrl = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls.Add
newCtrl.Caption = "Create Rei Folders"
newCtrl.OnAction = "MakeEdsFolder"
BuildEdsMenuItem1
End Sub

Sub BuildEdsMenuItem1()
Dim newCtrl As CommandBarControl
Set newCtrl = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls.Add
newCtrl.Caption = "Initial Email and Save"
newCtrl.OnAction = "EmailRei"
BuildEdsMenuItem2
End Sub

Sub BuildEdsMenuItem2()
Dim newCtrl As CommandBarControl
Set newCtrl = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls.Add
newCtrl.Caption = "Supplement Email and Save"
newCtrl.OnAction = "EmailSupp"
BuildEdsMenuItem3
End Sub

Sub BuildEdsMenuItem3()
Dim newCtrl As CommandBarControl
Set newCtrl = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls.Add
newCtrl.Caption = "TotalLoss Email and Save"
newCtrl.OnAction = "EmailTLA"
BuildEdsMenuItem4
End Sub

Sub BuildEdsMenuItem4()
Dim newCtrl As CommandBarControl
Set newCtrl = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls.Add
newCtrl.Caption = "Save Initial Rei"
newCtrl.OnAction = "SaveRei"
BuildEdsMenuItem5
End Sub

Sub BuildEdsMenuItem5()
Dim newCtrl As CommandBarControl
Set newCtrl = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls.Add
newCtrl.Caption = "Save Supplement Rei"
newCtrl.OnAction = "SaveSupp"
BuildEdsMenuItem6
End Sub

Sub BuildEdsMenuItem6()
Dim newCtrl As CommandBarControl
Set newCtrl = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls.Add
newCtrl.Caption = "Save Total Loss Rei"
newCtrl.OnAction = "SaveTotal"
End Sub

Sub DeleteEdsMenuItem()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls
If ctrl.Caption = "Create Rei Folders" Then ctrl.Delete
Next
DeleteEdsMenuItem1
End Sub

Sub DeleteEdsMenuItem1()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls
If ctrl.Caption = "Initial Email and Save" Then ctrl.Delete
Next
DeleteEdsMenuItem2
End Sub

Sub DeleteEdsMenuItem2()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls
If ctrl.Caption = "Supplement Email and Save" Then ctrl.Delete
Next
DeleteEdsMenuItem3
End Sub

Sub DeleteEdsMenuItem3()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls
If ctrl.Caption = "TotalLoss Email and Save" Then ctrl.Delete
Next
DeleteEdsMenuItem4
End Sub

Sub DeleteEdsMenuItem4()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls
If ctrl.Caption = "Save Initial Rei" Then ctrl.Delete
Next
DeleteEdsMenuItem5
End Sub

Sub DeleteEdsMenuItem5()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls
If ctrl.Caption = "Save Supplement Rei" Then ctrl.Delete
Next
DeleteEdsMenuItem6
End Sub

Sub DeleteEdsMenuItem6()
Dim ctrl As CommandBarControl
For Each ctrl In Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls
If ctrl.Caption = "Save Total Loss Rei" Then ctrl.Delete
Next
End Sub

Jacob Hilderbrand
04-13-2005, 12:54 PM
You can reduce the number of Subs and just call the same Sub with different Arguments.



Option Explicit

Sub BuildMenuItems()
Call BuildEdsMenuItem("Create Rei Folders", "MakeEdsFolder")
Call BuildEdsMenuItem("Initial Email and Save", "EmailRei")
Call BuildEdsMenuItem("Supplement Email and Save", "EmailSupp")
Call BuildEdsMenuItem("TotalLoss Email and Save", "EmailTLA")
...
...
...
End Sub

Sub BuildEdsMenuItem(Cap As String, OnAct As String)
Dim newCtrl As CommandBarControl
Set newCtrl = Application.CommandBars("Worksheet Menu Bar") _
.Controls("Tools").Controls.Add
newCtrl.Caption = "Create Rei Folders"
newCtrl.OnAction = "MakeEdsFolder"
End Sub

MOS MASTER
04-13-2005, 01:21 PM
Hi, :D

I was already working on this but DRJ beat me to it! :rofl: this is about the same as he suggested.

I have choosen to build a complete new menu instead off altering the Tools button...

the code


Sub MakeMenu()
Dim newMenu As CommandBarPopup
On Error Resume Next
DeleteMyButton
Set newMenu = Application.CommandBars("Worksheet Menu Bar") _
.Controls.Add(Type:=msoControlPopup, Before:=7)
With newMenu
.Caption = "My Tools"
.Visible = True
End With
AddMyButton newMenu, "Create Rei Folders", "MakeEdsFolder"
AddMyButton newMenu, "Initial Email and Save", "EmailRei"
AddMyButton newMenu, "Supplement Email and Save", "EmailSupp"
AddMyButton newMenu, "TotalLoss Email and Save", "EmailTLA"
AddMyButton newMenu, "Save Initial Rei", "SaveRei"
AddMyButton newMenu, "Save Supplement Rei", "SaveSupp"
AddMyButton newMenu, "Save Total Loss Rei", "SaveTotal"
Set newMenu = Nothing
End Sub

Sub AddMyButton(myMenu As CommandBarPopup, sCaption As String, sAction As String)
With myMenu.Controls.Add(Type:=msoControlButton)
.Caption = sCaption
.OnAction = sAction
End With
End Sub

Sub DeleteMyButton()
Dim ctrl As CommandBarPopup
For Each ctrl In Application.CommandBars("Worksheet Menu Bar").Controls
If ctrl.Caption = "My Tools" Then ctrl.Delete
Next
End Sub

Enjoy! :thumb

mvidas
04-13-2005, 01:28 PM
Well, I also made one, little bit different. I assumed you ran your Delete subs first, then the add subs, I just combined it so it deletes it before it adds it:


Sub BuildEdsMenuItem()
EdsMenu "Create Rei Folders", "MakeEdsFolder"
EdsMenu "Initial Email and Save", "EmailRei"
EdsMenu "Supplement Email and Save", "EmailSupp"
EdsMenu "TotalLoss Email and Save", "EmailTLA"
EdsMenu "Save Initial Rei", "SaveRei"
EdsMenu "Save Supplement Rei", "SaveSupp"
EdsMenu "Save Total Loss Rei", "SaveTotal"
End Sub

Public Function EdsMenu(vCaption As String, vOnAction As String)
Dim ctrl As CommandBarControl
On Error Resume Next
Application.CommandBars("Tools").Controls(vCaption).Delete
On Error GoTo 0
With Application.CommandBars("Worksheet Menu Bar").Controls("Tools").Controls.Add
.Caption = vCaption
.OnAction = vOnAction
End With
End Function

Matt

MOS MASTER
04-13-2005, 01:34 PM
Hi Matt, :D

Seams like always in VBA there are many ways to reach Rome! :rofl:

Erays
04-13-2005, 01:42 PM
M.O.S. Master
has done it this is a great way to create a new menu in excel works really great

Thanks to M.O.S. Master


:beerchug:

MOS MASTER
04-13-2005, 01:51 PM
You're Welcome Erays...:beerchug:

Have fun creating you're Menu's and amaze you're collegue's with you're work!

To make you're buttons look nicer add pictures to them with the:

.FaceId = 100
.Style = msoButtonIconAndCaption
properties..

Then you're function would look like:



Sub AddMyButton(myMenu As CommandBarPopup, _
sCaption As String, sAction As String, iID As Integer)
With myMenu.Controls.Add(Type:=msoControlButton)
.Caption = sCaption
.OnAction = sAction
.FaceId = iID
.Style = msoButtonIconAndCaption
End With
End Sub

'To call change to:

AddMyButton newMenu, "Save Total Loss Rei", "SaveTotal", 107

Just play with it! :whistle:

Zack Barresse
04-13-2005, 01:52 PM
.. Thanks to M.O.S. Master ..

Ahem, and to mvidas and DRJ as well - they helped just as much as MOS Master has. And it's great to be appreciated, but even worse to not be appreciated at all! :thumb

MOS MASTER
04-13-2005, 01:56 PM
And it's great to be appreciated, but even worse to not be appreciated at all! :thumbTrue...no appreciation what so ever can get a brother down...:think:

Erays
04-13-2005, 02:15 PM
Thanks to all who have helped me (DRJ, mvidas, MOS Master, Firefytr) I look forward to the day that I myself can help someone with this.

I say to others I dont have my foot in the door But I do have my little toenail there!