Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 64043 Skopiuj do schowka Pasek narzędzi na wstążce
Autor Wiadomość
Zuzanna 
forumowicz


Posty: 19
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 20 raz(y) 16.25 KB

ID posta: 361985 Skopiuj do schowka
 
 
OShon 
Excel Expert



Zaproszone osoby: 383
Wersja: Win Office 365
Pomógł: 1631 razy
Posty: 8319
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/20r, 3x MCC
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA
Sprawdź promocje na polskie dodatki do MS Office w VBATools.pl
ID posta: 362027 Skopiuj do schowka
 
 
Zuzanna 
forumowicz


Posty: 19
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 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1236 razy
Posty: 4306
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 Skopiuj do schowka
 
 
Zuzanna 
forumowicz


Posty: 19
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 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2659 razy
Posty: 8828
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 18 raz(y) 14.42 KB

_________________
Persistence is a virtue in the world of programming.
ID posta: 362144 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie 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

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

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