Przesunięty przez: Artik 26-09-2019, 23:15 |
Pasek narzędzi na wstążce |
Autor |
Wiadomość |
Zuzanna
Starszy Forumowicz

Posty: 36
|
Wysłany: 05-02-2019, 11:12 Pasek narzędzi na wstążce
|
|
|
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 102 raz(y) 16.25 KB |
|
|
 | ID posta:
361985
|
|
|
 |
|
|
|
OShon
Excel Expert


Zaproszone osoby: 396
Wersja: Win Office 365
Pomógł: 1638 razy Posty: 8386
|
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 |
|
_________________ Oskar Shon - MVP Office System/Development 11/21, 3xMCC, 4/9/22 TechNet
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA | GL Excel VBA
Dodatki do Office VBATools.pl, aktualne promocje, darmowe artykuły i literatura
|
|
 | ID posta:
362027
|
|
|
 |
|
|
Zuzanna
Starszy Forumowicz

Posty: 36
|
Wysłany: 05-02-2019, 22:13
|
|
|
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. ? |
|
 | ID posta:
362030
|
|
|
 |
|
|
apollo
ExcelSpec

Pomógł: 1306 razy Posty: 4517
|
Wysłany: 05-02-2019, 22:44
|
|
|
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. |
|
 | ID posta:
362035
|
|
|
 |
|
|
Zuzanna
Starszy Forumowicz

Posty: 36
|
Wysłany: 06-02-2019, 13:43
|
|
|
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 |
|
|
 | ID posta:
362073
|
|
|
 |
|
|
Artik


Wersja: Win Office 365
Pomógł: 3091 razy Posty: 10240
|
Wysłany: 07-02-2019, 16:19
|
|
|
Żabko droga, Zuzanna napisał/a: | ze względu na minimalną wiedzę z VBA | powiedz nam CO chcesz zrobić, a nie JAK chcesz zrobić.
W tej chwili walisz sztachetą na oślep. A można tak celnie, raz przez łeb i po zawodach.
..::Edit
W załączniku przykład odwzorowujący kod z załącznika, który pokazałaś w pierwszym poście. ::..
Artik
TEST zuzanna1.xlsm
|
Pobierz Plik ściągnięto 109 raz(y) 14.42 KB |
|
_________________ Persistence is a virtue in the world of programming. |
|
 | ID posta:
362144
|
|
|
 |
|
|
|
Nie możesz pisać nowych tematów Możesz odpowiadać w tematach Nie możesz zmieniać swoich postów Nie możesz usuwać swoich postów Nie możesz głosować w ankietach Nie możesz załączać plików na tym forum Możesz ściągać załączniki na tym forum
|
Dodaj temat do Ulubionych Wersja do druku
|
 |
Strona używa plików cookies.
Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe
|