'Copyright (c) 2025 optimal(xl) (www.optimalxl.com; [email protected]) {v=2025.3.28.0; a=c3b36f93; u=e3b1e0aac539}
'**NOTE**: Do not edit or place your own code in this module or this optimalxl.xlam file. Any changes to this file 
'          will be lost when Excel is closed, even if you save the file.
Option Explicit
Option Private Module
#If VBA7 And Not Mac Then
Private Const XML_NAMESPACE As String = "urn:optimalxl.com/hosta"
Private Const SH_IDX_LOG    As Long = 1
Private Const SH_IDX_KV     As Long = 2
Private Const LOG_TOT_COLS  As Long = 9
Private Const LOG_COL_LEVEL As Long = 5
Private Enum ErrorCode
    [_Fst] = 600 + vbObjectError
    HttpConnectionFailed
    HttpSendFailed
    HttpConnectionTimedOut
    HttpStatusNotOk
    HttpStreamToFileFailed
    HttpUrlIsEmpty
    TrampolineBookOpenFailed
    TrampolineTooManyArgs
    CreateFolderFailed
    HostBWorkbookOpenFailed
    HostBInitRunFailed
    HostBCopyInstallToTmpFailed
    HostBCopyTmpToInstallFailed
    HostBDownloadOrOpenFailed
    CreateObjectFailed
    MetaDataMissing
    MetaDataLoadFailed
    MissingArgument
    DiagnosticsFailed
    ViewLogFailed
    MissingHelpUrl
    BrowseToHelpUrlFailed
    Unidentified
    [_Lst]
End Enum
Private Enum UpdateType
    Installed = 2
    Opened
    Requested
    HotReload
End Enum
Private Type AddinMetaData
    is_init             As Boolean
    id                  As String
    app_display_name    As String
    publish_time        As String
    user_id             As String
    hostb_urls          As String
    help_url            As String
    help_email          As String
    ver                 As String
    cr                  As String
    code_md5            As String
    raw_xml             As String
End Type
Private installInProcess_   As Boolean
Private meta_               As AddinMetaData
Private rLogTarget_         As Range
Private wePutStatusBarOn_   As Boolean
Private updateType_         As UpdateType
Private Property Get AppMeta() As AddinMetaData
    If Not meta_.is_init Then
        loadMetaData
    End If
    AppMeta = meta_
End Property
Private Property Get AppNamespace() As String
    AppNamespace = Mid(ThisWorkbook.Name, 1, InStrRev(ThisWorkbook.Name, ".") - 1)
End Property
Private Property Get AppDisplayName() As String
    If Len(AppMeta.app_display_name) > 0 Then
        AppDisplayName = AppMeta.app_display_name
    Else
        AppDisplayName = AppNamespace
    End If
End Property
Private Property Get AppFldPth() As String
    AppFldPth = ThisWorkbook.path & Application.PathSeparator & AppNamespace & "_app"
End Property
Private Property Get AppTmpFldPth() As String
    AppTmpFldPth = AppFldPth & Application.PathSeparator & "tmp"
End Property
Private Property Get AppBinHostbFldPth() As String
    AppBinHostbFldPth = AppFldPth & Application.PathSeparator & "bin" & Application.PathSeparator & "hostb"
End Property
Private Property Get HostbFileName() As String
    HostbFileName = AppNamespace & "_hostb.xlam"
End Property
Private Property Get AppBinHostbFullName() As String
    AppBinHostbFullName = AppBinHostbFldPth & Application.PathSeparator & HostbFileName
End Property
Private Property Get HostbInitMacro() As String
    HostbInitMacro = "'" & HostbFileName & "'!init"
End Property
Private Function updateTypeToString(ByVal x As UpdateType) As String
    Select Case x
        Case UpdateType.Installed
            updateTypeToString = "Installed"
        Case UpdateType.Opened
            updateTypeToString = "Opened"
        Case UpdateType.Requested
            updateTypeToString = "Requested"
        Case UpdateType.HotReload
            updateTypeToString = "HotReload"
        Case Else
            updateTypeToString = "Unknown"
    End Select
End Function
Private Function kvGetKeysRange() As Range
    Dim sh  As Worksheet
    Set sh = ThisWorkbook.Worksheets(SH_IDX_KV)
    Set kvGetKeysRange = Excel.Range(sh.Range("a1"), sh.Range("a" & CStr(sh.Rows.Count)).End(xlUp))
End Function
Private Function kvGetValueCell(ByVal k As String) As Range
    Dim sh      As Worksheet
    Dim rKeys   As Range
    Dim idx     As Variant
    Set sh = ThisWorkbook.Worksheets(SH_IDX_KV)
    Set rKeys = kvGetKeysRange()
    idx = sh.Evaluate("=MATCH(" & Chr(34) & k & Chr(34) & "," & rKeys.Address(0, 0) & ",0)")
    If Not IsError(idx) Then
        Set kvGetValueCell = rKeys.Cells(CLng(idx), 1).Offset(, 1)
    Else
        Set kvGetValueCell = Nothing
    End If
End Function
Private Function kvGetValue(ByVal k As String) As Variant
    Dim sh  As Worksheet
    Dim r   As Range
    Set sh = ThisWorkbook.Worksheets(SH_IDX_KV)
    Set r = kvGetValueCell(k)
    If Not r Is Nothing Then
        kvGetValue = r.Value
    Else
        kvGetValue = CVErr(XlCVError.xlErrNA)
    End If
End Function
Private Sub kvPutValue(ByVal k As String, ByVal v As Variant)
    Dim sh  As Worksheet
    Dim r   As Range
    Set sh = ThisWorkbook.Worksheets(SH_IDX_KV)
    Set r = kvGetValueCell(k)
    If Not r Is Nothing Then
        r.Value = v
    Else
        Set r = sh.Range("a1")
        If IsEmpty(r.Value2) Then
        ElseIf IsEmpty(r.Offset(1).Value2) Then
            Set r = r.Offset(1)
        Else
            Set r = sh.Range("a" & CStr(sh.Rows.Count)).End(xlUp).Offset(1)
        End If
        r.Resize(, 2).Value = VBA.Array(k, v)
    End If
End Sub
Private Sub logl(ByVal levelText As String, ByVal msg As String)
    Dim r   As Range
    Dim sh  As Worksheet
    Set sh = ThisWorkbook.Worksheets(SH_IDX_LOG)
    If IsEmpty(sh.Range("a1").Value) Then
        sh.Range("a1").Resize(, LOG_TOT_COLS).Value = VBA.Array("dt", "time", "ts", "src_id", "level", "msg", "book", "path", "stack")
        sh.Range("a2").NumberFormat = "yyyy-mm-dd" 
        sh.Range("b2").NumberFormat = "hh:mm:ss"
        sh.Range("c2").NumberFormat = "0.000"
    End If
    If IsEmpty(sh.Range("a2").Value) Then
        Set r = sh.Range("a2")
    Else
        If Not rLogTarget_ Is Nothing Then
            If IsEmpty(rLogTarget_.Value) Then
                Set r = rLogTarget_
            Else
                Set r = sh.Range("a1").End(xlDown).Offset(1)
            End If
        Else
            Set r = sh.Range("a1").End(xlDown).Offset(1)
        End If
    End If
    r.Resize(, LOG_TOT_COLS).Value = VBA.Array(DateTime.Date, DateTime.Time, DateTime.timer, "hosta", levelText, msg, ThisWorkbook.Name, ThisWorkbook.path, Empty)
    If r.Row > 20000 Then
        sh.Rows("2:15001").Delete
        Set rLogTarget_ = sh.Range("a20000").End(xlUp).Offset(1)
    Else
        Set rLogTarget_ = r.Offset(1)
    End If
End Sub
Private Sub logDbug(ByVal msg As String)
    logl "DBUG", msg
End Sub
Private Sub logInfo(ByVal msg As String)
    logl "INFO", msg
End Sub
Private Sub logWarn(ByVal msg As String)
    logl "WARN", msg
End Sub
Private Sub logErro(ByVal msg As String)
    logl "ERRO", msg
End Sub
Private Sub logFatl(ByVal msg As String)
    logl "FATL", msg
End Sub
Private Sub writeStatus(msg As String)
    If Not Application.DisplayStatusBar Then
        wePutStatusBarOn_ = True
        Application.DisplayStatusBar = True
    End If
    If installInProcess_ Then
        Application.StatusBar = AppDisplayName & " installing: " & msg & " ..."
    Else
        Application.StatusBar = AppDisplayName & " updating: " & msg & " ..."
    End If
End Sub
Private Sub clearStatus()
    Application.StatusBar = False
    If wePutStatusBarOn_ Then
        Application.DisplayStatusBar = False
    End If
    If Application.Cursor <> XlMousePointer.xlDefault Then
        Application.Cursor = XlMousePointer.xlDefault
        DoEvents
    End If
End Sub
Private Function lateBoundObj(ParamArray classIds() As Variant) As Object
    Dim i       As Long
    Dim x       As Object
    Dim esource As String
    esource = ThisWorkbook.Name & "!lateBoundObj"
    If UBound(classIds) = -1 Then
        Err.Raise ErrorCode.MissingArgument, esource, "class id is empty"
    Else
        For i = LBound(classIds) To UBound(classIds)
            On Error Resume Next
            Set x = CreateObject(CStr(classIds(i)))
            On Error GoTo 0
            If Not x Is Nothing Then
                Set lateBoundObj = x
                Exit Function
            End If
        Next
    End If
    Err.Raise ErrorCode.CreateObjectFailed, esource, "missing a required Windows component: " & Join(classIds, "; ")
End Function
Private Function lateBoundDictionary() As Object
    Set lateBoundDictionary = lateBoundObj("Scripting.Dictionary")
End Function
Private Function lateBoundFileSystemObject() As Object
    Set lateBoundFileSystemObject = lateBoundObj("Scripting.FileSystemObject")
End Function
Private Function lateBoundHttp() As Object
    Set lateBoundHttp = lateBoundObj("MSXML2.XMLHTTP.6.0", "MSXML2.XMLHTTP.5.0", "MSXML2.XMLHTTP")
End Function
Private Function lateBoundXml() As Object
    Set lateBoundXml = lateBoundObj("MSXML2.DOMDocument.6.0", "MSXML2.DOMDocument.3.0", "MSXML2.DOMDocument")
End Function
Private Function lateBoundADODBStream() As Object
    Set lateBoundADODBStream = lateBoundObj("ADODB.Stream")
End Function
Private Function newWb() As Workbook
    Dim n As Long
    n = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = 1
    Set newWb = Application.Workbooks.Add()
    Application.SheetsInNewWorkbook = n
End Function
Private Function xmlNodeText(nd As Object) As String
    If Not nd Is Nothing Then
        xmlNodeText = trim$(nd.text)
    End If
End Function
Private Function abrvPath(ByVal pth As String) As String
    abrvPath = Replace(pth, ThisWorkbook.path, "..", Compare:=VbCompareMethod.vbTextCompare)
End Function
Private Function appMsgBoxTitle() As String
    If Len(AppMeta.ver) > 0 Then
        appMsgBoxTitle = AppDisplayName & "  (" & AppMeta.ver & "a)"
    Else
        appMsgBoxTitle = AppDisplayName
    End If
End Function
Private Sub loadMetaData()
    Dim dom     As Object
    Dim cp      As CustomXMLPart
    Dim i       As Long
    Dim esource As String
    esource = ThisWorkbook.Name & "!loadMetaData"
    On Error GoTo eh
    meta_.is_init = True
    Set dom = lateBoundXml()
    dom.SetProperty "SelectionNamespaces", "xmlns:ns='" & XML_NAMESPACE & "'"
    For Each cp In ThisWorkbook.CustomXMLParts.SelectByNamespace(XML_NAMESPACE)
        If dom.LoadXML(cp.xml) Then
            meta_.hostb_urls = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:hostb_urls"))
            meta_.app_display_name = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:app_display_name"))
            meta_.help_url = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:help_url"))
            meta_.help_email = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:help_email"))
            meta_.ver = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:version"))
            meta_.code_md5 = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:code_md5"))
            meta_.cr = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:copyright"))
            meta_.user_id = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:user_id"))
            meta_.publish_time = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:publish_time"))
            meta_.id = xmlNodeText(dom.SelectSingleNode("ns:addin_props/ns:id"))
            meta_.raw_xml = cp.xml
            If Len(meta_.hostb_urls) > 0 Then
                Exit For
            End If
        End If
    Next
    With ThisWorkbook.BuiltinDocumentProperties
        For i = 1 To .Count
            With .Item(i)
                If LCase$(.Name) = "title" Then
                    If Len(trim$(.Value)) > 0 Then
                        meta_.app_display_name = trim$(.Value)
                    End If
                End If
            End With
        Next
    End With
    Exit Sub
eh:
    Select Case Err.Number
        Case ErrorCode.[_Fst] To ErrorCode.[_Lst]
            Err.Raise Err.Number, Err.source, Err.Description
        Case 0
            Err.Raise ErrorCode.Unidentified, esource, "control flow error"
        Case Else
            Err.Raise ErrorCode.MetaDataLoadFailed, esource, "metadata in " & ThisWorkbook.Name & " could not be loaded (" & Err.Description & ")"
    End Select
End Sub
Private Function alert(ByVal msg As String, Optional ByVal buttons As VbMsgBoxStyle = VbMsgBoxStyle.vbOKOnly, Optional ByVal title As String = "") As VbMsgBoxResult
    Dim cursorState As XlMousePointer
    If Application.Cursor <> XlMousePointer.xlDefault Then
        cursorState = Application.Cursor
        Application.Cursor = XlMousePointer.xlDefault
        DoEvents
    End If
    If Len(trim(title)) = 0 Then
        title = appMsgBoxTitle()
    End If
    If Application.ScreenUpdating Then
        alert = MsgBox(msg, buttons, title)
    Else
        Application.ScreenUpdating = True
        alert = MsgBox(msg, buttons, title)
        Application.ScreenUpdating = False
    End If
    If cursorState <> 0 Then
        Application.Cursor = cursorState
        DoEvents
    End If
End Function
Private Function folderCreateRecursive(ByVal pth As String) As String
    Dim fso     As Object
    Dim esource As String
    esource = ThisWorkbook.Name & "!folderCreateRecursive"
    Set fso = lateBoundFileSystemObject()
    If fso.FolderExists(pth) Then
        folderCreateRecursive = pth
    Else
        folderCreateRecursive fso.GetParentFolderName(pth)
        On Error Resume Next
        fso.CreateFolder pth
        On Error GoTo 0
        If fso.FolderExists(pth) Then
            folderCreateRecursive = pth
        Else
            Err.Raise ErrorCode.CreateFolderFailed, esource, "this required folder can not be created: " & pth
        End If
    End If
End Function
Private Function timestampWithRandSuffix() As String
    With Application.WorksheetFunction
        timestampWithRandSuffix = Format(DateTime.Now, "yyyymmddTHHnnss") & "_" & Chr(.RandBetween(97, 122)) & Chr(.RandBetween(97, 122)) & Chr(.RandBetween(97, 122))
    End With
End Function
Private Function createNewTmpFldForHostb() As String
    Dim fso As Object
    Dim tmp As String
    Dim n   As Long
    folderCreateRecursive AppTmpFldPth
    Set fso = lateBoundFileSystemObject()
    Do
        tmp = AppTmpFldPth & Application.PathSeparator & "hostb_" & timestampWithRandSuffix()
        n = n + 1
        If n > 1 Then
            logWarn "in createNewTmpFldForHostb n = " & CStr(n)
        End If
    Loop Until Not fso.FolderExists(tmp) Or n > 10
    createNewTmpFldForHostb = folderCreateRecursive(tmp)
End Function
Private Function randomizeUrl(ByVal url As String) As String
    randomizeUrl = url & "?rnd=" & timestampWithRandSuffix()
End Function
Private Sub downloadHostB(ByVal urlRaw As String, ByVal destinationFullPath As String)
    Dim http        As Object
    Dim ms          As Object
    Dim timestamp   As Date
    Dim msg         As String
    Dim esource     As String
    Dim url         As String
    esource = ThisWorkbook.Name & "!downloadHostB"
    If (Len(trim$(urlRaw))) = 0 Then
        Err.Raise ErrorCode.HttpUrlIsEmpty, esource, AppDisplayName & " is missing a url for " & HostbFileName
    End If
    Set http = lateBoundHttp()
    url = randomizeUrl(urlRaw)
    logDbug "hostb url = " & urlRaw
    logDbug "hostb randomized url = " & url
    timestamp = DateTime.Now()
    On Error Resume Next
    http.Open "GET", url, True 
    If Err.Number <> 0 Then
        msg = "http connection failed (" & Err.Description & ") url = " & url
        On Error GoTo 0
        Err.Raise ErrorCode.HttpConnectionFailed, esource, msg
    End If
    http.setRequestHeader "Content-Type", "application/octet-stream"
    http.send
    If Err.Number <> 0 Then
        msg = "http send request failed (" & Err.Description & ") url = " & url
        On Error GoTo 0
        Err.Raise ErrorCode.HttpSendFailed, esource, msg
    End If
    Do
        If Abs(VBA.CDbl(DateTime.DateDiff("s", timestamp, DateTime.Now()))) > 6# Then
            http.abort
            Exit Do
        End If
        DoEvents
        If http.readyState <> 4 Then
            Call Application.Wait(DateTime.Now() + DateTime.TimeSerial(0, 0, 1))
        Else
            Exit Do
        End If
    Loop
    On Error GoTo 0
    If http.readyState <> 4 Then
        Err.Raise ErrorCode.HttpConnectionTimedOut, esource, "http connection timed-out on " & url
    ElseIf http.status <> 200 Then
        msg = "could not download installer (hostb); http status error"
        If Len(trim$(http.statusText)) > 0 Then
            msg = msg & " (" & CStr(http.status) & ", " & http.statusText & ")"
        Else
            msg = msg & " (" & CStr(http.status) & ")"
        End If
        Err.Raise ErrorCode.HttpStatusNotOk, esource, msg
    Else
        Set ms = lateBoundADODBStream()
        ms.Open
        ms.Type = 1
        On Error Resume Next
        ms.Write http.responseBody
        If Err.Number <> 0 Then
            msg = "could not write " & HostbFileName & " to an ADODB.Stream (" & Err.Description & ")"
            On Error GoTo 0
            Err.Raise ErrorCode.HttpStreamToFileFailed, esource, msg
        Else
            On Error Resume Next
            ms.SaveToFile destinationFullPath, 2
            ms.Close
            If Err.Number <> 0 Then
                msg = "could not save " & HostbFileName & " to " & destinationFullPath & " (" & Err.Description & ")"
                On Error GoTo 0
                Err.Raise ErrorCode.HttpStreamToFileFailed, esource, msg
            End If
        End If
    End If
End Sub
Private Function keyValCollectionToArray2d(xs As Collection) As Variant
    Dim i   As Long
    Dim v() As Variant
    If xs Is Nothing Then
        keyValCollectionToArray2d = Empty
    ElseIf xs.Count = 0 Then
        keyValCollectionToArray2d = Empty
    Else
        ReDim v(0 To xs.Count - 1, 0 To 1)
        For i = 1 To xs.Count
            v(i - 1, 0) = xs.Item(i)(0)
            v(i - 1, 1) = xs.Item(i)(1)
        Next
        keyValCollectionToArray2d = v
    End If
End Function
Private Function diagnostics() As Collection
    Dim xs  As Collection
    Dim wb  As Workbook
    Dim i   As Long
    Dim r   As Range
    Dim v(0 To 4, 0 To 1) As String
    Set xs = New Collection
    xs.Add VBA.Array("Name", ThisWorkbook.Name)
    xs.Add VBA.Array("Path", ThisWorkbook.path)
    xs.Add VBA.Array("User Name", Environ$("username"))
    xs.Add VBA.Array("Excel Version", Application.Version)
    xs.Add VBA.Array("Excel Build", Application.build)
    #If Win64 Then
        xs.Add VBA.Array("OS", "Win64")
    #ElseIf Win32 Then
        xs.Add VBA.Array("OS", "Win32")
    #Else
        xs.Add VBA.Array("OS", CVErr(XlCVError.xlErrNA))
    #End If
    For Each r In kvGetKeysRange().Cells
        If r.Value2 Like "*.version" Then
            xs.Add VBA.Array(r.Value2, r.Offset(, 1).Value2)
        End If
    Next
    On Error Resume Next
    Set wb = Application.Workbooks(HostbFileName)
    On Error GoTo 0
    If Not wb Is Nothing Then
        xs.Add VBA.Array("Hostb open at", wb.FullName)
    Else
        xs.Add VBA.Array("Hostb open at", CVErr(XlCVError.xlErrNA))
    End If
    v(0, 0) = "Scripting.Dictionary"
    v(1, 0) = "Scripting.FileSystemObject"
    v(2, 0) = "ADODB.Stream"
    v(3, 0) = "MSXML2.XMLHTTP"
    v(4, 0) = "MSXML2.DOMDocument"
    On Error Resume Next
    v(0, 1) = TypeName(lateBoundDictionary())
    v(1, 1) = TypeName(lateBoundFileSystemObject())
    v(2, 1) = TypeName(lateBoundADODBStream())
    v(3, 1) = TypeName(lateBoundHttp())
    v(4, 1) = TypeName(lateBoundXml())
    On Error GoTo 0
    For i = LBound(v, 1) To UBound(v, 1)
        If Not IsEmpty(v(i, 1)) Then
            xs.Add VBA.Array(v(i, 0), "ok")
        Else
            xs.Add VBA.Array(v(i, 0), CVErr(XlCVError.xlErrRef))
        End If
    Next
    xs.Add VBA.Array("AppNamespace", AppNamespace)
    xs.Add VBA.Array("AppDisplayName", AppDisplayName)
    xs.Add VBA.Array("AppMsgBoxTitle", appMsgBoxTitle)
    xs.Add VBA.Array("AppFldPth", AppFldPth)
    xs.Add VBA.Array("meta_.hostb_urls", meta_.hostb_urls)
    xs.Add VBA.Array("meta_.app_display_name", meta_.app_display_name)
    xs.Add VBA.Array("meta_.help_url", meta_.help_url)
    xs.Add VBA.Array("meta_.help_email", meta_.help_email)
    xs.Add VBA.Array("meta_.copyright", meta_.cr)
    xs.Add VBA.Array("meta_.version (hosta)", meta_.ver)
    xs.Add VBA.Array("meta_.code_md5", meta_.code_md5)
    xs.Add VBA.Array("meta_.user_id", meta_.user_id)
    xs.Add VBA.Array("meta_.publish_time", meta_.publish_time)
    xs.Add VBA.Array("meta_.id", meta_.id)
    xs.Add VBA.Array("meta_.raw_xml", meta_.raw_xml)
    Set diagnostics = xs
End Function
Private Sub showDiagnostics()
    Dim xs      As Collection
    Dim r       As Range
    Dim msg     As String
    Dim esource As String
    On Error GoTo eh
    esource = ThisWorkbook.Name & "!showDiagnostics"
    Set xs = diagnostics()
    If xs Is Nothing Then
        Err.Raise ErrorCode.DiagnosticsFailed, esource, "unable to show diagnostic information"
    ElseIf xs.Count = 0 Then
        Err.Raise ErrorCode.DiagnosticsFailed, esource, "unable to show diagnostic information"
    Else
        With newWb().Worksheets(1).Range("a1")
            With .Resize(xs.Count, 2)
                .Value = keyValCollectionToArray2d(xs)
                With .EntireColumn
                    .AutoFit
                    .HorizontalAlignment = xlLeft
                    .WrapText = False
                    For Each r In .Columns
                        If r.ColumnWidth > 125 Then
                            r.ColumnWidth = 125
                        End If
                    Next
                End With
            End With
        End With
    End If
   Exit Sub
eh:
    Select Case Err.Number
        Case ErrorCode.[_Fst] To ErrorCode.[_Lst]
            msg = "Error: [" & Err.Number - vbObjectError & "]  " & Err.Description & vbCrLf
            msg = msg & "Source: " & Err.source
        Case Else
            msg = "Diagnostic information is not available" & vbCrLf
            msg = msg & "Error: [" & Err.Number & "]  " & Err.Description
    End Select
    logErro msg
    alert msg, vbExclamation
End Sub
Private Sub showAbout()
    Const MSG_BOX_MAX_LENGTH As Long = 1023
    Dim xs      As Collection
    Dim msg     As String
    Dim s       As String
    Dim x       As Variant
    Dim prompt  As String
    Dim esource As String
    Dim r       As Range
    esource = ThisWorkbook.Name & "!showAbout"
    On Error GoTo eh
    Set xs = New Collection
    xs.Add VBA.Array("File name", ThisWorkbook.Name)
    xs.Add VBA.Array("Path", ThisWorkbook.path)
    For Each r In kvGetKeysRange().Cells
        If r.Value2 Like "*.version" Then
            xs.Add VBA.Array(r.Value2, r.Offset(, 1).Value2)
        End If
    Next
    If Len(AppMeta.id) > 0 Then
        xs.Add VBA.Array("Add-in id", AppMeta.id)
    End If
    If Len(AppMeta.user_id) > 0 Then
        xs.Add VBA.Array("User id", AppMeta.user_id)
    End If
    If Len(Environ$("username")) > 0 Then
        xs.Add VBA.Array("User name", Environ$("username"))
    End If
    If Len(AppMeta.help_email) > 0 Then
        xs.Add VBA.Array("Support email", AppMeta.help_email)
    End If
    If Len(AppMeta.help_url) > 0 Then
        xs.Add VBA.Array("Help/docs link", AppMeta.help_url)
    End If
    prompt = vbCrLf & vbCrLf & "Press 'Yes' to copy this info (and additional diagnostics) to a new workbook."
    For Each x In xs
        s = x(0) & ": " & trim$(x(1)) & vbCrLf
        If Len(s) + Len(prompt) + Len(msg) < MSG_BOX_MAX_LENGTH Then
            msg = msg & s
        End If
    Next
    If Len(AppMeta.cr) > 0 Then
        If Len(AppMeta.cr) + Len(prompt) + Len(msg) + Len(vbCrLf) < MSG_BOX_MAX_LENGTH Then
            msg = msg & vbCrLf & AppMeta.cr
        End If
    End If
    msg = msg & prompt
    If alert(msg, vbYesNoCancel + vbDefaultButton2 + vbInformation) = VbMsgBoxResult.vbYes Then
        showDiagnostics
    End If
    Exit Sub
eh:
    Select Case Err.Number
        Case ErrorCode.[_Fst] To ErrorCode.[_Lst]
            msg = "Error: [" & Err.Number - vbObjectError & "]  " & Err.Description & vbCrLf
            msg = msg & "Source: " & esource
        Case Else
            msg = "About information is not available" & vbCrLf
            msg = msg & "Error: [" & Err.Number & "]  " & Err.Description
    End Select
    logErro msg
    alert msg, vbExclamation
End Sub
Private Sub viewLog()
    Dim sh      As Worksheet
    Dim rSource As Range
    Dim r       As Range
    On Error GoTo eh
    Set sh = ThisWorkbook.Worksheets(SH_IDX_LOG)
    If IsEmpty(sh.Range("a2").Value) Then
        alert "The log is empty.", vbInformation
        Exit Sub
    End If
    Set rSource = sh.Range(sh.Range("a1"), sh.Cells(sh.Range("a1").End(xlDown).Row, sh.Range("a1").End(xlToRight).Column))
    With newWb().Worksheets(1).Range(rSource.Cells(1, 1).Address)
        With .Range(rSource.Address)
            .Value = rSource.Value
            .Columns.AutoFit
            For Each r In .Columns
                If r.ColumnWidth > 125 Then
                    r.ColumnWidth = 125
                End If
            Next
            If rSource.Rows.Count > 1 Then
                For Each r In rSource.Rows(2).Cells
                    .Columns(r.Column).NumberFormat = r.NumberFormat
                Next
                For Each r In .Columns(LOG_COL_LEVEL).Cells
                    Select Case r.Value
                        Case "FATL", "ERRO", "WARN"
                            r.Interior.ColorIndex = Switch(r.Value = "FATL", 3, r.Value = "ERRO", 45, r.Value = "WARN", 6)
                            r.Borders.Value = 1
                            r.Borders.ColorIndex = 15
                    End Select
                Next
            End If
        End With
    End With
    Exit Sub
eh:
    alert "the log is not available" & vbCrLf & "Error: [" & Err.Number & "]  " & Err.Description, vbExclamation
End Sub
Private Sub showInstallUpdateError()
    Dim msg         As String
    Dim errorNumber As Long
    Dim r           As Range
    clearStatus
    Select Case Err.Number
        Case ErrorCode.[_Fst] To ErrorCode.[_Lst]
            errorNumber = Err.Number - vbObjectError
            msg = "Error: [" & errorNumber & "]  " & Err.Description & vbCrLf
            msg = msg & "Source: " & Err.source
        Case 0
            msg = "Error: [" & ErrorCode.Unidentified - vbObjectError & "] control flow error"
        Case Else
            msg = "Error: [" & Err.Number & "]  " & Err.Description
    End Select
    msg = "The " & AppDisplayName & " add-in could not load required components." & vbCrLf & vbCrLf & msg
    logFatl msg
    msg = msg & vbCrLf & vbCrLf & "Press 'Yes' to show an error log."
    If alert(msg, vbExclamation + vbYesNoCancel) = vbYes Then
        viewLog
    End If
End Sub
Private Sub logDiagnostics()
    Dim kv As Variant
    Dim xs As Collection
    Set xs = diagnostics()
    If Not xs Is Nothing Then
        If xs.Count > 0 Then
            For Each kv In xs
                logInfo "diagnostics: " & CStr(kv(0)) & " = " & CStr(kv(1))
            Next
            Exit Sub
        End If
    End If
    logWarn "there are no diagnostics"
End Sub
Private Sub checkForUpdates(ByVal typeOfUpdate As UpdateType)
    Dim wbHostB             As Workbook
    Dim fso                 As Object
    Dim tmpHostbBinFld      As String
    Dim msg                 As String
    Dim esource             As String
    Dim hostBTempFullName   As String
    Dim url                 As Variant
    Dim urls                As Variant
    Dim isNewlyDownloaded   As Boolean
    Dim lastErrNum          As Long
    Dim lastErrMsg          As String
    esource = ThisWorkbook.Name & "!checkForUpdates"
    On Error GoTo eh
    Application.Cursor = XlMousePointer.xlWait
    writeStatus "checking for host(b)"
    logDbug "entry of " & esource & " with updateType = " & updateTypeToString(typeOfUpdate)
    logDiagnostics
    kvPutValue "hosta.version", AppMeta.ver
    On Error Resume Next
    Set wbHostB = Application.Workbooks(HostbFileName)
    On Error GoTo eh
    If Not wbHostB Is Nothing Then
        If wbHostB.CustomXMLParts.SelectByNamespace("urn:optimalxl.com/hostb").Count = 0 Then
            logWarn "forcibly closing open and invalid hostb here: " & wbHostB.FullName
            wbHostB.Close False
            Set wbHostB = Nothing
        Else
            logDbug "hostb is open here, " & abrvPath(wbHostB.FullName)
            logDbug "calling " & HostbInitMacro & " with isNewlyDownloaded = False"
            clearStatus
            Application.Run HostbInitMacro, ThisWorkbook.FullName, False, CLng(typeOfUpdate)
            Exit Sub
        End If
    End If
    writeStatus "creating temp folder for host(b)"
    logDbug "creating a new hostb temp folder"
    tmpHostbBinFld = createNewTmpFldForHostb()
    logDbug "created new hostb temp folder: " & abrvPath(tmpHostbBinFld)
    Set fso = lateBoundFileSystemObject()
    hostBTempFullName = fso.BuildPath(tmpHostbBinFld, HostbFileName)
    If fso.FileExists(AppBinHostbFullName) Then
        writeStatus "copying host(b) to run location"
        logDbug "hostb has already been installed at : " & abrvPath(AppBinHostbFullName)
        On Error Resume Next
        fso.CopyFile AppBinHostbFullName, hostBTempFullName, True
        If Err.Number <> 0 Then
            msg = "could not copy " & abrvPath(AppBinHostbFullName) & " to " & abrvPath(hostBTempFullName) & " (" & Err.Description & ")"
            On Error GoTo eh
            Err.Raise ErrorCode.HostBCopyInstallToTmpFailed, esource, msg
        Else
            On Error GoTo eh
        End If
        logDbug "hostb file copied to here: " & abrvPath(hostBTempFullName)
        writeStatus "opening host(b)"
        logDbug "opening hostb workbook at " & abrvPath(hostBTempFullName)
        On Error Resume Next
        Set wbHostB = Application.Workbooks.Open(hostBTempFullName)
        If Err.Number <> 0 Then
            lastErrMsg = Err.Description
            lastErrNum = Err.Number
            On Error GoTo eh
            Set wbHostB = Nothing
            logErro "hostb workbook exists but could not be opened. Had this error: " & lastErrNum & "; " & lastErrMsg
        Else
            On Error GoTo eh
        End If
    End If
    If wbHostB Is Nothing Then
        isNewlyDownloaded = True
        logDbug "hostb has not been installed yet (or is corrupted) / bin folder is empty: " & AppBinHostbFldPth
        logDbug "prompting user to ok install"
        msg = "Optimal(xl) will now download supporting files to:"
        msg = msg & vbCrLf & vbCrLf & AppFldPth
        msg = msg & vbCrLf & vbCrLf & "This typically takes less than 10 seconds."
        msg = msg & vbCrLf & vbCrLf & "A message box will alert you when we're done."
        msg = msg & vbCrLf & vbCrLf & "See the green status bar in the bottom left of your Excel window to view progress."
        msg = msg & vbCrLf & vbCrLf & "Continue?"
        If alert(msg, vbOKCancel + vbDefaultButton1 + vbQuestion) = VbMsgBoxResult.vbCancel Then
            logDbug "user canceled install"
            clearStatus
            Exit Sub
        End If
        writeStatus "downloading host(b)"
        If Not fso.FolderExists(AppBinHostbFldPth) Then
            logDbug "creating hostb install bin folder: " & abrvPath(AppBinHostbFldPth)
            folderCreateRecursive AppBinHostbFldPth
        End If
        If Len(AppMeta.hostb_urls) = 0 Then
            Err.Raise ErrorCode.HttpUrlIsEmpty, , "meta data for host(b) urls is missing"
        Else
            urls = Split(AppMeta.hostb_urls, "|")
            If UBound(urls) = -1 Then
                Err.Raise ErrorCode.HttpUrlIsEmpty, , "meta data for host(b) urls is empty"
            End If
        End If
        For Each url In urls
            logDbug "hostb being downloaded; base url = " & url & "; to file location = " & abrvPath(hostBTempFullName)
            On Error Resume Next
            downloadHostB CStr(url), hostBTempFullName
            If Err.Number <> 0 Then
                lastErrMsg = Err.Description
                lastErrNum = Err.Number
                On Error GoTo eh
                logWarn "hostb url, " & url & ", did not work, error: " & lastErrNum & "; " & lastErrMsg
            Else
                On Error GoTo eh
                writeStatus "copying host(b) to install location"
                logDbug "copying downloaded hostb (" & abrvPath(hostBTempFullName) & ") to install folder (" & abrvPath(AppBinHostbFullName) & ")"
                On Error Resume Next
                fso.CopyFile hostBTempFullName, AppBinHostbFullName, True
                If Err.Number <> 0 Then
                    lastErrMsg = Err.Description
                    lastErrNum = Err.Number
                    On Error GoTo eh
                    msg = "could not copy " & abrvPath(hostBTempFullName) & " to " & abrvPath(AppBinHostbFullName) & " (" & lastErrMsg & ")"
                    Err.Raise ErrorCode.HostBCopyTmpToInstallFailed, esource, msg
                Else
                    On Error GoTo eh
                    writeStatus "opening host(b)"
                    logDbug "opening hostb workbook at " & abrvPath(hostBTempFullName)
                    On Error Resume Next
                    Set wbHostB = Application.Workbooks.Open(hostBTempFullName)
                    If Err.Number <> 0 Then
                        lastErrMsg = Err.Description
                        lastErrNum = Err.Number
                        On Error GoTo eh
                        logWarn "url download worked, but could not open hostb xlam file: " & lastErrMsg
                    Else
                        On Error GoTo eh
                        Exit For
                    End If
                End If
            End If
        Next
        If wbHostB Is Nothing Then
            logDbug "raising error from the last hostb url tried. All urls threw (not necessarily the same error)."
            If lastErrNum <> 0 And Len(lastErrMsg) > 0 Then
                Err.Raise lastErrNum, esource, lastErrMsg
            Else
                Err.Raise ErrorCode.HostBDownloadOrOpenFailed, esource, "the host(b) xlam file could not be downloaded / opened"
            End If
        End If
    End If
    logDbug "opened hostb from here, " & abrvPath(wbHostB.FullName)
    logDbug "calling " & HostbInitMacro & " with wasHostbFreshlyDownloded = " & CStr(isNewlyDownloaded)
    clearStatus
    Application.Run HostbInitMacro, ThisWorkbook.FullName, isNewlyDownloaded, CLng(typeOfUpdate)
    Exit Sub
eh:
    showInstallUpdateError
End Sub
Public Sub trampoline(ByVal workbookFullName As String, macroName As String, ParamArray args() As Variant)
    Dim wb      As Workbook
    Dim s       As String
    Dim esource As String
    Dim msg     As String
    esource = ThisWorkbook.Name & "!trampoline"
    logDbug esource & " for " & workbookFullName & "!" & macroName
    On Error Resume Next
    Set wb = Application.Workbooks.Open(workbookFullName)
    On Error GoTo eh
    If wb Is Nothing Then
        Err.Raise ErrorCode.TrampolineBookOpenFailed, esource, "trampoline failed, could not open " & workbookFullName
    End If
    s = "'" & wb.Name & "'!" & macroName
    On Error GoTo 0
    Select Case UBound(args)
        Case -1: Application.Run s
        Case 0: Application.Run s, args(0)
        Case 1: Application.Run s, args(0), args(1)
        Case 2: Application.Run s, args(0), args(1), args(2)
        Case 3: Application.Run s, args(0), args(1), args(2), args(3)
        Case 4: Application.Run s, args(0), args(1), args(2), args(3), args(4)
        Case 5: Application.Run s, args(0), args(1), args(2), args(3), args(4), args(5)
        Case 6: Application.Run s, args(0), args(1), args(2), args(3), args(4), args(5), args(6)
        Case 7: Application.Run s, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7)
        Case Else
            On Error GoTo eh
            Err.Raise ErrorCode.TrampolineTooManyArgs, esource, "trampoline supports a maximum of 8 parameters"
    End Select
    Exit Sub
eh:
    showInstallUpdateError
End Sub
Public Sub oxlOnInstalled()
    installInProcess_ = True
End Sub
Public Sub oxlOnOpen()
    If meta_.is_init Then
        logWarn "at 'oxlOnOpen', 'meta_.is_init' is already true"
        Exit Sub
    End If
    If LCase$(Right$(ThisWorkbook.Name, 5)) <> ".xlam" Then
        Exit Sub
    End If
    On Error GoTo eh
    logDbug "********** HOSTA onOpen **********"
    If ThisWorkbook.Worksheets.Count < 2 Then
        ThisWorkbook.Worksheets.Add
    End If
    If installInProcess_ Then
        updateType_ = UpdateType.Installed
        checkForUpdates UpdateType.Installed
    Else
        updateType_ = UpdateType.Opened
        checkForUpdates UpdateType.Opened
    End If
    Exit Sub
eh:
    showInstallUpdateError
End Sub
Public Sub roa_a(ctrl As IRibbonControl)
    If Len(ctrl.tag) > 0 Then
        logDbug "ribbon event, hosta ribbonOnActionHandler with id = '" & ctrl.id & "' and tag = '" & ctrl.tag & "'"
    Else
        logDbug "ribbon event, hosta ribbonOnActionHandler with id = '" & ctrl.id & "'"
    End If
    Select Case LCase$(ctrl.id)
        Case "oxl.installer.hosta.view_log"
            viewLog
        Case "oxl.installer.hosta.about"
            showAbout
        Case "oxl.installer.hosta.view_diagnostics"
            showDiagnostics
        Case "oxl.installer.hosta.check_for_updates"
            checkForUpdates UpdateType.Requested
        Case Else
            alert "The hosta menu control '" & ctrl.id & "' has no action associated with it.", vbExclamation
    End Select
End Sub
Public Sub oxlOnClose()
    Dim wbHostB As Workbook
    On Error Resume Next
    Set wbHostB = Application.Workbooks(HostbFileName)
    On Error GoTo eh
    If Not wbHostB Is Nothing Then
        wbHostB.Close False
    End If
eh:
End Sub
Public Sub Auto_Open()
    If meta_.is_init Then
        Exit Sub
    ElseIf LCase$(Right$(ThisWorkbook.Name, 5)) <> ".xlam" Then
        Exit Sub
    Else
        logDbug "Workbook_Open event did not fire, falling back to Auto_Open"
        oxlOnOpen
    End If
End Sub
Public Sub Auto_Close()
    oxlOnClose
End Sub
#ElseIf Mac Then
Public Sub oxlOnOpen()
    MsgBox "The " & ThisWorkbook.Name & " add-in requires Windows-based Excel", vbInformation, ThisWorkbook.Name
End Sub
Public Sub oxlOnInstalled()
End Sub
Public Sub oxlOnClose()
End Sub
#Else
Public Sub oxlOnOpen()
    MsgBox "The " & ThisWorkbook.Name & " add-in requires Excel 2010 or later", vbInformation, ThisWorkbook.Name
End Sub
Public Sub oxlOnInstalled()
End Sub
Public Sub oxlOnClose()
End Sub
#End If