Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
       Private Sub Workbook_Open()
           Run "StartUp"
       End Sub

Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim wm As Worksheet, rRow As Integer, rangeS As String, rangeE As String
    If Target.Address = Cells(1, FirstOutput).Address Then
        If MsgBox("Clear results?", vbYesNo, AppName) = vbYes Then
            Set wm = ActiveWorkbook.Sheets("Macro")
            rangeS = wm.Cells(2, FirstOutput).Address
            rangeE = wm.Cells(wm.UsedRange.Rows.Count, LastOutput).Address
            Range(rangeS & ":" & rangeE).Select
            Selection.ClearContents
            Range(Target.Address).Select
        End If
        Cancel = True
        Exit Sub
    End If
End Sub


Attribute VB_Name = "Sheet8"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet4"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "SelectivePurge"
Global Const VERSION As Double = "11.0215"
Global Const MACRO_NAME As String = "Selective Purge"
Global Const GUI_NAME As String = "signon_b2"
Global Const FirstOutput As Integer = 6 'first output column
Global Const LastOutput As Integer = 8 'last output column

Public Sub RunExtraSteps(hookLocation As String)
    On Error GoTo gotError
    Select Case hookLocation
        Case "BeforeGUI":
        Case "BeforeProcessLine":
        Case "AfterProcessLine":
        Case "AfterAllLines":
            B2LogOut
            If IeState <> -1 Then IE.Quit
            Set IE = Nothing
        Case "BeforeSave":
        Case "AfterSave":
        Case "BeforeError":
        Case "AfterError":
    End Select
    Exit Sub
gotError:
    Select Case Err.Number
       Case 0:
            MsgBox Err.Description, vbCritical, AppName
            Err.Raise ErrorNum.Critical, "", Err.Description
    End Select
End Sub

Public Function ExtraConfirm(rownum As Long, hookLocation As String)
    ExtraConfirm = True
    Select Case hookLocation
        Case "ProcessLine":
            If LCase(Cells(rownum, FirstOutput).value) = "success" Then ExtraConfirm = False
    End Select
End Function

Public Sub ProcessLine(rownum As Long)
    On Error GoTo gotError
    Dim user, pwd As String, runMode As String, hostHome As String, boid As String, isB2Visible As Boolean, database As String
    Dim sccf As String, msgID As String, formatType As String, msgStatus As String, comments As String, purgeType As String, datePosted As Date
    Dim realRow As Integer, onRow As Integer
    database = "Local"
    With GUI
        user = .username
        pwd = .password
        runMode = .runMode
        hostHome = .hostHome
        boid = .boid
    End With
    isB2Visible = False
    If runMode = "Blue2 Visible" Then isB2Visible = True
    msgID = ""
    sccf = Cells(rownum, 1).Formula
    datePosted = CDate(Nz(Cells(rownum, 2), 0))
    formatType = UCase(Cells(rownum, 3).value)
    purgeType = Cells(rownum, 4).value
    purgeType = "Physical"
    comments = StripInvalidChars(Trim(Cells(rownum, 5).value))
    
    Select Case Len(sccf)
        Case 32
            msgID = sccf
            sccf = ""
        Case 0
            Exit Sub
        Case 15
            sccf = sccf & "00"
    End Select
    If formatType = "" Or purgeType = "" Or comments = "" Then Err.Raise IIf(rownum < 4, ErrorNum.Critical, ErrorNum.Noncritical), , "Missing required data."
    'load B2
    LoadBlue2 user, pwd, boid, database, hostHome, isB2Visible, , , , , "selectivePurgeSubmitButton"
    B2SelectivePurge hostHome
    If sccf = "" Then
        IePutString "messageId", msgID
        ieScript "processMessageCriteriaForm('" & msgID & "');"
    Else
        IePutString "sccf", sccf
        ieScript "processSccfCriteriaForm('" & sccf & "');"
    End If
    'IePutString "__multiselect_messageType", formatType
    'IePutString "messageType", formatType
    setInventoryLimit formatType, "messageType"
    IeDoAction "selectivePurgeSearchBtn", Click
    IsB2FinishedLoading 120
    Output rownum, "Not Found", ""
    If ieWait(Trim(msgID & sccf), 2, "searchResults") = False Then
        If IeGetString("errortext_0", innertext) <> "" Then Err.Raise ErrorNum.Noncritical, , IeGetString("errortext_0", innertext)
        Err.Raise ErrorNum.Noncritical, , "Timeout waiting for search results"
    End If
'Looping Through Results
    onRow = 0
    For realRow = 0 To GetTotalRows - 1
        If onRow > 25 Then
            onRow = 0
            ieScript ("document.getElementById('queryResults').childNodes[0].childNodes[1].childNodes[3].click()")
            Sleep 1000
            IsIeFinishedLoading 120
        End If
        If UCase(SearchResult(onRow, formatColumn)) = UCase(formatType) Then
            If UCase(SearchResult(onRow, msgStatusColumn)) = "TERM" Then
                If CDate(SearchResult(onRow, msgDateColumn)) = datePosted Or datePosted = 0 Then
                    IE.Document.getElementById("tr.summary." & onRow).Children(1).Children(0).Checked = True
                End If
            End If
        End If
CountReturn:
        onRow = onRow + 1
    Next
    IePutString "commentsInp", comments
    ieScript "getContactDetails();"
    If ieWait("*?", 5, "userPhoneInp") = False Then ieScript ""
    If ieWait("*?", 115, "userPhoneInp") = False Then Err.Raise ErrorNum.Noncritical, , "Timed out waiting for Get Contact button"
    IeDoAction "selectivePurgeSubmitButton", Click
    'after Submit button
    IsB2FinishedLoading
    ieWait "Selected records have been successfully submitted for selective purge", 1.5
    If IeGetString("errortext_0", innertext) <> "" Then Err.Raise ErrorNum.Noncritical, , IeGetString("errortext_0", innertext)
    If ieWait("Selected records have been successfully submitted for selective purge", 5) Then
        Output rownum, "Success", Trim(Replace(IeGetString("successMsgDiv", innertext), vbNewLine, ""))
    Else
        Err.Raise ErrorNum.Noncritical, , "Message Submitted, but cannot be confirmed"
    End If
    Exit Sub
gotError:
    Dim ErrDesc As String, ErrNum As Integer
    ErrDesc = Err.Description
    ErrNum = Err.Number
    Select Case ErrNum
        Case ErrorNum.Critical:
            B2LogOut
            Err.Raise ErrNum, , ErrDesc
        Case ErrorNum.Noncritical:
            Output rownum, "Error", ErrDesc
        Case Else
            MsgBox ErrDesc, vbCritical, "Error (" & ErrNum & ")"
            If MsgBox("Continue to run " & MACRO_NAME & "?", vbYesNo, "Unknown Error") = vbYes Then
                Output rownum, "Error", ErrDesc
            Else
                Err.Raise ErrorNum.Silent, , ErrDesc
            End If
    End Select
End Sub

Attribute VB_Name = "Excel_Functions"
'+----------------------------------------------------------------------------+
'|                             [Excel Functions]
'|                    Basic functions for Excel based macros
'|          Requires: "Microsoft Visual Basic for Applications Extensibility", C:\Windows\SysWOW64\FM20.dll
'|
'|  2/1     Added DeleteSheet and Updated VerifySheetExists to allow specific workbook
'|  2/1/21  Added FM20.dll requirement, updated StatBar
'|  11/13   Updated ExportSheet to use Settings
'|  10/21   Bug fix in GetTable()
'|  10/7    Updated GetSetting and PutSetting to use GetTable & optional Workbook parameter
'|  10/6    Added GetTable() to search for table name in all sheets
'|  9/10    Updates for 64bit
'|  8/4     Updated RegExMatch to handle capture groups
'|  7/24    Added RegExMatch()
'|  4/3     Added GetSetting() & PutSetting()
'|  2/25    Added SmartCInt, SmartCLng
'|  1/24    Added VLookup to simplify using vlookup.
'|  1/2/20  Removed CountLeft(), NextCell(). Added CopyToClipboard().
'|  12/31   Moved SetListBoxValue(),SetListBoxAllNone(),& GetControlValue() here from Excel_Functions.
'|  5/29/19 Added AddReference() and DownloadURL().
'|  12/11   Added CountInStr() to count needles in a haystack.
'|  5/29    Added Clean() a clone of Excel's Clean() function.
'|  5/15    Added SmartCDate().
'|  5/4     Updated SetListBoxValue() to ignore empy values.
'|  5/3     Added Nz(),GetControlValue(),SetListBoxAllNone(),SetListBoxValue().
'|  4/19    Added AppName - needs global const "MACRO_NAME" and "VERSION".
'|  4/12    Added GUI to call the userform. (Use GUI_NAME as global const to set name).
'|  4/12/18 Removed URLDownloadToFile. Cleaned up code.
'|  3/30/16 Added header items to make functions work without other modules.
'|  5/5     Added: FileOrDirExists() & ShowFileDialog.
'|  5/4     Added: VerifySheetExists(sheetName) to verify/create sheet.
'|  1/9/15  Status() sends full text to form.
'|  6/19/14 Updated Status() to work with signon or signon_match.
'|  9/13    Updated SaveFile() to use Status().
'|  8/21    Added: Status, countLeft, statBar, nextCell, saveFile.
'|
'+----------------------------------------------------------------------------+

Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Declare PtrSafe Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
Public Declare PtrSafe Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Public Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
 
Public Type tagOPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    strFilter As String
    strCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    strFile As String
    nMaxFile As Long
    strFileTitle As String
    nMaxFileTitle As Long
    strInitialDir As String
    strTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    strDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Function Status(StatusText As String)
    On Error Resume Next
    Dim appStatusText As String
    appStatusText = StatusText
    If InStr(StatusText, AppName) = 0 Then appStatusText = AppName & IIf(AppName = "", "", " - ") & StatusText
    If StatusText = "" Then
        GUI.StatusBar.value = ""
        Application.StatusBar = False
    Else
        GUI.StatusBar.value = StatusText
        GUI.Repaint
        Application.StatusBar = appStatusText
    End If
    Status = True
End Function

Public Function statBar(percent As Double, Optional size As Integer = 40) As String
'Returns a text status/progress bar with percent complete in the middle
    Dim leftPart As String, rightPart As String, spacePart As String, activePart As String
    Dim leftSpace As Integer, rightSpace As Integer, i As Integer
    leftPart = "(."
    rightPart = ".)"
    spacePart = ".."
    activePart = "[" & Format(percent * 100, "00.00") & "%]"
    
    leftSpace = Round(percent * size, 0)
    rightSpace = size - 1 - leftSpace
    statBar = leftPart
    For i = 1 To leftSpace
        statBar = statBar & spacePart
    Next
    statBar = statBar & activePart
    For i = 1 To rightSpace
        statBar = statBar & spacePart
    Next
    statBar = statBar & rightPart
End Function


Function saveFile()
On Error GoTo gotError
    Dim PrevStatus As String
    PrevStatus = Application.StatusBar
    Status ("Saving....")
    ActiveWorkbook.Save
    Status ("Saved!")
    Sleep 1000
    Status (PrevStatus)
    saveFile = True
    Exit Function
gotError:
    saveFile = False
    Status ("Failed to Save File!")
End Function



Public Function VerifySheetExists(sheetName As String, Optional createIfNeeded As Boolean = True, Optional workbookObj As Excel.Workbook) As Boolean
    If workbookObj Is Nothing Then Set workbookObj = ActiveWorkbook
    Dim currentSheet As Integer
    VerifySheetExists = False
    For i = 1 To workbookObj.Sheets.Count
        If workbookObj.Sheets(i).Name = sheetName Then VerifySheetExists = True
    Next
    If VerifySheetExists = False And createIfNeeded = True Then
        With workbookObj
            currentSheet = .ActiveSheet.Index
            Dim nws As Worksheet
            Set nws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            nws.Name = sheetName
            VerifySheetExists = True
            .Sheets(currentSheet).Activate
        End With
    End If
    Exit Function
gotError:
    VerifySheetExists = False
End Function


Function ShowFileDialog(ByVal SaveFileDialog As Boolean, strFilter As String, strTitle As String, ByVal strInitialDirec As String, Optional defaultFileName)
'Pass in a boolean indicating whether this is a SaveFileDialog. If false, it will be an open fileEDialog.
' Sample filter string - this one for excel files (the Chr(0) functions like the vertical bar in VB.Net filters).
'-- Dim filter As String
'-- filter = "Excel files(*.xlsx)" & Chr(0) & "*.xlsx" & Chr(0) & "All Files (*.*)" & Chr(0) & "*.*"
    On Error GoTo gotError
    Dim OFN As tagOPENFILENAME
    Dim strFileName As String, strFileTitle As String
    If IsMissing(defaultFileName) = False Then strFileName = defaultFileName
    strFileName = VBA.Left(strFileName & String(256, 0), 256)
    strFileTitle = String(256, 0)
    With OFN
        .lStructSize = Len(OFN)
        '.hwndOwner = Application.hWndAccessApp
        .strFilter = strFilter
        .nFilterIndex = 0
        .strFile = VBA.Left(strFileName & String(256, 0), 256)
        .nMaxFile = VBA.Len(strFileName)
        .strFileTitle = String(256, 0)
        .nMaxFileTitle = VBA.Len(strFileTitle)
        .strTitle = strTitle
        .Flags = 0
        .strDefExt = ""
        .strInitialDir = strInitialDirec
        .strCustomFilter = ""
        .nMaxCustFilter = 0
        .lpfnHook = 0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
    End With
    If SaveFileDialog Then aht_apiGetSaveFileName OFN Else aht_apiGetOpenFileName OFN
    'The string returned is 256 chars long, ending in nulls. Remove the nulls.
    ShowFileDialog = OFN.strFile
    If VBA.Len(OFN.strFile & "") = 0 Then Exit Function
    Dim i As Long
    For i = VBA.Len(OFN.strFile) To 1 Step -1
        If VBA.Mid(OFN.strFile, i, 1) <> Constants.vbNullChar Then Exit For
    Next i
    ShowFileDialog = VBA.Mid(OFN.strFile, 1, i)
    Exit Function
gotError:
    ShowFileDialog = False
End Function

Function FileOrDirExists(PathName As String) As Boolean
'Function returns TRUE if the specified file or folder exists, false if not.
    Dim iTemp As Integer
    On Error Resume Next
    iTemp = GetAttr(PathName)
    'Check if error exists and set response appropriately
    Select Case Err.Number
    Case Is = 0
        FileOrDirExists = True
    Case Else
        FileOrDirExists = False
    End Select
End Function

Public Function ExportSheet(Optional sheetName As String) As Boolean
    ExportSheet = False
    Dim filename As String, filter As String, lastFileNameArray() As String
    Dim ws As Worksheet, newWorkbook As Workbook
    Dim lastFileName As String, newSheetName As String
    Dim lastFileDir As String, lastFileNamePart As String
    newSheetName = GetSetting("ExportSheet")
    lastFileName = GetSetting("ExportPath")
    If lastFileName <> "" Then
        lastFileName = StrReverse(lastFileName)
        lastFileNameArray = Split(lastFileName, "\", 2)
        lastFileNamePart = StrReverse(lastFileNameArray(0))
        lastFileDir = StrReverse(lastFileNameArray(1))
    End If
'get File Name
    filter = "Excel files(*.xlsx)" & Chr(0) & "*.xlsx" & Chr(0) & "All Files (*.*)" & Chr(0) & "*.*"
    filename = ShowFileDialog(True, filter, "Export File Name", lastFileDir, lastFileNamePart)
    If InStr(filename, "\") = 0 Then
        MsgBox "Export Canceled!", vbInformation, "Export Sheet"
        Exit Function
    End If
    If newSheetName = "" Then newSheetName = sheetName
    newSheetName = InputBox("New Worksheet (tab) Name." & vbNewLine & "Press Cancel to keep original.", "Export Sheet", newSheetName)
    If newSheetName = "" Then newSheetName = sheetName
    PutSetting "ExportSheet", newSheetName
    PutSetting "ExportPath", filename
'make new file
    Set ws = ActiveWorkbook.Sheets(sheetName)
    Set newWorkbook = Workbooks.Add
'copy sheet & save
    ws.Copy Before:=newWorkbook.Sheets(1)
    newWorkbook.Sheets(sheetName).Name = newSheetName
    newWorkbook.SaveAs filename
    ExportSheet = True
End Function

Public Function CopyFile(oldPathAndFile As String, newPathAndFile As String, Optional openOldPath As Boolean = False) As Boolean
    'Copies file from one location to another
    On Error GoTo gotError
    Dim oldPath As String
    oldPath = StrReverse(oldPathAndFile)
    If InStr(oldPath, "/") Then oldPath = Mid(oldPath, InStr(oldPath, "/") + 1)
    If InStr(oldPath, "\") Then oldPath = Mid(oldPath, InStr(oldPath, "\") + 1)
    oldPath = StrReverse(oldPath)
    CopyFile = False
    Dim fs As Object
    If openOldPath Then Shell "C:\WINDOWS\explorer.exe """ & oldPath & "", vbNormalFocus
    If FileOrDirExists(oldPathAndFile) = False Then
        MsgBox "Error! """ & oldPathAndFile & """ was not found", vbCritical, "Copying files.."
        Exit Function
    End If
    Set fs = CreateObject("Scripting.FileSystemObject")
    fs.CopyFile oldPathAndFile, newPathAndFile
    Set fs = Nothing
    CopyFile = True
    Exit Function
gotError:
    MsgBox "Failed copying " & oldPathAndFile & " to """ & newPathAndFile & """" & Chr(13) & Error
End Function

Public Sub KillProperly(fileToKill As String)
    If Len(Dir$(fileToKill)) > 0 Then
        SetAttr fileToKill, vbNormal
        Kill fileToKill
    End If
End Sub

Public Function AppName() As String
    AppName = MACRO_NAME & " " & VERSION
End Function

Public Function GUI(Optional formName As String = "") As Object
    'lets you call the userform as "GUI.show". Should have GUI_NAME as Global Const
    Dim i As Integer, foundForm As Boolean
    If formName = "" Then formName = GUI_NAME
    If UserForms.Count = 0 Then
        CallByName UserForms, "Add", VbMethod, formName
        Set GUI = UserForms(0)
    Else
        For i = 0 To UserForms.Count - 1
            If UserForms(i).Name = formName Then
                Set GUI = UserForms(i)
                foundForm = True
                Exit For
            End If
        Next
        If foundForm = False Then
            CallByName UserForms, "Add", VbMethod, formName
            Set GUI = UserForms(UserForms.Count - 1)
        End If
    End If
End Function

Public Function Nz(ByVal theValue As Variant, Optional nullValue As String = "") As Variant
    If IsNull(theValue) Then
        Nz = nullValue
    Else
        Nz = theValue
    End If
End Function

Public Function SmartCDate(value As Variant, Optional valueOnError As Variant = Null) As Variant
'Like CDate, only returning either NULL or a specific date on error
    On Error GoTo gotError
    If value = "" Then GoTo gotError
    SmartCDate = CDate(value)
    Exit Function
gotError:
    SmartCDate = valueOnError
End Function

Public Function SmartCInt(value As Variant, Optional valueOnError As Variant = Null) As Variant
'Like CInt, only returning either NULL or a specific int on error
    On Error GoTo gotError
    If value = "" Then GoTo gotError
    SmartCInt = CInt(value)
    Exit Function
gotError:
    SmartCInt = valueOnError
End Function

Public Function SmartCLng(value As Variant, Optional valueOnError As Variant = Null) As Variant
'Like CLng, only returning either NULL or a specific Long on error
    On Error GoTo gotError
    If value = "" Then GoTo gotError
    SmartCLng = CLng(value)
    Exit Function
gotError:
    SmartCLng = valueOnError
End Function

Public Function Clean(stringValue As String) As String
    Clean = Application.WorksheetFunction.Clean(Trim(stringValue))
End Function

Public Function CountInStr(textString As String, subStringToFind As String) As Long
    CountInStr = 0
    On Error Resume Next
    CountInStr = UBound(Split(textString, subStringToFind))
End Function

Public Function AddReference(refUrl As String)
    On Error Resume Next
    Const LPATH As String = "C:\SS_Macro\"
    Dim refName As String
    Dim VBAEditor As VBIDE.VBE
    Dim vbProj As VBIDE.VBProject
    Dim chkRef As VBIDE.Reference
    Dim BoolExists As Boolean

    Set VBAEditor = Application.VBE
    Set vbProj = ActiveWorkbook.VBProject
    
    If FileOrDirExists(LPATH) = False Then MkDir LPATH
    refName = StrReverse(refUrl)
    refName = Mid(refName, 1, InStr(refName, "/") - 1)
    refName = StrReverse(refName)
    refName = Replace(refName, ".txt", "")

    '~~> Check if "Microsoft VBScript Regular Expressions 5.5" is already added
    For Each chkRef In vbProj.References
        If chkRef.FullPath = LPATH & refName Then
            BoolExists = True
            GoTo CleanUp
        End If
    Next
    If FileOrDirExists(LPATH & refName) = False Then DownloadURL refUrl, LPATH & refName
    
    vbProj.References.AddFromFile LPATH & refName

CleanUp:
    If BoolExists = True Then
        'MsgBox "Reference already exists"
    Else
        'MsgBox "Reference Added Successfully"
    End If

    Set vbProj = Nothing
    Set VBAEditor = Nothing
End Function

Public Function DownloadURL(urlPath As String, savePath) As Boolean
    DownloadURL = False
    On Error GoTo gotError
    Dim myURL As String, WinHttpReq As Object, oStream As Object

    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", urlPath, False
    WinHttpReq.Send
    
    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile savePath, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If
    DownloadURL = True
    Exit Function
gotError:
    MsgBox "Failed to download " & urlPath & vbNewLine & Err.Description
End Function

Public Sub CopyToClipboard(text As String)
    MsgBox "Copying to Clipboard"
    Dim clippy As New DataObject
    clippy.SetText (text)
    clippy.PutInClipboard
End Sub

Public Function VLookup(lookupValue As Variant, lookUpRange As Range, returnColumn As Integer, Optional approxMatch As Boolean = False) As Variant
    VLookup = Application.VLookup(lookupValue, lookUpRange, returnColumn, approxMatch)
End Function

Public Function GetTable(tableName As String, Optional wb As Workbook) As ListObject
    If IsEmpty(wb) Or wb Is Nothing Then Set wb = ThisWorkbook
    For Each s In wb.Sheets
        For Each t In s.ListObjects
            If t.Name = tableName Then
                Set GetTable = t
                Exit Function
            End If
        Next
    Next
End Function


Public Sub PutSetting(settingName As String, settingValue As Variant, Optional settingTable As String = "Settings", Optional setColumn As Integer = 2, Optional wb As Workbook)
    On Error GoTo gotError
    If IsEmpty(wb) Then Set wb = ThisWorkbook
    Dim tableObj As ListObject, foundCell As Range, SettingRow As Integer
    Set tableObj = GetTable(settingTable, wb)
    If tableObj Is Nothing Then GoTo gotError
    SettingRow = GetSettingRow(tableObj, settingName)
    If SettingRow = -1 Then
    'create setting
        tableObj.ListRows.Add (1)
        tableObj.DataBodyRange(1, 1).value = settingName
        tableObj.DataBodyRange(1, setColumn).value = settingValue
    Else
    'update setting
        tableObj.DataBodyRange(SettingRow, setColumn).value = settingValue
    End If
    
    Exit Sub
gotError:
    MsgBox "Failed"
End Sub

Private Function GetSettingRow(tableObj As ListObject, settingName As String) As Integer
    Dim x As Integer
    For x = 1 To tableObj.ListRows.Count
    If LCase(tableObj.DataBodyRange(x, 1).value) = LCase(settingName) Then
        GetSettingRow = x
        Exit Function
    End If
  Next
  GetSettingRow = -1
End Function

Public Function GetSetting(settingName As String, Optional settingTable As String = "Settings", Optional returnColumn As Integer = 2, Optional wb As Workbook) As Variant
    On Error GoTo gotError
    If IsEmpty(wb) Then Set wb = ThisWorkbook
    Dim tableObj As ListObject, foundCell As Range, SettingRow As Integer
    Set tableObj = GetTable(settingTable, wb)
    If tableObj Is Nothing Then Exit Function
    SettingRow = GetSettingRow(tableObj, settingName)
    If SettingRow = -1 Then Exit Function
    GetSetting = tableObj.DataBodyRange(SettingRow, returnColumn).value
    Exit Function
gotError:
End Function

Public Function RegExMatch(searchText As String, pattern As String, Optional onlyFirst As Boolean = True, Optional captureGroup As Integer = -1, _
                            Optional ignoreCase As Boolean = True, Optional ignoreLineBreaks As Boolean = True) As Variant
    'returns regex match of 'pattern' from 'searchText'. By default it returns first match, but can be set to return all
    'captureGroup = -1 (default) returns full match, other numbers returns capture group (starting at 0)
    'see https://regexr.com/ for help w/ RegEx
    Dim result As String, allMatches As Object, RE As Object, i As Integer, tempObj() As String
    Set RE = CreateObject("vbscript.regexp")
    With RE
        .pattern = pattern
        .Global = Not onlyFirst
        .ignoreCase = ignoreCase
        .MultiLine = ignoreLineBreaks
        Set allMatches = .Execute(searchText)
    End With
    If allMatches.Count = 0 Then Exit Function
    If onlyFirst = True Then
        RegExMatch = allMatches.Item(0)
        If captureGroup <> -1 Then RegExMatch = allMatches.Item(0).subMatches(captureGroup)
    Else
        ReDim tempObj(allMatches.Count - 1)
        For i = 0 To allMatches.Count - 1
            If captureGroup = -1 Then
                tempObj(i) = allMatches.Item(i)
            Else
                tempObj(i) = allMatches.Item(i).subMatches(captureGroup)
            End If
        Next
        RegExMatch = tempObj
    End If
End Function

Public Sub DeleteSheet(sheetName As String, Optional workbookObj As Excel.Workbook)
    If workbookObj Is Nothing Then Set workbookObj = ActiveWorkbook
    If VerifySheetExists(sheetName, False, workbookObj) = False Then Exit Sub 'doesn't exist
    Application.DisplayAlerts = False
    workbookObj.Sheets(sheetName).Delete
    Application.DisplayAlerts = True
End Sub

Attribute VB_Name = "VersionCheck"
'+----------------------------------------------------------------------------+
'|                             [Version Check]
'|  Sets up the More Macros and Troubleshooting buttons on the help tab and check server for updates.
'|                          Requires: "MS winHTTP services"
'|
'|  9/10    Updates for 64bit
'|  9/3     Moved PostTracking() to AutomationStats module
'|  4/3     Updated to use Settings instead of Ranges
'|  4/3     Added PostTracking() to track macro numbers
'|  1/27    Bug fix removed closing MSXML2.ServerXMLHTTP
'|  1/6     Bug fixes with CheckVersion.
'|  1/3     Overhaul of VersionCheck() using IDG server
'|  1/2/20  Changed URLs to use IDG server & formatting fixes
'|  5/25    Fixed error reporting bug in checkVersion
'|  5/16    More accurate hyperlink assignments.
'|  4/18    Major change to tracking! Now tracking via IDG server.
'|  3/6/18  Updated VersionCheck: cleared out columns before the version DB is added in.
'|  9/8/16  Updated FixStuckIE to better handle errors.
'|  2/11    "Instructions" tab changed to "Help".
'|  2/11/15 FixStuckIe uses IE_Sledgehammer() now.
'|  12/9    Updated StartUp() to clear last vars.
'|  5/5     FixStuckIe ends any stuck macro process and clears status bar.
'|  3/4/14  Adds users to UserList.csv on SharePoint.
'|  8/15    Fixed SP URL for downloading. Added DL error handling.
'|  5/31    error handling.
'|  5/10    changed email link to include Harmony.
'|  5/9     Also fixed SP URL.
'|  5/9     Email button dynamically includes macro name/version.
'|  5/8     Major change - now uses SharePoint site.
'|  2/22    Minor tweaks.
'|  2/13    Updated to use X drive.
'|
'+----------------------------------------------------------------------------+

'##################################################################################
'################################## SETUP #########################################
'|  add cells named "MacroUser", "MacroName", "MacroVersion", & "LastCheck" to Options tab
'|  "ThisWorkbook" should have the following code in it:
    '   Private Sub Workbook_Open()
    '       Run "StartUp"
    '   End Sub
'##################################################################################
'##################################################################################

Const EMAIL_ADDRESS As String = "scott.severt@anthem.com"
Const MORE_MACROS As String = "http://va10dwviss159.us.ad.wellpoint.com/IDG/WFM_Macro/"
Const TROUBLESHOOTING As String = "http://va10dwviss159.us.ad.wellpoint.com/IDG/WFM_Macro/B2MacroHelp/"
Const DL_DIR As String = "http://va10dwviss159.us.ad.wellpoint.com/IDG/WFM_Macro/VBA_Macros/"
Const CHECK_URL As String = "http://va10dwviss159.us.ad.wellpoint.com/IDG/WFM_Macro/check.asp"
Const TRACK_URL As String = "http://va10dwviss159.us.ad.wellpoint.com/IDG/WFM_Tracking/track.asp"
Const DL_TRACK_URL As String = "http://va10dwviss159.us.ad.wellpoint.com/IDG/WFM_Tracking/index.asp"


Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Public Declare PtrSafe Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
Public Declare PtrSafe Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Public Declare PtrSafe Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
 
Public Type tagOPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
 

Private Function ShowFileDialog(ByVal SaveFileDialog As Boolean, strFilter As String, strTitle As String, ByVal strInitialDirec As String, Optional defaultFileName)
    'Pass in a boolean indicating whether this is a SaveFileDialog. If false, it will be an open fileEDialog.
    On Error GoTo gotError
    Dim OFN As tagOPENFILENAME
    Dim strFileName As String, strFileTitle As String
    If IsEmpty(defaultFileName) = False Then strFileName = defaultFileName
    strFileName = VBA.Left(strFileName & String(256, 0), 256)
    strFileTitle = String(256, 0)
    With OFN
        .lStructSize = Len(OFN)
        '.hwndOwner = Application.hWndAccessApp
        .strFilter = strFilter
        .nFilterIndex = 0
        .strFile = VBA.Left(strFileName & String(256, 0), 256)
        .nMaxFile = VBA.Len(strFileName)
        .strFileTitle = String(256, 0)
        .nMaxFileTitle = VBA.Len(strFileTitle)
        .strTitle = strTitle
        .Flags = 0
        .strDefExt = ""
        .strInitialDir = strInitialDirec
        .strCustomFilter = ""
        .nMaxCustFilter = 0
        .lpfnHook = 0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
    End With
    If SaveFileDialog Then aht_apiGetSaveFileName OFN Else aht_apiGetOpenFileName OFN
    'The string returned is 256 chars long, ending in nulls. Remove the nulls.
    ShowFileDialog = OFN.strFile
    If VBA.Len(OFN.strFile & "") = 0 Then Exit Function
    Dim i As Long
    For i = VBA.Len(OFN.strFile) To 1 Step -1
        If VBA.Mid(OFN.strFile, i, 1) <> Constants.vbNullChar Then Exit For
    Next i
    ShowFileDialog = VBA.Mid(OFN.strFile, 1, i)
    Exit Function
gotError:
    ShowFileDialog = False
End Function



Sub StartUp()
'checks for updates every 3 days & logs new users in db
    Dim currentUser As String, control As String, dlTrackUrl As String, objHttp As Object, LastCheck As Date
    On Error GoTo gotError
    currentUser = (Environ$("Username"))
    control = currentUser & "|" & MACRO_NAME & "|" & VERSION
    'Check Tabs
    If VerifySheetExists("Help", False) = True Then
        With Worksheets("Help")
            Worksheets("Help").Unprotect
            For i = 1 To 3
                If .Hyperlinks(i).ScreenTip = "Click to email." Then .Hyperlinks(i).Address = "mailto:" & EMAIL_ADDRESS & "?subject=Macro Help: " & AppName
                If .Hyperlinks(i).ScreenTip = "View More Macros" Then .Hyperlinks(i).Address = MORE_MACROS
                If .Hyperlinks(i).ScreenTip = "Troubleshooting Steps" Then .Hyperlinks(i).Address = TROUBLESHOOTING
            Next
            Worksheets("Help").Protect
        End With
    End If
    If VerifySheetExists("ChangeLog", False) Then Worksheets("ChangeLog").Protect
    'Check for updates
    LastCheck = GetSetting("Last Check")
    If Date - LastCheck > 2 Then DoCheckVersion True
    'Log new user
    If GetSetting("control") <> control Then
        'clear last var cells
        PutSetting "Last User", Null
        PutSetting "Last Plan", Null
        PutSetting "Run Mode", "Normal"
        'add to userlist
        dlTrackUrl = DL_TRACK_URL & "?m=" & MACRO_NAME & "&v=" & VERSION & "&u=" & currentUser
        Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
        objHttp.Open "GET", dlTrackUrl, False
        objHttp.Send ""
        'if successful update MacroUser so
        If objHttp.Status = 200 Then PutSetting "Control", control
        Set objHttp = Nothing
    End If
    Exit Sub
gotError:
    On Error Resume Next
    a = Err.Description
    PutSetting "Control", Null
    If VerifySheetExists("ChangeLog", False) Then Worksheets("ChangeLog").Protect
    If VerifySheetExists("Help", False) Then Worksheets("Help").Protect
End Sub
 
Function DlFile(FullAddressOfTheLink As String, SaveFileAs As String)
        DlFile = False
    If URLDownloadToFile(0, FullAddressOfTheLink, SaveFileAs, 0, 0) = 0 Then
        DlFile = True
    End If
End Function

Sub FixStuckIE()
    On Error GoTo gotError
    Dim confirm As String
    confirm = MsgBox("This will close any open Internet Explorer windows." & vbNewLine _
        & "Please ensure that you do not have unsaved work in any Internet Explorer windows then click Ok", vbOKCancel, "Internet Explorer Fix")
    If confirm = vbCancel Then Exit Sub
    IE_Sledgehammer
    Status ("")
    MsgBox "Finished!                    ", vbInformation, "Internet Explorer Fix"
    Exit Sub
gotError:
    MsgBox "Failed. Please run the command again.", vbCritical, "Internet Explorer Fix"
End Sub

Sub DoCheckVersion(Optional DoSilent As Boolean = False)
    On Error GoTo gotError
    Dim versionUrl As String, serverVersion As Double, filename As String, filter As String, saveLoc As String
    Application.Cursor = xlWait
    filter = "Excel Macro Files(*.xlsm)" & Chr(0) & "*.xlsm" '& Chr(0) & "All Files (*.*)" & Chr(0) & "*.*"
    versionUrl = CHECK_URL & "?m=" & MACRO_NAME ' Replace(MACRO_NAME, " ", "%20")
    Application.StatusBar = "Checking for updates to " & MACRO_NAME & "..."
    DoEvents
    SetIE (False)
    IE.Navigate versionUrl
    If ieWait("*?", 30, "version") = False Then Err.Raise 2, , "Failed to reach update server"
    serverVersion = CDbl(IeGetString("version", innertext))
    filename = IeGetString("filename", innertext)
    IE.Quit
    Set IE = Nothing
    Application.Cursor = xlDefault

    If serverVersion > VERSION Then
        MsgBox "Your macro is out of date!" & Chr(13) & MACRO_NAME & " " & serverVersion & " is available for download.", vbCritical, "Update Required"
        If MsgBox("Click OK to download the current version of """ & MACRO_NAME & """.", vbOKCancel, MACRO_NAME) = vbOK Then
            namepart = Split(filename, ".")
            defaultname = namepart(0) & " " & serverVersion & "." & namepart(1)
            saveLoc = ShowFileDialog(True, filter, "Select where to save the updated version of " & MACRO_NAME & ".", "", defaultname)
            If saveLoc = defaultname Then Err.Raise 1, , "User Canceled"
            filename = Replace(filename, " ", "%20")
            dl = DlFile(DL_DIR & filename, saveLoc)
            If dl = True Then
                MsgBox MACRO_NAME & " has been saved to " & saveLoc & Chr(13) & Chr(13) & "Please exit this file and switch to the new file.", vbInformation, MACRO_NAME
            Else
                Err.Raise 2, , "Download Failed!"
            End If
        End If
    Else
        PutSetting "Last Check", Date
        If DoSilent = False Then MsgBox "Your current version is up to date!" & Chr(13) & AppName, vbInformation, "Version Check"
    End If 'out of date
    Application.StatusBar = False
    Exit Sub
gotError:
    Application.Cursor = xlDefault
    MsgBox Err.Description, IIf(Err.Number = 2, vbCritical, vbInformation), "Version Check"
    Application.StatusBar = False
    On Error Resume Next
    IE.Quit
End Sub

Sub CheckVersion()
    DoCheckVersion
End Sub

Attribute VB_Name = "WebFunctions"
'+----------------------------------------------------------------------------+
'|                            [Web Function]
'|                Handles IE and basic web functionality
'|  Requires: "Microsoft Internet Controls", "Windows Script Host Object Model"
'|
'|  2/11/21 Bugfix in IeWait - searchTerm is now byVal
'|  10/29   Added open to remove Line Breaks in StripInvalidChars()
'|  9/10    Updates for 64bit
'|  2/28    Update StripInvalidChars to escaping special chars is optional.
'|  2/21    Added IeWaitForEither() to run IeWait against 2 terms as once.
'|  2/21    Added optional caseSensitive boolean to IeWait.
'|  1/2/20  Removed KillIE() -> use IE_Sledgehammer() instead. Also formatting fixes
'|  10/8    Removed AboveWinXP()
'|  10/2    Updated ieWait to optionaly search in ElementLocation
'|  10/1    Updated ieDoAction to add 'submit'
'|  8/8     Updated StripInvalidChars to replace '&nbsp;'
'|  7/22    Bug fix in GetIeVersion
'|  7/19/19 Updated "StripInvalidChars" to replace fake MS space with real space
'|  10/18   Added "SelectedText" (for dropdowns) as option for ieGetString & iePutString
'|  8/15    Updated StripInvalidChars() to remove "�"
…