Option Explicit '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
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (2)
Commented:
Private Function BuildButton(id As String, label As String, imageMso As String, onAction As String, visible As String) As String
id = Chr(34) & "x1:" & id & Chr(34)
label = Chr(34) & label & Chr(34)
imageMso = Chr(34) & imageMso & Chr(34)
onAction = Chr(34) & onAction & Chr(34)
visible = Chr(34) & visible & Chr(34)
BuildButton = "<mso:button idQ=" & id & _
" label=" & label & _
" imageMso=" & imageMso & _
" onAction=" & onAction & _
" visible=" & visible & _
"/>" & vbCrLf
End Function
This allows the buttons to be added like so:
ribbonXMLNew = ribbonXMLNew + BuildButton("MyMenuItemIde
Just found that a little easier to read. Also, I had to add "PtrSafe" to the Declare Function statement in order to use this on a 64 bit system.
My only request is that you add some comments to that Declare function, as I am not familiar with those code objects and am not sure what it is doing.
Again, this was great. Thanks for posting!!!
Commented:
Thanks you very much for this macro !
For your information, if you put that macro in the "Application_Startup" of "ThisOutlookSession", it can create the ribbon at start ! No need to restart then.
BR
Kevin