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
De fleste virksomheder har efterhånden bevist, at AI virker.
Pilotprojekter leverer resultater. Medarbejdere bruger generative AI-værktøjer. Nye use cases dukker op på tværs af organisationen.
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 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
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
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.
