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

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

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 = "UnlockVBA"
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr ' nIDDlgItem = int?
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare PtrSafe Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function LockWindowUpdate Lib "user32" (ByVal hWndLock As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal uIDEvent As LongPtr) As Long
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long ' nIDDlgItem = int?
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
    Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal uIDEvent As Long) As Long
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Private Const WM_CLOSE As Long = &H10
Private Const WM_GETTEXT As Long = &HD
Private Const EM_REPLACESEL As Long = &HC2
Private Const EM_SETSEL As Long = &HB1
Private Const BM_CLICK As Long = &HF5&
Private Const TCM_SETCURFOCUS As Long = &H1330&
Private Const IDPassword As Long = &H155E&
Private Const IDOK As Long = &H1&

Private Const TimeoutSecond As Long = 2

Private g_ProjectName    As String
Private g_Password       As String
Private g_Result         As Long
#If VBA7 Then
    Private g_hwndVBE        As LongPtr
    Private g_hwndPassword   As LongPtr
#Else
    Private g_hwndVBE        As Long
    Private g_hwndPassword   As Long
#End If

Sub Test_UnlockProject()
    Select Case UnlockProject(ActiveWorkbook.VBProject, "Test")
        Case 0: MsgBox "The project was unlocked"
        Case 2: MsgBox "The active project was already unlocked"
        Case Else: MsgBox "Error or timeout"
    End Select
End Sub

Public Function UnlockProject(ByVal Project As Object, ByVal password As String) As Long

#If VBA7 Then
    Dim lRet As LongPtr
#Else
    Dim lRet As Long
#End If
Dim timeOut As Date

    On Error GoTo ErrorHandler
    UnlockProject = 1

    ' If project already unlocked then no need to do anything fancy
    ' Return status 2 to indicate already unlocked
    If Project.Protection <> vbext_pp_locked Then
        UnlockProject = 2
        Exit Function
    End If

    ' Set global varaibles for the project name, the password and the result of the callback
    g_ProjectName = Project.name
    g_Password = password
    g_Result = 0

    ' Freeze windows updates so user doesn't see the magic happening :)
    ' This is dangerous if the program crashes as will 'lock' user out of Windows
    ' LockWindowUpdate GetDesktopWindow()

    ' Switch to the VBE
    ' and set the VBE window handle as a global variable
    Application.VBE.MainWindow.visible = True
    g_hwndVBE = Application.VBE.MainWindow.hWnd

    ' Run 'UnlockTimerProc' as a callback
    lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
    If lRet = 0 Then
        Debug.Print "error setting timer"
        GoTo ErrorHandler
    End If

    ' Switch to the project we want to unlock
    Set Application.VBE.ActiveVBProject = Project
    If Not Application.VBE.ActiveVBProject Is Project Then GoTo ErrorHandler

    ' Launch the menu item Tools -> VBA Project Properties
    ' This will trigger the password dialog
    ' which will then get picked up by the callback
    Application.VBE.CommandBars.FindControl(ID:=2578).Execute

    ' Loop until callback procedure 'UnlockTimerProc' has run
    ' determine run by watching the state of the global variable 'g_result'
    ' ... or backstop of 2 seconds max
    timeOut = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While g_Result = 0 And Now() < timeOut
        DoEvents
    Loop
    If g_Result Then UnlockProject = 0

ErrorHandler:
    ' Switch back to the Excel application
    AppActivate Application.caption

    ' Unfreeze window updates
    LockWindowUpdate 0

End Function

#If VBA7 Then
    Private Function UnlockTimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
    Private Function UnlockTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If

#If VBA7 Then
    Dim hWndPassword As LongPtr
    Dim hWndOK As LongPtr
    Dim hWndTmp As LongPtr
    Dim lRet As LongPtr
#Else
    Dim hWndPassword As Long
    Dim hWndOK As Long
    Dim hWndTmp As Long
    Dim lRet As Long
#End If
Dim lRet2 As Long
Dim sCaption As String
Dim timeOut As Date
Dim timeout2 As Date
Dim pwd As String

    ' Protect ourselves against failure :)
    On Error GoTo ErrorHandler

    ' Kill timer used to initiate this callback
    KillTimer 0, idEvent

    ' Determine the Title for the password dialog
    Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
        ' For the japanese version
        Case 1041
            sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
                        ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
                        ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
                        ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
        Case Else
            sCaption = " Password"
    End Select
    sCaption = g_ProjectName & sCaption

    ' Set a max timeout of 2 seconds to guard against endless loop failure
    timeOut = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While Now() < timeOut

        hWndPassword = 0
        hWndOK = 0
        hWndTmp = 0

        ' Loop until find a window with the correct title that is a child of the
        ' VBE handle for the project to unlock we found in 'UnlockProject'
        Do
            hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
            If hWndTmp = 0 Then Exit Do
        Loop Until GetParent(hWndTmp) = g_hwndVBE

        ' If we don't find it then could be that the calling routine hasn't yet triggered
        ' the appearance of the dialog box
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If hWndTmp = 0 Then GoTo Continue

        ' Found the dialog box, make sure it has focus
        Debug.Print "found window"
        lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

        ' Get the handle for the password input
        hWndPassword = GetDlgItem(hWndTmp, IDPassword)
        Debug.Print "hwndpassword: " & hWndPassword

        ' Get the handle for the OK button
        hWndOK = GetDlgItem(hWndTmp, IDOK)
        Debug.Print "hwndOK: " & hWndOK

        ' If either handle is zero then we have an issue
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If (hWndTmp And hWndOK) = 0 Then GoTo Continue

        ' Enter the password ionto the password box
        lRet = SetFocusAPI(hWndPassword)
        lRet2 = SendMessage(hWndPassword, EM_SETSEL, 0, ByVal -1&)
        lRet2 = SendMessage(hWndPassword, EM_REPLACESEL, 0, ByVal g_Password)

        ' As a check, get the text back out of the pasword box and verify it's the same
        pwd = String(260, Chr(0))
        lRet2 = SendMessage(hWndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
        pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
        ' If not the same then we have an issue
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If pwd <> g_Password Then GoTo Continue

        ' Now we need to close the Project Properties window we opened to trigger
        ' the password input in the first place
        ' Like the current routine, do it as a callback
        lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)

        ' Click the OK button
        lRet = SetFocusAPI(hWndOK)
        lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)

        ' Set the gloabal variable to success to flag back up to the initiating routine
        ' that this worked
        g_Result = 1
        Exit Do

        ' If we get here then something didn't work above
        ' Wait 0.1 secs and try again
        ' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
        DoEvents
        Sleep 100
    Loop
    Exit Function

    ' If we get here something went wrong so close the password dialog box (if we have a handle)
    ' and unfreeze window updates (if we set that in the first place)
ErrorHandler:
    Debug.Print Err.number
    If hWndPassword <> 0 Then SendMessage hWndPassword, WM_CLOSE, 0, ByVal 0&
    LockWindowUpdate 0

End Function

#If VBA7 Then
    Function ClosePropertiesWindow(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) As Long
#Else
    Function ClosePropertiesWindow(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long) As Long
#End If

#If VBA7 Then
    Dim hWndTmp As LongPtr
    Dim hWndOK As LongPtr
    Dim lRet As LongPtr
#Else
    Dim hWndTmp As Long
    Dim hWndOK As Long
    Dim lRet As Long
#End If
Dim lRet2 As Long
Dim timeOut As Date
Dim sCaption As String

    ' Protect ourselves against failure :)
    On Error GoTo ErrorHandler

    ' Kill timer used to initiate this callback
    KillTimer 0, idEvent

    ' Determine the Title for the project properties dialog
    sCaption = g_ProjectName & " - Project Properties"
    Debug.Print sCaption

    ' Set a max timeout of 2 seconds to guard against endless loop failure
    timeOut = Now() + TimeSerial(0, 0, TimeoutSecond)
    Do While Now() < timeOut

        hWndTmp = 0

        ' Loop until find a window with the correct title that is a child of the
        ' VBE handle for the project to unlock we found in 'UnlockProject'
        Do
            hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
            If hWndTmp = 0 Then Exit Do
        Loop Until GetParent(hWndTmp) = g_hwndVBE

        ' If we don't find it then could be that the calling routine hasn't yet triggered
        ' the appearance of the dialog box
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If hWndTmp = 0 Then GoTo Continue

        ' Found the dialog box, make sure it has focus
        Debug.Print "found properties window"
        lRet2 = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

        ' Get the handle for the OK button
        hWndOK = GetDlgItem(hWndTmp, IDOK)
        Debug.Print "hwndOK: " & hWndOK

        ' If either handle is zero then we have an issue
        ' Skip to the end of the loop, wait 0.1 secs and try again
        If (hWndTmp And hWndOK) = 0 Then GoTo Continue

        ' Click the OK button
        lRet = SetFocusAPI(hWndOK)
        lRet2 = SendMessage(hWndOK, BM_CLICK, 0, ByVal 0&)

        ' Set the gloabal variable to success to flag back up to the initiating routine
        ' that this worked
        g_Result = 1
        Exit Do

        ' If we get here then something didn't work above
        ' Wait 0.1 secs and try again
        ' Master loop is capped with a longstop of 2 secs to terminate endless loops
Continue:
        DoEvents
        Sleep 100
    Loop
    Exit Function

    ' If we get here something went wrong so unfreeze window updates (if we set that in the first place)
ErrorHandler:
    Debug.Print Err.number
    LockWindowUpdate 0

End Function


Attribute VB_Name = "BPM_WCF_Functions"
'+----------------------------------------------------------------------------+
'|                            [BPM_Only]
'|                       Handles BPM/WCF Functions
'|  Add the following to main macro:    Global Const BPM_WCF As String = "WCF" 'Sets framework as BPM or WCF
'|
'|  9/29/20     Updated GetProcessCount() to return results
'|  11/5/19     Updated "LoadContentSearch" for search fields w/o operators
'|  12/6        Added actual "ContentSearch" functions
'|  12/6        Corrected name of "Process" functions (prev called "ContentSearch").
'|  12/6        Added support for WCF. Changed name to reflect that.
'|  12/3        Bug fix in GetContentSearchCount(), plus longer timeout.
'|  10/23/18    Initial release.
'|
'+----------------------------------------------------------------------------+
'|      Workflow
'|      Call "LoadBPM" function to initiate everything
'|      Call "GetContentSearchResults" or "GetProcessCount" to do searches


Global Const BPM_URL As String = "https://fnetp8bpmprod.wellpoint.com/ENTBPM/"
Global Const WCF_URL As String = "https://fnetp8aeprod.us.ad.wellpoint.com/CONTENTONLY/"

Private Function Framework() As String
    On Error Resume Next
    Framework = "BPM" 'default if Const isn't setup
    Dim buf As String
    buf = Trim(UCase(BPM_WCF))
    If buf = BPM Or buf = "WCF" Then Framework = buf
End Function

Public Function URL() As String
    If Framework = "WCF" Then
        URL = WCF_URL
    Else
        URL = BPM_URL
    End If
End Function

Public Sub LoadBPM(workArea As String, user As String, pwd As String, ieVisible As Boolean)
    BPMfix
    SetIE ieVisible
    If InStr(IE.LocationURL, URL) = 0 Then 'not loaded at all
        IE.Navigate MACRO_BASE & Framework & "fix.htm"
        IsIeFinishedLoading 120
    End If
    If ieWait("LogonForm", 0, "divHolder") = True Then 'Sign In Screen
        IePutString "txtUserID", user
        IePutString "txtPWD", pwd
        SetSelect IE.Document.getElementById("cboEnvironment"), workArea
        ieScript "logon();"
        IsIeFinishedLoading 120
        ieWait "JavaScript:logoff();", 2
        If ieWait(" Logon Failed.", 2) = True Then Err.Raise ErrorNum.Critical, , " Logon Failed. Check your credentials and try again"
        If ieWait("Not permitted to login to this Work Area.", 0) = True Then Err.Raise ErrorNum.Critical, , "Username/Password is incorrect"
        If ieWait("JavaScript:logoff();", 55) = False Then Err.Raise ErrorNum.Noncritical, , "BPM Logon Timed Out"
    End If
    Exit Sub
End Sub

Private Sub LoadContentSearch(role As String, search As String, searchCriteria As Collection)
    Dim i As Integer, FieldName As String, fieldValue As String, fieldOperator As String
    If ielocationurl <> URL & "contentHome.jsp" Then
        IE.Navigate URL & "contentHome.jsp"
        IsIeFinishedLoading 120
        If ieWait("*?", 60, "cboSTemplate") = False Then Err.Raise ErrorNum.Noncritical, , "Timed Out waiting for Content Search page"
    Else
        DoReset
        Sleep 100
        IsIeFinishedLoading 55
    End If
    If SetRole(role) = False Then
        Sleep 500
        IsIeFinishedLoading 55
        If SetRole(role) = False Then Err.Raise ErrorNum.Noncritical, , "Failed to set Role"
    End If
    If ieWait(search, 33, "cboSTemplate") = False Then Err.Raise ErrorNum.Noncritical, , "Search '" & search & "' not found"
    If SetSearch(search) = False Then
        Sleep 500
        IsIeFinishedLoading 55
        If SetSearch(search) = False Then Err.Raise ErrorNum.Noncritical, , "Failed to set Search"
    End If
    
    For i = 1 To searchCriteria.Count
        FieldName = "txtsql"
        If InStr(searchCriteria(i)(0), "DT") <> 0 Or InStr(searchCriteria(i)(0), "DATE") <> 0 Then FieldName = FieldName & "dt"
        FieldName = FieldName & searchCriteria(i)(0)
        fieldOperator = searchCriteria(i)(1)
        If IsArray(searchCriteria(i)(2)) = True Then
            fieldValue = searchCriteria(i)(2)(0)
        Else
            fieldValue = searchCriteria(i)(2)
        End If
        IePutString "cboOps" & searchCriteria(i)(0), fieldOperator, SelectedText
        If ieWait("cboOps" & searchCriteria(i)(0), 0) = False Then ' there's no operator dropdown
            For Each e In IE.Document.getElementsByTagname("select")
                Status e.ID
                If e.ID Like "txtsql*" & searchCriteria(i)(0) = True Then
                    IePutString e.ID, fieldValue, SelectedText
                    Exit For
                End If
            Next
        Else 'there is an operator drop down
            IePutString IE.Document.getElementById("cboOps" & searchCriteria(i)(0)).NextSibling.NextSibling.ID, fieldValue
        End If
    Next
End Sub

Public Function GetContentSearchResults(role As String, search As String, searchCriteria As Collection) As Collection
    On Error Resume Next
    Dim Output As Collection, i As Integer, t As Integer, c As Integer, tables As Integer, table As Object, row() As String
    Set Output = New Collection
    LoadContentSearch role, search, searchCriteria
    ieScript "browse();"
    IsIeFinishedLoading 120
    If ieWait("*?", 120, "srchResults1") = False Then Err.Raise ErrorNum.Noncritical, , "Timed out waiting for Content Search results"
    tables = CountInStr(IE.Document.body.innerHtml, "doclistHD")
    If tables = 0 Then Exit Function
    
    For i = 1 To tables
        IE.Document.getElementById("doclistHD").ID = "table" & i
        Set table = IE.Document.getElementById("table" & i)
            For t = 1 To table.ChildNodes(0).ChildNodes.Length - 1
                ReDim row(1 To table.ChildNodes(0).ChildNodes(t).ChildNodes.Length - 1)
                For c = 1 To table.ChildNodes(0).ChildNodes(t).ChildNodes.Length - 1
                    row(c) = Trim(table.ChildNodes(0).ChildNodes(t).ChildNodes(c).innertext)
                Next
                Output.Add row
            Next
    Next
    Set GetContentSearchResults = Output
End Function

Private Sub LoadProcess(role As String, queue As String, searchCriteria As Collection)
    Dim i As Integer, FieldName As String, fieldValue As String, fieldOperator As String
    Dim newRoleId As String, newQueueId As String
    If IE.LocationURL <> URL & "processHome.jsp" Then
        IE.Navigate URL & "processHome.jsp"
        IsIeFinishedLoading 120
        If ieWait("Case sensitive", 60, "ProcessSearch") = False Then Err.Raise ErrorNum.Noncritical, , "Timed Out waiting for Process page"
    Else
        DoReset
        Sleep 100
        IsIeFinishedLoading 55
    End If
    If SetRole(role) = False Then
        Sleep 500
        IsIeFinishedLoading 55
        If SetRole(role) = False Then Err.Raise ErrorNum.Noncritical, , "Failed to set Role"
    End If
    If ieWait(queue, 33, "cboQueue") = False Then Err.Raise ErrorNum.Noncritical, , "Queue '" & queue & "' not found"
    If SetQueue(queue) = False Then
        Sleep 500
        IsIeFinishedLoading 55
        If SetQueue(queue) = False Then Err.Raise ErrorNum.Noncritical, , "Failed to set Queue"
    End If
    
    For i = 1 To searchCriteria.Count
        FieldName = "txtsql"
        If InStr(searchCriteria(i)(0), "DT") <> 0 Or InStr(searchCriteria(i)(0), "DATE") <> 0 Then FieldName = FieldName & "dt"
        FieldName = FieldName & searchCriteria(i)(0)
        fieldOperator = searchCriteria(i)(1)
        If IsArray(searchCriteria(i)(2)) = True Then
            fieldValue = searchCriteria(i)(2)(0)
        Else
            fieldValue = searchCriteria(i)(2)
        End If
        IePutString "cboOps" & searchCriteria(i)(0), fieldOperator, SelectedText
        IePutString FieldName, fieldValue
    Next
End Sub

Public Function GetProcessCount(role As String, queue As String, searchCriteria As Collection) As Long
    GetProcessCount = 0
    LoadProcess role, queue, searchCriteria
    IePutString "txtCount", ""
    ieScript "count()"
    If ieWait("*?", 60, "txtCount") = False Then
        ieScript "count()"
        If ieWait("*?", 300, "txtCount") = False Then Err.Raise ErrorNum.Noncritical, , "Timed out waiting for count"
    End If
    GetProcessCount = CLng(IeGetString("txtCount", value))
End Function

Public Sub BPMfix()
    Dim fso As FileSystemObject
    Dim FSOFile As TextStream
    If FileOrDirExists(MACRO_BASE) = False Then MkDir (MACRO_BASE)
    If FileOrDirExists(MACRO_BASE & Framework & "fix.htm") = False Then
        Set fso = New FileSystemObject
         ' opens  file in write mode
        Set FSOFile = fso.OpenTextFile(MACRO_BASE & Framework & "fix.htm", ForWriting, True)
        FSOFile.WriteLine ("<html><head><title>Loading " & Framework & "...</title>" & vbNewLine)
        FSOFile.WriteLine ("<!-- saved from url=(0042)" & URL & " -->")
        FSOFile.WriteLine ("<script>window.name = ""Login"";" & vbNewLine)
        FSOFile.WriteLine ("window.location =""" & URL & "processHome.jsp"";" & vbNewLine)
        FSOFile.WriteLine ("</script></head><body><h2>Loading " & Framework & "...</h2></body></html>" & vbNewLine)
        'FSOFile.WriteLine ("" & vbNewLine)
        FSOFile.Close
    End If
End Sub

Private Sub DoReset()
    ieScript ("function resetFormValues(sText){}")
    ieScript "resetForm();"
    IE.Document.getElementById("DisplaySrchFields").Reset
    IsIeFinishedLoading 120
End Sub

Public Function MakeCriteria(encodedCriteria As String) As Collection
    Dim usingSpan As Boolean, level1() As String, level2() As String, level3() As String, i As Integer, buf(0 To 2) As Variant, criteria As Collection
    Set criteria = New Collection
    level1 = Split(encodedCriteria, "@@")
    For i = 0 To UBound(level1)
        'ReDim Preserve buf(0 To i)
…