VBA - Build XML Add-Ins ribbon

XMLribbon.bas

Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)

Call UnloadCustomRibbon

End Sub
Private Sub Workbook_Open()

Call LoadCustomRibbon

End Sub
Private Sub LoadCustomRibbon()

Dim strOfficeUIContentNew As String
Dim strOfficeUIContent As String
Dim strOfficeUI_1stPart As String
Dim strOfficeUI_2ndPart As String
Dim lngTabsTagPosition As Long
Dim lngFile As Long
Dim strPath As String
Dim strFileName As String
Dim ribbonXML As String
Dim strUser As String

lngFile = FreeFile
strUser = Environ("Username")
strPath = "C:\Users\" & strUser & "\AppData\Local\Microsoft\Office\"
strFileName = "Excel.officeUI"

'check if ribbon file exist
If modUtils.CheckIfFileExists(strPath & strFileName) Then

    strOfficeUIContent = GetOfficeUIContent(strPath, strFileName)
    If strOfficeUIContent <> "" Then ribbonXML = strOfficeUIContent
    lngTabsTagPosition = InStr(1, strOfficeUIContent, "<mso:tabs>", vbTextCompare)

Else

    modUtils.CreateTextFile (strPath & strFileName)

End If

'if UI contains <mso:tabs> then it means that ribbon was already created therefore UI cannot be replaced. It must be updated (additional tags will be inserted
If lngTabsTagPosition > 0 Then

    'the second condition checks if YourNameTab tag is not in UI
    If InStr(1, strOfficeUIContent, "YourNameTab", vbTextCompare) = 0 Then

        Debug.Print "condition 1 met"
    
        strOfficeUI_1stPart = Mid(strOfficeUIContent, 1, lngTabsTagPosition + Len("<mso:tabs>") - 1)
        strOfficeUI_2ndPart = Mid(strOfficeUIContent, lngTabsTagPosition + Len("<mso:tabs>"), Len(strOfficeUIContent))
    
        ribbonXML = ""
        ribbonXML = ribbonXML + "      <mso:tab id='YourNameTab' label='YourName' insertBeforeQ='mso:TabFormat'>" & vbNewLine
        ribbonXML = ribbonXML + "        <mso:group id='YourNameGroup' label='ABC1' autoScale='true'>" & vbNewLine
        ribbonXML = ribbonXML + "          <mso:button id='ImportData' label='ABC2' " & vbNewLine
        ribbonXML = ribbonXML + "imageMso='ImportExcel'      onAction='ImportDataNew'/>" & vbNewLine
        ribbonXML = ribbonXML + "          <mso:button id='CreateReport' label='CreateReport' " & vbNewLine
        ribbonXML = ribbonXML + "imageMso='RecordsMoreRecordsMenu'      onAction='CreateReportNew'/>" & vbNewLine
        ribbonXML = ribbonXML + "        </mso:group>" & vbNewLine
        ribbonXML = ribbonXML + "      </mso:tab>" & vbNewLine
        
        strOfficeUIContentNew = strOfficeUI_1stPart & ribbonXML & strOfficeUI_2ndPart
        ribbonXML = strOfficeUIContentNew
        
    End If

Else

    'build the entire ribbon
    Debug.Print "condition 2 met"

    ribbonXML = ""
    ribbonXML = "<mso:customUI      xmlns:mso='http://schemas.microsoft.com/office/2009/07/customui'>" & vbNewLine
    ribbonXML = ribbonXML + "  <mso:ribbon>" & vbNewLine
    ribbonXML = ribbonXML + "    <mso:qat/>" & vbNewLine
    ribbonXML = ribbonXML + "    <mso:tabs>" & vbNewLine
    ribbonXML = ribbonXML + "      <mso:tab id='YourNameTab' label='YourName' insertBeforeQ='mso:TabFormat'>" & vbNewLine
    ribbonXML = ribbonXML + "        <mso:group id='YourNameGroup' label='ABC1' autoScale='true'>" & vbNewLine
    ribbonXML = ribbonXML + "          <mso:button id='ImportData' label='ImportData' " & vbNewLine
    ribbonXML = ribbonXML + "imageMso='ImportExcel'      onAction='ImportPODataNew'/>" & vbNewLine
    ribbonXML = ribbonXML + "          <mso:button id='CreateReport' label='CreateReport' " & vbNewLine
    ribbonXML = ribbonXML + "imageMso='RecordsMoreRecordsMenu'      onAction='CreateReportNew'/>" & vbNewLine
    ribbonXML = ribbonXML + "        </mso:group>" & vbNewLine
    ribbonXML = ribbonXML + "      </mso:tab>" & vbNewLine
    ribbonXML = ribbonXML + "    </mso:tabs>" & vbNewLine
    ribbonXML = ribbonXML + "  </mso:ribbon>" & vbNewLine
    ribbonXML = ribbonXML + "</mso:customUI>"

End If

ribbonXML = Replace(ribbonXML, """", "")

Open strPath & strFileName For Output Access Write As lngFile
Print #lngFile, ribbonXML
Close lngFile

End Sub
Private Sub UnloadCustomRibbon()

Dim strOfficeUI_1stPart As String
Dim strOfficeUI_2ndPart As String
Dim i As Long
Dim lngYourNameTabStartPos As Long
Dim lngYourNameTabEndPos As Long
Dim lngTabsTagPosition As Long
Dim lngFile As Long
Dim strOfficeUIContent As String
Dim strPath As String, strFileName As String, ribbonXML As String, strUser As String

lngFile = FreeFile
strUser = Environ("Username")
strPath = "C:\Users\" & strUser & "\AppData\Local\Microsoft\Office\"
strFileName = "Excel.officeUI"

'check if ribbon file exist
If modUtils.CheckIfFileExists(strPath & strFileName) Then

    strOfficeUIContent = GetOfficeUIContent(strPath, strFileName)
    If strOfficeUIContent <> "" Then ribbonXML = strOfficeUIContent
    lngTabsTagPosition = InStr(1, strOfficeUIContent, "<mso:tabs>", vbTextCompare)

Else

    Exit Sub

End If

If lngTabsTagPosition > 0 Then

    On Error Resume Next
    lngYourNameTabStartPos = InStr(1, strOfficeUIContent, "<mso:tab id='YourNameTab'", vbTextCompare)
    lngYourNameTabEndPos = InStr(lngYourNameTabStartPos, strOfficeUIContent, "</mso:tab>", vbTextCompare)
    On Error GoTo 0
    
    If lngYourNameTabStartPos > 0 And lngYourNameTabEndPos > 0 Then
    
        strOfficeUI_1stPart = Left(strOfficeUIContent, lngYourNameTabStartPos - 1)
        strOfficeUI_2ndPart = Mid(strOfficeUIContent, lngYourNameTabEndPos + Len("</mso:tab>"))
        ribbonXML = strOfficeUI_1stPart & strOfficeUI_2ndPart
    
    End If
        
Else
    
    'if UI file is empty (does not have TABS tag)
    ribbonXML = "<mso:customUI           xmlns:mso=""http://schemas.microsoft.com/office/2009/07/customui"">" & _
    "<mso:ribbon></mso:ribbon></mso:customUI>"

End If

Open strPath & strFileName For Output Access Write As lngFile
Print #lngFile, ribbonXML
Close lngFile

End Sub
Function AddInsInstalled() As Boolean

Dim objAddIn As AddIn

AddInsInstalled = False
For Each objAddIn In Application.AddIns

    If objAddIn.Installed Then AddInsInstalled = True: Exit Function

Next objAddIn

End Function
Function GetOfficeUIContent(strPath As String, strFileName As String) As String

Dim strUser As String
Dim varLineFromFile As Variant
Dim strContent As String

Open strPath & strFileName For Input As #1

Do Until EOF(1)

    Line Input #1, varLineFromFile
    strContent = strContent & varLineFromFile

Loop

Close #1

GetOfficeUIContent = strContent

End Function