Egen værktøjslinie

For Each bar In Application.CommandBars
    If Not bar.BuiltIn And Not bar.Visible Then bar.Delete
Next

sletter skjulte hjemmelavede commandbars.

Hej kabbak

Det ser super ud

Gider du udbygge eksemplet med et par knapper så jeg kan se hvordan jeg skal lave det i xla-filen ?

1) Kan man også selv bestemme knappens "billede"
2) Kan man lave denne type værktøjslinie "skjult" ved lukning af skabelonen. I tilfælde af at man åbner to versioner af skabelonen og kommer til at lukke den ene igen så skal værktøjslinien ikke forsvinde (man skal kunne højreklikke og vise den igen). Men den skal forsvinde når der ikke er nogen skabelon åben.

Du får et eksempel på hvordan jeg sletter en gammel menulinje og laver den anden via kode.

1. Billedet, har jeg ikke fundet ud af, jeg bruger tekst.

2. har jeg ikke testet.

Sub auto_open()
    For Each cbar In CommandBars
        If cbar.Name = "MinBar" Then
            CommandBars("MinBar").Delete    ' sletter MinBar, hvis den er der i forvejen
        End If
    Next
    Set cbar1 = CommandBars.Add(Name:="MinBar", Position:=msoBarTop)

    cbar1.Visible = True
    Set newItem = CommandBars("MinBar").Controls.Add(Type:=msoControlButton)

    With newItem
        .BeginGroup = True
        .FaceId = 420
        .Caption = "(Lav menu)"
        .Style = msoButtonCaption
        .OnAction = "Menu"
    End With

    Set newItem = CommandBars("MinBar").Controls.Add(Type:=msoControlButton)
    With newItem
        .BeginGroup = False
        .Caption = "(Gentag overskrift)"
        .Style = msoButtonCaption
        .OnAction = "linje"
    End With

    Set newItem = CommandBars("MinBar").Controls.Add(Type:=msoControlButton)
    With newItem
        .BeginGroup = False
        .Caption = "(Sti)"
        .Style = msoButtonCaption
        .OnAction = "Sti"
    End With

End Sub
Sub Trans()
    FlytData.Show
End Sub
Sub Linje()
    On Error GoTo Slut
    A = MsgBox("Vil du gentage en eller flere linier på alle udskrevne sider", vbYesNo, "OVERSKRIFT PÅ UDSKRIFT  v.MinBar Kabbak ©")
    If A = 6 Then
        B = InputBox("Hvor mange linier", "Antal linier", 1)

        With ActiveSheet.PageSetup
            .PrintTitleRows = "$1:$" & B
            .PrintTitleColumns = ""
        End With
    Else

        Exit Sub
    End If
Slut:
End Sub


Function Tørvægt_M2(RestVægt, NeddeltVægt, Tørvægt, Areal)

    V1 = RestVægt + NeddeltVægt

    If V1 > 0 Then
        V2 = V1 * Tørvægt
        V3 = NeddeltVægt * Areal
        Tørvægt_M2 = V2 / V3
    End If

    If V1 = 0 And Tørvægt > 0 And Areal > 0 Then
        Tørvægt_M2 = Tørvægt / Areal
    End If

    If Tørvægt_M2 = 0 Then
        Tørvægt_M2 = "mangler data"
    End If
End Function


Public Sub Menu()
    Dim W As Integer, K As Integer, A As Integer
    A = MsgBox("Vil du indsætte et ark ved navn MENU, eller opdatere eksisterende, hvor der er Hyperlink til dine ark", vbYesNo, "MENU OPRETTER  v.Kabbak ©")
    If A = 6 Then
        W = 1    ' styrer række inden for hyperlink
        K = 1    ' styrer kolonner inden for hyperlink
        For Each ws In Worksheets
            If ws.Name = "Menu" Then GoTo Findes
        Next ws

        Set NewSheet = Worksheets.Add    ' opretter nyt ark
        NewSheet.Name = "Menu"        ' navngiver det nye ark

Findes:
        Worksheets("Menu").Activate
        Range("a1").Select
        If ActiveCell.Value = "" Then
            ActiveCell.Value = "MENU Styring    v.Kabbak ©"
            ActiveCell.Font.Color = vbBlue
            ActiveCell.Font.Bold = True
            ActiveCell.Font.Italic = True

            Range("A1:i1").Select
            With Selection
                .HorizontalAlignment = xlCenter
            End With
            Selection.Merge
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 3
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 3
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 3
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .Weight = xlMedium
                .ColorIndex = 3
            End With
        End If
        Range("a2:i31").Select            ' sletter alle data i området til hyperlink
        Selection.ClearContents            '    der kan jo være fjernet sider ???
        Range("a2").Select
        '-----------------------------------------Der laves hyperlink til alle ark  -------------
        For Each ws In Worksheets
            Worksheets("Menu").Range("a2:a260").Cells(W, K).Select    ' reseverer et område til at skrive hyperlink i

            If ws.Name = "Menu" Then GoTo Næste    ' Hopper over hovedarket "Menu"

            ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & ws.Name & "'" & "!A1"
            ActiveCell.FormulaR1C1 = ws.Name    ' skriver hyperlink på alle sider inden for området
            W = W + 1
Næste:
        Next ws
        '------------------------------Soterer kollonne A ----------------------------
        Range("A2").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
                      OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                      DataOption1:=xlSortNormal

        '--------------- Flytter data over i 4 kolonner ------------------------
        R = 2
        For I = 31 To 252 Step 28
            Range("A" & I & ":A" & I + 28).Cut
            Cells(2, R).Select
            ActiveSheet.Paste
            R = R + 1
        Next
        Columns("A:I").Select
        Selection.EntireColumn.AutoFit
        Range("A1").Select

    Else
        Exit Sub
    End If
End Sub
Sub Sti()
    A = MsgBox("Vil indsætte stien til XL Regnearket i sidefoden ", vbYesNo, "FILPLACERINGEN BLIVER ANGIVET PÅ UDSKRIFT  v.MinBar Bak ©")
    If A = 6 Then
        Application.ScreenUpdating = False
        Application.StatusBar = "Ændrer sidefod i" & ActiveSheet.Name
        ActiveSheet.PageSetup.LeftFooter = ActiveWorkbook.Path & "\" & " &F"
        Application.StatusBar = False
    End If
End Sub

Jeg tror måske vi taler lidt forbi hinanden.

Det skal ikke være en menu (ligesom Filer - Rediger m.v.)

Det skal være en værktøjslinie (ikoner - Fed - Kursiv m.v.)

Du må meget gerne forklare lidt dybere hvor koden skal placeres hvis jeg tager fejl. Jeg kan slet ikke få det til at virke.

Jeg tror jeg har fået det til at virke med at lave en værktøjslinie nu.

Men måske nogle kunne fortælle mig hvordan man sætter egne ikoner på linien når den nu er lavet via kode ?

Kom med et svar kabbak så får du point

Jeg åbner et nyt spørgsmål angående design af ikoner

et svar ;-))
som jeg sagde, ved jeg ikke noget om billeder på knapperne

Helt OK