Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Pasek narzędzi na wstążce

Zuzanna · Starszy Forumowicz Posty: 32

Znalazłam w internecie makro do tworzenia paska narzędziowego na wstążce, ale nie umiem poradzić sobie z problemem usuwania przez to makro innych zdefiniowanych przez użytkownika pasków narzędzi. Czy ktoś jest w stanie mi pomóc z tym problemem.

TEST.xlsm

Pobierz Plik ściągnięto 72 raz(y) 16.25 KB

OShon · Wysłany: 05-02-2019, 21:55

Albo przywróć z opcji aplikacji (sa przyciski do resetu) a jak chcesz kodem to

Kod:

application.CommandBars(nazwa_paska).reset

a jak twój padek to

Kod:

application.CommandBars(nazwa_paska).delete

Zuzanna · Starszy Forumowicz Posty: 32

Chyba się nie zrozumieliśmy. Jak nie chcę nic usuwać. Makro powinno stworzyć kolejny pasek narzędzi (kartę na wstążce), nie usuwając już innych pasków narzędzi zrobionych przez użytkownika. W tej chwili po uruchomieniu makra usuwa bezpowrotnie moją kartę z dodanymi makrami, oraz usuwa dodane polecenia z paska narzędzi szybki dostęp.
Makro odwołuje się do pliku konfiguracji wstążki i chyba je nadpisuje - tak mi się wydaje. Jak temu zapobiec. ?

apollo · ExcelSpec **Pomógł:** 1295 razy Posty: 4483

Możesz iść inną drogą.
1. Dodajesz menu do riibon kodem
2. Dodajesz używając Custon UI Editor.

Jeśli chesz konkrety to musisz opisać, co zawiera swoje menu, ile pozycji, kod dla każdej pozycji itd.

Zuzanna · Starszy Forumowicz Posty: 32

Koledzy ze względu na minimalną wiedzę z VBA proszę o przeanalizowanie poniższego kody. Czy nie rozwiązuje on mojego problemu ?.

Kod:

'Declaration needed for shfolder
Private Const SHGFP_TYPE_CURRENT = 0
Private Const CSIDL_LOCAL_APPDATA = &H1C

Private Declare Function SHGetFolderPath Lib "shfolder" Alias "SHGetFolderPathA" (ByVal hwndOwner As Long, ByVal nFolder As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal pszPath As String) As Long

'Put your application name in here
Private Const OfficeApplicationFileName As String = "MSProject.officeUI"

Public Sub Setup_MyOwnButton()
Dim FilePath As String
Dim CurrentXML As String
Dim ribbonXMLHeader As String
Dim ribbonXMLContent As String
Dim ribbonXMLNew As String
Dim ribbonXMLFooter As String
Dim XPos1 As Long
Dim XPos2 As Long
Dim X As Long
Dim retVal As Long

'Read current path, where the files are placed
FilePath = String(255, vbNullChar)
retVal = SHGetFolderPath(0, CSIDL_LOCAL_APPDATA, 0, SHGFP_TYPE_CURRENT, FilePath)
FilePath = Left(FilePath, InStr(1, FilePath, Chr(0)) - 1)
FilePath = FilePath & "\Microsoft\Office\" & OfficeApplicationFileName

CurrentXML = ""
If ExistsFile(FilePath) Then

'Read the content of the CustomUI file, if exists
X = FreeFile
Open FilePath For Input As #X
Input #X, CurrentXML
Close #X

'Extract the header, footer and actual content from the XML file
XPos1 = InStr(CurrentXML, "<mso:tabs>") + Len("<mso:tabs>") - 1
XPos2 = InStr(CurrentXML, "</mso:tabs>")

If XPos1 > 0 Then
ribbonXMLHeader = Left$(CurrentXML, XPos1)
End If
If XPos2 > 0 Then
ribbonXMLFooter = Mid$(CurrentXML, XPos2)
End If
If XPos1 > 0 And XPos2 > 0 Then
ribbonXMLContent = Mid$(CurrentXML, XPos1 + 1, Len(CurrentXML) - XPos1 - Len(ribbonXMLFooter))
End If

Else
'Create a new Header and footer
ribbonXMLHeader = "<mso:customUI xmlns:x2=""http://schemas.microsoft.com/office/2009/07/customui/macro"""
ribbonXMLHeader = ribbonXMLHeader + " xmlns:x1=""TFCOfficeShim.Connect.3"""
ribbonXMLHeader = ribbonXMLHeader + " xmlns:mso=""http://schemas.microsoft.com/office/2009/07/customui"">"
ribbonXMLHeader = ribbonXMLHeader + "<mso:ribbon>"
ribbonXMLHeader = ribbonXMLHeader + "<mso:qat/>"
ribbonXMLHeader = ribbonXMLHeader + "<mso:tabs>"

ribbonXMLFooter = ribbonXMLFooter + "</mso:tabs>"
ribbonXMLFooter = ribbonXMLFooter + "</mso:ribbon>"
ribbonXMLFooter = ribbonXMLFooter + "</mso:customUI>"

End If

'Define the new menu item, menu group and button for the macro
'ID has to be unique, but you can use any name
'Label is just your name
'imageMso is the name of an existing application icon, create it one time via File-Options to find your icons.
'onAction is the Name of your Macro

ribbonXMLNew = ribbonXMLNew + "<mso:tab id=""MyMenuItemIdentifier"" label=""MyMenuLabel"" insertBeforeQ=""mso:TabFormat"">"
ribbonXMLNew = ribbonXMLNew + "<mso:group id=""MyMenuGroupIdentifier"" label=""MyGroupLabel"" imageMso=""ShowClipboard"" autoScale=""true"">"
ribbonXMLNew = ribbonXMLNew + "<mso:button id=""MyButtonIdentifier"" label=""MyMacroLabel"" "
ribbonXMLNew = ribbonXMLNew + "imageMso=""HyperlinksVerify"" onAction=""NameOfMyMacro"" visible=""true""/>"
ribbonXMLNew = ribbonXMLNew + "</mso:group></mso:tab>"

'Add the new content to the existing content if exists
XPos1 = InStr(ribbonXMLContent, ribbonXMLNew)
If XPos1 > 0 Then
ribbonXMLContent = Left$(ribbonXMLContent, XPos1 - 1) & Mid$(ribbonXMLContent, XPos1 + Len(ribbonXMLNew))
ribbonXMLContent = ribbonXMLContent + ribbonXMLNew
Else
ribbonXMLContent = ribbonXMLContent + ribbonXMLNew
End If

'Write the new XML
X = FreeFile
Open FilePath For Output As X
Print #X, ribbonXMLHeader + ribbonXMLContent + ribbonXMLFooter
Close #X

MsgBox "Please close the application and reopen it again", vbInformation, "My Setup Tool"

End Sub

'******************************************************************************
'Helper Macros
Public Function ExistsFile(wwFile As String) As Boolean
Dim ret As Long
On Error Resume Next
ret = GetAttr(wwFile)
If Err = 0 Or Err = 70 Then
ExistsFile = True
Else
ExistsFile = False
End If
Err = 0
End Function

Artik · Wersja: Win Office 365 **Pomógł:** 2940 razy Posty: 9729

Żabko droga,