10. marts 2007 - 20:03
Der er
2 kommentarer og
1 løsning
Makro til menubar
Hejsa
Hvorfor kan jeg ikke kalde min makro i nedenstående eksempel.
Jeg har placeret koden i en xla-fil og placeret den i xlstart biblioteket.
Jeg får bare en fejl der refererer til at "menu.xla!MyMacroName1 blev ikke fundet"
Her er koden:
Option Explicit
Dim NewMenuItem As CommandBarControl
Const MenuCaption = "NyMenu"
Const UnderMenuCaption = "NyUndermenu"
Public Sub NyMenu()
Dim bMenuExists As Boolean
Dim ctrl1 As CommandBarButton
Dim mnuNyUndermenuLocal As CommandBarButton
Dim MenuItem As CommandBarControl
Dim LocalMenuItem As CommandBarControl
Dim MenuBar As CommandBar
Dim strPreKode As String
Set MenuBar = Application.CommandBars.ActiveMenuBar
bMenuExists = False
MenuBar.Reset
For Each MenuItem In MenuBar.Controls
If MenuItem.Caption = MenuCaption Then
bMenuExists = True
Set LocalMenuItem = MenuItem
Set mnuNyUndermenuLocal = MenuItem.CommandBar.Controls(UnderMenuCaption)
End If
Next MenuItem
If Not bMenuExists Then
Set LocalMenuItem = MenuBar.Controls.Add(Type:=msoControlPopup, Temporary:=True)
LocalMenuItem.Move Before:=10
LocalMenuItem.Caption = MenuCaption
Set ctrl1 = LocalMenuItem.CommandBar.Controls.Add(Type:=msoControlButton, ID:=1, Temporary:=True)
With ctrl1
.Caption = UnderMenuCaption
.Style = msoButtonCaption
.OnAction = "MyMacroName1"
End With
Set NewMenuItem = LocalMenuItem
If CheckTemplate Then
NewMenuItem.Enabled = False
End If
End If
End Sub
Public Sub SletMenu()
If Not NewMenuItem Is Nothing Then
On Error Resume Next
NewMenuItem.Delete
On Error GoTo 0
Set NewMenuItem = Nothing
End If
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
SletMenu
End Sub
Private Sub Workbook_Activate()
NyMenu
End Sub
Private Sub Workbook_Deactivate()
SletMenu
End Sub
Private Sub Workbook_Open()
NyMenu
End Sub
Private Function CheckTemplate() As Boolean
Dim bResult As Boolean
bResult = False
If UCase(Application.ActiveWorkbook.Name) = "TEMPLATE.XLS" Then
bResult = True
End If
CheckTemplate = bResult
End Function
Public Sub TrigMenu(shtWorkSheet As Worksheet)
Workbook_SheetActivate shtWorkSheet
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
NyMenu
End Sub
Sub MyMacroName1()
Workbooks.Open Filename:="c:\mitark.xls"
End Sub
10. marts 2007 - 22:07
#1
Jeg fandt selv denne på eksperten.dk
Option Explicit
Public MenuObject As CommandBarPopup
Public SubMenu As CommandBarPopup
Public MenuItem As Object
Public SubMenuItem As CommandBarButton
Public Const strMenuName As String = "MyMenu"
Public Const strMenuNo As String = 11
Public Const intBarsNo As Integer = 1
Sub Auto_Open()
' Make sure the menus aren't duplicated
DeleteMenu strMenuName, intBarsNo
'Add MainMenu
CreateMainMenu strMenuName, strMenuNo, intBarsNo
'Add to MainMenu - ControlPopup and ControlButton
'MenuItem
CreateMenuItem "Item &1", "Menu01", "71", False
CreateMenuItem "Item &2", "Menu02", "72", False
'SubMenu
CreateSubMenu "&Group 1", True
'SubMenuItem
CreateSubMenuItem "GroupItem &1", "UMenu01", "71", False
End Sub
Sub DeleteMenu(strMenuName As String, intBarsNo As Integer)
' This sub should be executed when the workbook is closed
' Deletes the Menus
On Error Resume Next
Application.CommandBars(intBarsNo).Controls(strMenuName).Delete
On Error GoTo 0
End Sub
Private Sub CreateMainMenu(strMenuName, strMenuNo As String, intBarsNo As Integer)
'En ny hovedmenu
Set MenuObject = Application.CommandBars(intBarsNo).Controls.Add(Type:=msoControlPopup, _
Before:=strMenuNo, Temporary:=True)
MenuObject.Caption = strMenuName
End Sub
Private Sub CreateMenuItem(strCaption, strOnAction, strFaceId As String, bolBeginGroup As Boolean)
'Et menupunkt punkt direkte i hovedmenu'en
'MenuItem
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
With MenuItem
.Caption = strCaption
.OnAction = strOnAction
.FaceId = strFaceId
.BeginGroup = bolBeginGroup
End With
End Sub
Private Sub CreateSubMenu(strCaption As String, bolBeginGroup As Boolean)
'En menugruppe i hovedmenuen
'SubMenu
Set SubMenu = MenuObject.Controls.Add(Type:=msoControlPopup)
With SubMenu
.Caption = strCaption
.BeginGroup = bolBeginGroup
End With
End Sub
Private Sub CreateSubMenuItem(strCaption, strOnAction, strFaceId As String, bolBeginGroup As Boolean)
'Et menupunkt i en menugruppe
'SubMenu Item - UnderMenuPunkt
Set SubMenuItem = SubMenu.Controls.Add(Type:=msoControlButton)
With SubMenuItem
.Caption = strCaption
.OnAction = strOnAction
.FaceId = strFaceId
.BeginGroup = bolBeginGroup
End With
End Sub
Private Sub Menu01()
'Macro for menu testing
MsgBox "This is a do-nothing macro."
End Sub
Private Sub Menu02()
'Macro for menu testing
MsgBox "This is a do-nothing macro."
End Sub
Private Sub UMenu01()
'Macro for menu testing
MsgBox "This is a do-nothing macro."
End Sub
Her er den jeg bruger nu. Der er både undermenuer, subundermenuer og direkte links. Håber du kan bruge den.
Option Explicit
Public MenuObject As CommandBarPopup
Public SubMenu As CommandBarPopup
Public MenuItem As Object
Public SubMenuItem As CommandBarButton
Public SubMenuItem2 As CommandBarPopup
Public SubMenuItem3 As CommandBarButton
Public Const strMenuName As String = "&Min Menu"
Public Const strMenuNo As String = 11
Public Const intBarsNo As Integer = 1
Sub Auto_Open()
' Make sure the menus aren't duplicated
DeleteMenu strMenuName, intBarsNo
'Add MainMenu
CreateMainMenu strMenuName, strMenuNo, intBarsNo
'Add to MainMenu - ControlPopup and ControlButton
'MenuItem
'SubMenu
CreateSubMenu "&Regnskaber"
'SubMenuItem
CreateSubMenuItem "Klasse A-virksomheder", "UMenu01", "532"
CreateSubMenuItem "Klasse B-virksomheder", "UMenu02", "532"
CreateSubMenuItem "&Hjælp til regnskabsmodel", "Menu02", "42"
CreateSubMenu2 "&Budgetter"
'SubMenuItem
CreateSubMenuItem "12 måneder", "UMenu03", "71"
CreateSubMenuItem "Kvartal", "UMenu04", "72"
CreateSubMenuItem "År", "UMenu05", "73"
CreateSubMenu "&Indkomst- og formueopgørelse"
'SubMenuItem
CreateSubMenuItem "Grønt ark", "UMenu13", "532"
CreateSubMenu "&Selskabsstiftelse"
'SubMenuItem
CreateSubMenuItem "Skattefri", "UMenu06", "591"
CreateSubMenuItem "Skattepligtig", "UMenu07", "591"
CreateSubMenu "&Diverse skabeloner"
'SubMenuItem
CreateSubMenuItem2 "Saldomeddelelser"
CreateSubMenuItem3 "Dansk", "UMenu08", "83"
CreateSubMenuItem3 "Engelsk", "UMenu09", "84"
CreateSubMenuItem3 "Tysk", "UMenu10", "99"
CreateSubMenuItem "Indholdsfortegnelse personlige", "UMenu11", "12"
CreateSubMenuItem "Indholdsfortegnelse selskaber", "UMenu12", "12"
CreateSubMenuItem "Efterangivelse moms", "UMenu17", "591"
CreateSubMenu "&Vejledninger"
'SubMenuItem
CreateSubMenuItem "Låneomkostninger", "UMenu14", "591"
CreateSubMenuItem "Fri telefon m.m.", "UMenu15", "591"
CreateSubMenuItem "Koder", "UMenu16", "591"
CreateMenuItem "&Arbejdspapirer", "Menu01", "05"
CreateMenuItem "&Klientliste", "Menu03", "213"
End Sub
Sub DeleteMenu(strMenuName As String, intBarsNo As Integer)
' This sub should be executed when the workbook is closed
' Deletes the Menus
On Error Resume Next
Application.CommandBars(intBarsNo).Controls(strMenuName).Delete
On Error GoTo 0
End Sub
Private Sub CreateMainMenu(strMenuName, strMenuNo As String, intBarsNo As Integer)
'En ny hovedmenu
Set MenuObject = Application.CommandBars(intBarsNo).Controls.Add(Type:=msoControlPopup, _
Before:=strMenuNo, Temporary:=True)
MenuObject.Caption = strMenuName
End Sub
Private Sub CreateMenuItem(strCaption, strOnAction, strFaceId As String)
'Et menupunkt punkt direkte i hovedmenu'en
'MenuItem
Set MenuItem = MenuObject.Controls.Add(Type:=msoControlButton)
With MenuItem
.Caption = strCaption
.OnAction = strOnAction
.FaceId = strFaceId
End With
End Sub
Private Sub CreateSubMenu(strCaption)
'En menugruppe i hovedmenuen
'SubMenu
Set SubMenu = MenuObject.Controls.Add(Type:=msoControlPopup)
With SubMenu
.Caption = strCaption
End With
End Sub
Private Sub CreateSubMenu2(strCaption)
'En menugruppe i hovedmenuen
'SubMenu
Set SubMenu = MenuObject.Controls.Add(Type:=msoControlPopup)
With SubMenu
.Caption = strCaption
.Enabled = False
End With
End Sub
Private Sub CreateSubMenuItem(strCaption, strOnAction, strFaceId As String)
'Et menupunkt i en menugruppe
'SubMenu Item - UnderMenuPunkt
Set SubMenuItem = SubMenu.Controls.Add(Type:=msoControlButton)
With SubMenuItem
.Caption = strCaption
.OnAction = strOnAction
.FaceId = strFaceId
End With
End Sub
Private Sub CreateSubMenuItem2(strCaption)
Set SubMenuItem2 = SubMenu.Controls.Add(Type:=msoControlPopup)
With SubMenuItem2
.Caption = strCaption
End With
End Sub
Private Sub CreateSubMenuItem3(strCaption, strOnAction, strFaceId As String)
'Et menupunkt i en menugruppe
'SubMenu Item - UnderMenuPunkt
Set SubMenuItem3 = SubMenuItem2.Controls.Add(Type:=msoControlButton)
With SubMenuItem3
.Caption = strCaption
.OnAction = strOnAction
.FaceId = strFaceId
End With
End Sub
Private Sub Menu01()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Arbejdspapirer\Arbejdspapirer.xlt"
End Sub
Private Sub Menu02()
Dim WordObj As Object
Set WordObj = CreateObject("word.basic")
WordObj.appshow
WordObj.fileopen Name:="H:\Kunder\0_Mastere\Regnskab selskaber klasse B, C og D\Manual regnskabsmodel B.doc"
End Sub
Private Sub Menu03()
Workbooks.Open Filename:="H:\SHEETS\SR\Klientliste.xls"
End Sub
Private Sub UMenu01()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Regnskab personlige klasse A\Regnskab med makro A.xlt"
End Sub
Private Sub UMenu02()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Regnskab selskaber klasse B, C og D\Regnskab med makro BC.xlt"
End Sub
Private Sub UMenu03()
End Sub
Private Sub UMenu04()
End Sub
Private Sub UMenu05()
End Sub
Private Sub UMenu06()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Selskabsstiftelse\Skattefri\Selskabsstiftelse.xlt"
End Sub
Private Sub UMenu07()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Selskabsstiftelse\Skattepligtig\Selskabsstiftelse.xlt"
End Sub
Private Sub UMenu08()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Diverse standarder\Saldomeddelelser\Dansk.xlt"
End Sub
Private Sub UMenu09()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Diverse standarder\Saldomeddelelser\Engelsk.xlt"
End Sub
Private Sub UMenu10()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Diverse standarder\Saldomeddelelser\Tysk.xlt"
End Sub
Private Sub UMenu11()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\SR Revision AS\Mappeindeling personlige.xls"
End Sub
Private Sub UMenu12()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\SR Revision AS\Mappeindeling selskaber.xls"
End Sub
Private Sub UMenu13()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Diverse standarder\I & F - Grønt ark.xlt"
End Sub
Private Sub UMenu14()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\SR Revision AS\låneomk skat.xls"
End Sub
Private Sub UMenu15()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Diverse standarder\Fri telefon m.v..xls"
End Sub
Private Sub UMenu16()
Workbooks.Open Filename:="H:\SHEETS\SR\Diverse koder\Koder.xls"
End Sub
Private Sub UMenu17()
Workbooks.Open Filename:="H:\Kunder\0_Mastere\Moms\Momsefterangivelse.xls"
End Sub
