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)
    With Target
        If .Row = 1 Then
            Cancel = True
            If .Column = 1 Or .Column = 2 Then Exit Sub
            SetHeaders
        End If
    End With
End Sub

Attribute VB_Name = "Sheet5"
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
Sub FindElements()
    Dim ews As Worksheet, user As String, pwd As String, hostHome As String, boid As String
    Dim thisTab As Variant, rownum As Long, label As String, section As String
    Dim elementTable As Variant, i As Long, t As Integer, existsInTable As Boolean
    Dim sectionNumber As Long, elementNumber As Long, tbl As ListObject, sortcolumn As Range
    Dim fieldsetE As Object, legendE As Object, labelE As Object, msgIdArray() As Variant
    msgIdArray = Array("df53c503c5cea1c03388ae1c139cd925", "5e13f5e2ee8515ae1a14cd7b8f209a51", "9799d8350a8a47f2234686f1d71fe2f0")
    On Error Resume Next
    Status ""
    Set ews = Worksheets("Elements")
    With GUI
        .Show (vbModeless)
        .Run = False
        Do While .Run = False 'wait for inital start
            If .visible = False Then Exit Do
            DoEvents
        Loop
        If .visible = False Then Exit Sub
        user = .username
        pwd = .password
        hostHome = .hostHome
        boid = .boid
    End With
    For Each msgID In msgIdArray
    
        LoadBlue2 user, pwd, boid, "L", hostHome, True, , msgID, , "MISROUTE"
        ClickB2Line 1, "Claim Misroute Request"
        ews.Activate
        elementTable = Range("ElementTable")
        rownum = UBound(elementTable) + 2
        If rownum = 3 Then rownum = 2
        sectionNumber = 0
        elementNumber = 0
        For Each e In IE.Document.getElementById("sfSummary").getElementsByTagname("span")
            'If e.ID = "stateHistoryFieldset" Then
            '    a = e.innertext
            'End If
            If e.Children.length <> 0 Then e.ID = "multi"
            If e.ID <> "" And e.classname <> "displayNone" And e.ID <> "stateHistoryFieldset" Then
                'If LCase(e.PreviousSibling.PreviousSibling.tagname) = "label" Then
                Set fieldSet = e.parentelement
                For i = 0 To 9
                    buf = fieldSet.classname
                    If buf = "fieldset" Then Exit For
                    Set fieldSet = fieldSet.parentelement
                Next
                Set legendE = fieldSet.PreviousSibling
                For i = 0 To 4
                    buf = legendE.tagname
                    If buf = "LEGEND" Then Exit For
                    Set legendE = legendE.PreviousSibling
                Next
                Set labelE = Nothing
                If e.PreviousSibling Is Nothing Then
                    Set labelE = e.parentelement
                Else
                    Set labelE = e.PreviousSibling
                End If
                
                For i = 0 To 9
                    buf = labelE.outerhtml
                    buf = labelE.tagname
                    If buf = "LABEL" Then Exit For
                    If labelE.PreviousSibling Is Nothing Then
                        If Nz(labelE.parentelement, 0) = 0 Then
                            Set labelE = labelE.NextSibling
                            Set labelE = labelE.parentelement
                        Else
                            Set labelE = labelE.parentelement
                        End If
                        
                    Else
                        Set labelE = labelE.PreviousSibling
                    End If
                Next
    
                
                    label = labelE.innertext
                    If InStr(e.ID, ".child.") > 0 Then 'this is attachment details
                        label = "Attachment " & label
                    End If
                    section = legendE.innertext
                    If e.ID = "multi" Then
                        e.ID = ""
                        For i = 0 To e.Children.length - 1
                            If e.ID <> "" Then e.ID = e.ID & "|||"
                            If e.Children(i).tagname = "SPAN" Then e.ID = e.ID & e.Children(i).ID
                            e.Children(i).ID = ""
                        Next
                    End If
                    existsInTable = False
                    For i = 1 To UBound(elementTable)
                        If e.ID = elementTable(i, 4) Then
                            existsInTable = True
                            Exit For
                        End If
                    Next
                    If existsInTable = False Then
    
                        ews.Cells(rownum, 1).value = label & IIf(section <> "", " (" & Trim(Replace(section, "Details", "")) & ")", "")
                        ews.Cells(rownum, 2).value = section
                        ews.Cells(rownum, 3).value = label
                        ews.Cells(rownum, 4).value = e.ID
                        If ews.Cells(rownum, 2).value <> ews.Cells(rownum - 1, 2).value Then
                            sectionNumber = sectionNumber + 1
                            elementNumber = 1
                        End If
                        ews.Cells(rownum, 5).value = "'" & Format(sectionNumber, "000") & Format(elementNumber, "000")
                        rownum = rownum + 1
                        elementNumber = elementNumber + 1
                    End If
            End If
        Next
    
    
    Next
    B2LogOut
    IE.Quit
    Set IE = Nothing
    GUI.Hide
'sort
    Set tbl = ews.ListObjects("ElementTable")
    Set sortcolumn = Range("ElementTable[Sort]")
    tbl.Sort. _
        SortFields.Add Key:=Range("ElementTable[[#All],[Item]]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
    With tbl.Sort
       .SortFields.Clear
       .SortFields.Add Key:=sortcolumn, SortOn:=xlSortOnValues, Order:=xlAscending
       .Header = xlYes
       .Apply
    End With

    MsgBox "Finished", vbInformation, "Find Elements"
End Sub



Attribute VB_Name = "Sheet7"
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 = "B2_Only"
'+----------------------------------------------------------------------------+
'|                             [Blue2 Functions]
'|          Blue2 Specific functions for Excel macros. Requires "WebFunctions"
'|
'|  10/21   Update GetTotalRows() with optional Depth setting
'|  4/3     Updated to use Settings instead of Ranges
'|  3/5     Updated SetInventoryLimit to handle CnclAdjReq
'|  2/28    Update LoadBlue2 to process DEV correctly (Options 0228)
'|  2/28    Fixed bug causing macro to not see BOID selection screen
'|  1/27    Added add'l columns to SearchReasultColumn
'|  1/24    BaseURL uses BOIDs Table
'|  1/3     Bug fix in SetHostHome()
'|  1/2/20  Added B2SearchHistory() & formatting fixes
'|  9/12    Bug fix in setInventoryLimit()
'|  7/26/19 Added B2SelectivePurge(). Bug fix in GetTotalRows()
'|  11/9    Added SearchResultColumn Enum to make SearchResult work better
'|  8/15    Added SccfFix to fix formatting on SCCFs
'|  5/29    Added optional buttonIdToConfirmPageIsLoaded to LoadBlue2 for times when we're not loading the SCCF Search page
'|  5/25    Added optional inventoryFieldId to setInventoryLimit() for rare instances where it is not the default
'|  5/14    Bug fix in IsB2Loaded()
'|  5/7     Fixed SearchResult so it actually looks for attachmentInd
'|  5/3     Added B2NewMsg() to load New Message screen
'|  4/27    Updated GetSuccessID to pull from 2nd child of output
'|  4/27    Uses IeGetString/IePutString
'|  4/27    Added error handling to just about every line
'|  4/26    Fixed GetTotalRows
'|  4/19    Updated err.Raise statments to use ErrorNum enums
'|  4/18    Updated IsB2Loaded to work with Nasco. Added B2LogIn(), SetBoid(), SetDatabase()
'|  4/17/18 Split from B2_Functions_M4_Database
'|
'+----------------------------------------------------------------------------+

Const DEFAULT_B2 As String = "https://blue2.wellpoint.com/blue2web/"
Global B2LoadCount As Integer
Public Enum SearchResultColumn
    attachmentColumn = 0
    sccfColumn = 1
    formatColumn = 2
    statusCodeColumn = 3
    dispCodeColumn = 4
    ocStatusColumn = 5
    msgStatusColumn = 6
    msgDateColumn = 7
    claimTypeColumn = 8
    subscriberIdColumn = 9
    reasonCodeColumn = 10
    actionCodeColumn = 11
    gopFormType = 12
    hostPlanCtrl = 13
    processingSite = 14
    messgOrg = 15
End Enum

Public Function LoadBlue2(ByVal username As String, ByVal password As String, ByVal boid As String, ByVal database As String, ByVal hostHome As String, ByVal visible As Boolean, Optional ByVal sccf As String = "", _
                    Optional ByVal msgID As String = "", Optional ByVal Kill_After_Loads As Integer = 100, Optional ByVal inventoryLimit As String = "", Optional buttonIdToConfirmPageIsLoaded As String = "listingSearchButton") As Boolean
    Dim baseURL As String, url As String, b2Loaded As Boolean
    On Error GoTo gotError
    LoadBlue2 = False
    hostHome = LCase(Trim(hostHome))
    If hostHome <> "host" And hostHome <> "home" Then Err.Raise ErrorNum.Critical, "", "Unable to detirmine if this is Host or Home."
    database = Left(UCase(database), 1)
    If database <> "L" And database <> "R" Then Err.Raise ErrorNum.Critical, "", "Unable to detirmine the database selection."
    
    baseURL = GetSetting(boid, "BOIDs")
    boid = Replace(boid, "[DEV]", "")
    If baseURL = "" Then baseURL = DEFAULT_B2
    If Left(baseURL, 5) <> "https" Then baseURL = Replace(baseURL, "http://", "https://")
    url = baseURL & "general/login.do"
    If ieVersion = 0 Then ieVersion = GetIeVersion
    If ieVersion = -1 Then
        ieVersion = 0
        Err.Raise ErrorNum.Critical, "", "Error connecting to Internet Explorer. Please ensure ""Enable Protected Mode"" is checked in IE Options > Security"
    End If
    b2Loaded = False
    Do While b2Loaded = False
        SetIE (visible)
        B2LoadCount = B2LoadCount + 1
        
        If B2LoadCount > Kill_After_Loads Then
            Dim oldStatus As String
            oldStatus = Application.StatusBar
            Application.StatusBar = "Clearing IE State.. One Moment"
            B2LogOut
            IE.Quit
            Set IE = Nothing
            Sleep 1500
            Application.StatusBar = oldStatus
            B2LoadCount = 0
            SetIE (visible)
        End If
        SetIE (visible)
        If Not IE Is Nothing Then IE.Silent = True
        If ieWait(buttonIdToConfirmPageIsLoaded, 0.5) Then Exit Do 'already loaded
        
        If InStr(IE.LocationURL, baseURL & "general") = 0 Or IeState <> READYSTATE_COMPLETE Then IE.Navigate url
        If IsB2FinishedLoading(120) = False Then
            B2LogOut
            IE.Quit
            Set IE = Nothing
            Err.Raise ErrorNum.Noncritical, "", "Blue2 Not Responding"
        End If
        While ieWait("Login", 0.5, "loginFrm") = True
            B2LogIn username, password
        Wend
        While ieWait("boidSubmitBtn", 0.5) = True
            SetBOID boid
        Wend
    
        b2Loaded = IsB2Loaded()
    Loop
    ieScript ("cleanUpAround($('output'));")
    ieScript ("function alert(msg) { document.getElementById('footer').innerHTML = msg;  };")
    
    If SetHostHome(hostHome) = False Then Err.Raise ErrorNum.Noncritical, "", "Failed to set B2 to " & hostHome
'SCCF/MsgID Search
    If Trim(msgID & sccf) <> "" Then
        If hostHome = "host" Then ieScript ("loadAjax('/blue2web/general/viewPage!show.do?pageName=sccf_search', $('output'), 'view=home&homeHostCode=1', 'get');")
        If hostHome = "home" Then ieScript ("loadAjax('/blue2web/general/viewPage!show.do?pageName=sccf_search', $('output'), 'view=host&homeHostCode=2', 'get');")
        If IsB2FinishedLoading(120) = False Then Err.Raise ErrorNum.Noncritical, , "Timed out waiting for SCCF Search screen"
        If ieWait("SCCF Search", 30) = False Then Err.Raise ErrorNum.Noncritical, "", "Timed out waiting for SCCF Search screen"
        If sccf <> "" Then
            IePutString "sccfFld", sccf, , Critical
        Else 'msgID
            IePutString "messageIdInp", msgID, , Critical
        End If
        SetDatabase database
        If inventoryLimit <> "" Then setInventoryLimit (inventoryLimit)
        IeDoAction "listingSearchButton", Click, Noncritical
        Sleep 500
        If IsB2FinishedLoading(120) = False Then Err.Raise ErrorNum.Noncritical, , "Timed out after clicking search button"
        'test if loaded
        tries = 0
        While Trim(IeGetString("searchResults", innertext)) = ""
            If IeState = -1 Then Err.Raise ErrorNum.Noncritical, , "IE crashed waiting for search results"
            tries = tries + 1
            Sleep 250
            DoEvents
            If tries > (30 * 4) Then Err.Raise ErrorNum.Noncritical, "", "Timed out waiting for search results"
            errorMsg = ""
            errorMsg = IeGetString("errorDisplay", innertext)
            If errorMsg = Empty Then errorMsg = ""
            If errorMsg <> "" Then Err.Raise ErrorNum.Noncritical, "", errorMsg
        Wend
        tries = 0
        LoadBlue2 = True
    End If
    LoadBlue2 = True
    Exit Function
gotError:
    Dim ErrNum As Integer
    ErrNum = Err.Number
    LoadBlue2 = False
    Select Case ErrNum
        Case ErrorNum.Critical 'critical error
            Err.Raise ErrorNum.Critical, "LoadBlue2", Err.Description
        Case ErrorNum.Noncritical 'non-critical
            Err.Raise ErrorNum.Noncritical, "LoadBlue2", Err.Description
        Case 462 'The remote server machine does not exist
            Err.Raise ErrorNum.Noncritical, "LoadBlue2", "IE crashed durring operation"
        Case Else
            'MsgBox Err.Description & " (" & Err.Number & ")"
            Err.Raise ErrorNum.Critical, "LoadBlue2", Err.Description
    End Select
End Function

Function ClickB2Line(linenum As Integer, Optional WaitForText As String = "Country") As Boolean
'click the line number supplied, returns true if loaded within ~50 seconds
    On Error GoTo gotError
    ClickB2Line = False
    IeDoAction "listingSearch.resultsTable.tr." & linenum, Click
    IsB2FinishedLoading (120)
    loaded = ieWait(WaitForText, 0.5)
    tries = 0
    While loaded = False And tries < 10
        IeDoAction "listingSearch.resultsTable.tr." & linenum, Click
        IsB2FinishedLoading 45
        loaded = ieWait(WaitForText, 2)
        tries = tries + 1
    Wend
    ClickB2Line = loaded
    Exit Function
gotError:
    Err.Raise ErrorNum.Noncritical, , "Failed to load Blue2 line"
End Function

Function IsB2Loaded() As Boolean
'test to see if B2 has finished loading main screen
    On Error GoTo gotError
    Dim mbp As String, tries As Integer
    IsB2Loaded = False
    If InStr(IE.LocationURL, "nasco") <> 0 Then
        Sleep 500
        IsB2FinishedLoading 120
        IsB2Loaded = ieWait("SCCF History", 0)
        Exit Function
    End If
        IsB2FinishedLoading 120
        tries = 0
        While IeGetString("mailBoxPane", StyleDisplay, Critical) <> "none" And tries < 10 'check every .5 sec for 5 secs
            Sleep 500
            tries = tries + 1
        Wend
        IsB2Loaded = False
        If IeGetString("mailBoxPane", StyleDisplay, Critical) = "none" Then IsB2Loaded = True
        Exit Function
gotError:
       Err.Raise ErrorNum.Noncritical, , "IE crashed while loading"
End Function

Function B2LogOut()
    On Error Resume Next
    ieScript ("logout();")
    IsB2FinishedLoading 30
End Function

Function KillBlue2WithMessage() As Boolean
        Dim confirmMsg As String
        confirmMsg = "Blue2 seems to be having issues. Click Ok to close all Internet Explorer windows or Cancel to quit the macro." & _
        vbNewLine & "This message will close and attempt to close all IE windows automatically in 1 minute."
        confirm = MsgPopup(confirmMsg, vbOKCancel, AppName, 30)
        If confirm = -1 Then confirm = MsgPopup(confirmMsg, vbOKCancel, AppName, 30)
        If confirm = vbOK Or confirm = -1 Then
            On Error Resume Next
            B2LogOut
            IE.Quit
            Set IE = Nothing
            IE_Sledgehammer
        Else
            KillBlue2WithMessage = False
            Exit Function
        End If
        KillBlue2WithMessage = True
End Function

Function IsB2FinishedLoading(Optional timeOutSeconds As Double, Optional ignoreB2AjaxWheel As Boolean = False) As Boolean
    On Error Resume Next
    Dim innerHtml As String
    IsB2FinishedLoading = False
    startTime = Timer
    timepassed = 0
    ajaxloader = 1
    If ignoreB2AjaxWheel = True Then ajaxloader = 0
    If IeState = -1 Or IeState = 0 Then Exit Function
    While ajaxloader <> 0 Or IeState <> 4
        While ajaxloader <> 0
            innerHtml = ""
            Sleep 100
            DoEvents
            timepassed = Timer - startTime
            If timepassed > timeOutSeconds Then Exit Function
            innerHtml = IE.Document.body.innerHtml
            ajaxloader = InStr(innerHtml, "/blue2web/images/ajax-loader")
        Wend
        DoEvents
        If IeState = -1 Then Exit Function
        timepassed = Timer - startTime
        If timepassed > timeOutSeconds Then Exit Function
    Wend
    IsB2FinishedLoading = True
End Function

Function setInventoryLimit(ByVal inventoryLimit As String, Optional inventoryFieldId As String = "formatTypeFld") As Boolean
    On Error GoTo gotError
    Dim inventory As String
    If Left(LCase(inventoryLimit), 6) = "adjust" Then inventoryLimit = "adjust"
    Select Case LCase(inventoryLimit)
        Case "cncladjreq"
            inventory = "CNCLADJ"
        Case "adjustreq", "adjustresp":
            inventory = "ADJUST"
        Case "claimstatus":
            inventory = "276"
        Case Else:
            inventory = UCase(inventoryLimit)
    End Select
    IePutString inventoryFieldId, inventory
    IeDoAction inventoryFieldId, FireChange
    Exit Function
gotError:
    Err.Raise ErrorNum.Noncritical, , "Failed to set inventory limit (" & inventoryLimit & ")"
End Function

Function getSuccessId() As String
    On Error Resume Next
    getSuccessId = ""
    getSuccessId = Trim(Right((IE.Document.getElementById("msgTypeTarget").Children(1).innertext), 32))
    If getSuccessId = "" Then getSuccessId = Trim(Right(IeGetString("output", innertext), 32))
    If Len(getSuccessId) < 32 Then getSuccessId = ""
End Function

Function SetHostHome(ByVal hostHome As String) As Boolean
    On Error GoTo gotError
    SetHostHome = False
    'home host switcher
    hostHome = LCase(hostHome) & "TabAnc"
    If InStr(IeGetString(hostHome, Classlist), "active") = 0 Then
        IeDoAction hostHome, Click, Noncritical
        Sleep 100
        IsB2FinishedLoading 120
    End If
    SetHostHome = InStr(IeGetString(hostHome, Classlist), "active") > 0
    Exit Function
gotError:
    Err.Raise ErrorNum.Noncritical, , "Failed to set Blue2 to " & hostHome
End Function

Public Function GetTotalRows(Optional depth As Integer = 0) As Integer
    Dim resultText As String, resultArray() As String
    On Error GoTo gotError
    GetTotalRows = -1
    resultText = IE.Document.getElementsByClassname("results")(depth).innertext
    resultText = Replace(resultText, " Results", "")
    resultText = StrReverse(Trim(resultText))
    resultArray = Split(resultText, " ")
    GetTotalRows = StrReverse(resultArray(0))
    Exit Function
gotError:
    If depth <> 0 Then
        Err.Raise ErrorNum.Noncritical, , "Failed to count B2 Search Results"
    Else
        GetTotalRows = 0
    End If
End Function

Public Function SearchResult(rowID As Integer, value As SearchResultColumn) As String
    On Error GoTo gotError
    Dim trName As String
    If ieWait("tr.summary.", 0) = True Then 'selective purge
        trName = "tr.summary."
        value = value + 2
    End If
    If ieWait("listingSearch.resultsTable.tr.", 0) = True Then trName = "listingSearch.resultsTable.tr." 'sccf lookup
    If value = attachment Then
        If InStr(IE.Document.getElementById(trName & rowID).Children(0).innerHtml, "iconAtchInd") <> 0 Then
            SearchResult = "TRUE"
        Else
            SearchResult = "FALSE"
        End If
        Exit Function
    End If
    SearchResult = IE.Document.getElementById(trName & rowID).Children(value).innertext
    Exit Function
gotError:
    SearchResult = "ERROR"
End Function

Private Sub B2LogIn(user As String, password As String)
    ieScript ("document.loginFrm.j_username.value = '" & user & "';")
    ieScript ("document.loginFrm.j_password.value = '" & password & "';")
    ieScript ("document.loginFrm.action = '/blue2web/j_security_check';")
    ieScript ("document.loginFrm.submit()")
    Sleep 500
    IsB2FinishedLoading 120
    Sleep 500
    If ieWait("Login failed. Please try again.", 0) Then Err.Raise ErrorNum.Critical, , "Login Failed. Please reenter your B2 Username and Password."
End Sub

Private Sub SetBOID(boid As String)
    On Error GoTo gotError
    boid = Replace(boid, "NY ", "NewYork-")
    If Not SetSelect(IE.Document.getElementById("buSlt"), boid) Then Err.Raise ErrorNum.Critical, "", "BOID '" & boid & "' not available."
    IeDoAction "boidSubmitBtn", Click
    Sleep 500
    IeDoAction "boidSubmitBtn", Click, Silent
    Sleep 500
    Exit Sub
gotError:
    Err.Raise ErrorNum.Critical, , "Failed to set BOID to " & boid
End Sub

Private Sub SetDatabase(database As String)
    On Error GoTo gotError
    Dim currentDB As String
    currentDB = IE.Document.getElementsByTagname("select")(0).value
    If currentDB <> database Then
        IePutString "databaseInp", database
        IE.Document.getElementsByTagname("select")(0).value = database
        DoEvents
        Sleep 150
        ieScript ("onDBSelect();")
        Sleep 150
        DoEvents
        IsB2FinishedLoading (120)
    End If
    Exit Sub
gotError:
    Err.Raise ErrorNum.Noncritical, , "Failed to set Database"
End Sub

Public Sub B2NewMsg(ByVal hostHome As String)
    hostHome = LCase(hostHome)
    If hostHome = "home" Then
        ieScript ("loadAjax('/blue2web/general/viewPage!show.do?pageName=new_msg_home', $('output'), 'view=home&homeHostCode=2', 'get');")
    Else
        ieScript ("loadAjax('/blue2web/general/viewPage!show.do?pageName=new_msg_host', $('output'), 'view=home&homeHostCode=1', 'get');")
    End If
    IsB2FinishedLoading 30
    Sleep 250
    If ieWait("Create New Message", 30) = False Then Err.Raise ErrorNum.Noncritical, "B2NewMsg", "Failed to load ""Create New Message"" screen"
End Sub

Public Sub B2SelectivePurge(ByVal hostHome As String)
    hostHome = LCase(hostHome)
    If hostHome = "home" Then
        ieScript ("loadAjax('/blue2web/general/viewPage!show.do?pageName=view_selective_purge_admin', $('output'), 'view=home&homeHostCode=2', 'get');")
    Else
        ieScript ("loadAjax('/blue2web/general/viewPage!show.do?pageName=view_selective_purge_admin', $('output'), 'view=home&homeHostCode=1', 'get');")
    End If
    IsB2FinishedLoading 30
    Sleep 250
    If ieWait("Selective Purge Approval Process", 30, "messageMeta") = False Then Err.Raise ErrorNum.Noncritical, "B2SelectivePurge", "Failed to load ""Selective Purge"" screen"
End Sub

Public Function SccfFix(ByVal sccf As String) As String
    SccfFix = sccf
    If Len(sccf) = 17 Or Len(sccf) = 32 Then Exit Function
    If Len(SccfFix) = 16 And Mid(sccf, 16, 2) = "00" Then
        SccfFix = "0" & SccfFix
        Exit Function
    End If
End Function

Public Sub B2SearchHistory(ByVal hostHome As String)
    SetHostHome hostHome
    If ieWait("listingSearchButton", 0, "sccf_searchFrm") = True Then
        IE.Document.getElementById("sccf_searchFrm").Reset
        ieScript ("processAllFields()")
    Else
        IeDoAction "sccfHistoryTab", Click
    End If
    IsB2FinishedLoading 120
    If ieWait("listingSearchButton", 30, "sccf_searchFrm") = False Then Err.Raise ErrorNum.Noncritical, "B2SearchHistory", "Failed to load ""SCCF Search"" screen"
End Sub

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 = "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 = "HeaderGUI"
Attribute VB_Base = "0{A56AB09D-3A6F-4F49-874E-4028BB8AE78D}{CB44EA7B-E3FC-48ED-8572-929BCA865C53}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Dim headerArray() As String

Private Sub ElementBox_Change()
    UpdateActiveHeaders
End Sub



Private Sub SetButton_Click()
    Me.Hide
End Sub

Private Sub UserForm_Initialize()
    Dim headerString As String, i As Integer, ws As Worksheet
    Set ws = Worksheets("Macro")
    For i = FirstOutput To ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        If headerString <> "" Then headerString = headerString & ","
        headerString = headerString & ws.Cells(1, i).value
    Next
    'headerArray = Split(headerString, ",")
    SetListBoxAllNone Me.Name, "ElementBox", False
    SetListBoxValue Me.Name, "ElementBox", headerString
    UpdateActiveHeaders
End Sub

Private Sub UpdateActiveHeaders()
    Dim headers() As String, ActiveHeaders() As String, activeHeadersString As String
    Dim h As Integer, a As Integer, alreadyActive As Boolean, isSelected As Boolean, doAdd As Boolean
    headers = Split(GetControlValue("HeaderGUI", "ElementBox"), ",")
    With Me.ActiveHeaders
'Add Items
        For h = 0 To UBound(headers)
            alreadyActive = False
            If .ListCount > 0 Then
                For a = 0 To .ListCount - 1
                    If headers(h) = .List(a) Then alreadyActive = True
                Next
                If alreadyActive = False Then
                    .AddItem headers(h)
                    doAdd = True
                End If
            Else
                .AddItem headers(h)
                doAdd = True
            End If
        Next
        If doAdd = True Then Exit Sub 'only remove if we didn't add
'Remove Items
        For a = .ListCount - 1 To 0 Step -1
            isSelected = False
            If UBound(headers) > -1 Then
                For h = 0 To UBound(headers)
                    If .List(a) = headers(h) Then isSelected = True
                Next
                If isSelected = False Then
                    .RemoveItem a
                End If
            Else
                .RemoveItem a
            End If
        Next
    End With
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Select Case MsgBox("Apply Changes?", vbYesNoCancel, "Set Headers")
        Case vbYes
            Cancel = True
            Me.Hide
        Case vbCancel
            Cancel = True
    End Select
End Sub


Attribute VB_Name = "WebFunctions"
'+----------------------------------------------------------------------------+
'|                            [Web Function]
'|                Handles IE and basic web functionality
'|  Requires: "Microsoft Internet Controls", "Windows Script Host Object Model"
'|
'|  9/29    Bugfix for ieWait() - set everything to ByVal
'|  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 "�"
'|  5/16    Bug fix causing IeWait to not wait if * is used
'|  5/3     Updated IeWait to workwith * wildcard
'|  5/3     Updated ElementStringLoc to include "Checked"
'|  4/27    Changed IeString to IeGetString & IePutValue to IePutString
'|  4/27    Updated ElementStringLoc: added "value"
'|  4/27    Added IeDoAction() to fire actions (click,change,focus) to DOM elements
'|  4/27    Added IePutValue() to set a DOM value
'|  4/25    Added IeString() to get string from Element ID w/o error
'|  4/24    Added StripInvalidChars() to remove chars that mess up Javascript
'|  4/18    Added ieVersion as global
'|  4/12/18 Forked from B2_Functions_M4_database
'|
'+----------------------------------------------------------------------------+

Global IE As InternetExplorer
Global ieVersion As Integer
Public Enum ElementStringLoc
    innerHtml = 0
    innertext = 1
…