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 = "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 = "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 "�"
'|  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
    outerhtml = 2
    OuterText = 3
    Classlist = 4
    StyleDisplay = 5
    value = 6
    Checked = 7
    SelectedText = 8
End Enum

Public Enum IeElementAction
    Click = 0
    Focus = 1
    FireChange = 2
    submit = 3
End Enum

Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Function ieWait(ByVal searchString As String, timeOut As Double, Optional elementId As String = "", Optional elementLocation As ElementStringLoc = ElementStringLoc.innerHtml, Optional caseSensitive As Boolean = False) As Boolean
    On Error GoTo gotError
    Dim theText As String
    ieWait = False
    startTime = Timer
    timepast = 0
    If IeState = -1 Then Exit Function
    Do While InStr(theText, searchString) = 0
        DoEvents
        If IeState = 4 Then theText = IE.Document.body.innerHtml
        If elementId <> "" Then
            If InStr(theText, elementId) <> 0 Then
                theText = IeGetString(elementId, elementLocation) & IeGetString(elementId, value)
            Else
                theText = ""
            End If
        End If
        If caseSensitive = False Then
            theText = LCase(theText)
            searchString = LCase(searchString)
        End If
        If InStr(searchString, "*") Then
            If theText Like searchString Then Exit Do
        End If
        timepast = Timer - startTime
        If timepast > timeOut Then Exit Do
        If timepast < 0 Then Exit Do
    Loop
    If InStr(theText, searchString) <> 0 Then
        ieWait = True
    Else
        If theText Like searchString Then ieWait = True 'wildcard search
    End If
    Exit Function
gotError:
End Function

Public Function ieScript(javascript)
    On Error Resume Next
    Call IE.Document.parentWindow.execScript(javascript, "JavaScript")
End Function

Public Function getHTML()
    MsgBox "getHTML"
    Dim clippy As New DataObject
    theText = IE.Document.body.innerHtml
    clippy.SetText (theText)
    clippy.PutInClipboard
End Function

Public Function StripTags(html As String) As String
    On Error Resume Next
    Dim lt As Long
    Dim gt As Long
    Dim buf As String
    Dim tag As String
    'Save original string into buffer
    buf = html
    'Find and remove all HTML tags
    lt = InStr(buf, "<")
    gt = InStr(buf, ">")
    Do While lt > 0 And gt > 0 And gt > lt
        'extract tag
        tag = Mid$(buf, lt, gt - lt + 1)
        'strip tag from from buffer
        buf = Replace(buf, tag, "")
        'look for next tag
        lt = InStr(buf, "<")
        gt = InStr(buf, ">")
    Loop
    'Next remove any extranious carriage returns and line feeds
    '- from the beginnig
    Do While Left(buf, 1) = vbCr Or Left(buf, 1) = vbLf
        buf = Mid$(buf, 2)
    Loop
    '- from the end
    Do While Right(buf, 1) = vbCr Or Right(buf, 1) = vbLf
        buf = Left$(buf, Len(buf) - 1)
    Loop
    'Next fix common HTML escape codes
    buf = Replace(buf, "&nbsp;", " ")
    buf = Replace(buf, "&amp;", "&")
    buf = Replace(buf, "&quot;", """")
    buf = Replace(buf, "&#", "#")
    buf = Replace(buf, "&lt;", "<")
    buf = Replace(buf, "&gt;", ">")
    buf = Replace(buf, "%20", " ")
    'strip off extra leading and trailing spaces
    buf = Trim$(buf)
    'return the result
    StripTags = buf
End Function

Public Sub Win7Fix()
    On Error Resume Next
    Dim objWSHShell As Object
    Set objWSHShell = CreateObject("WScript.Shell")
    Dim win7FixFile As String
    win7FixFile = objWSHShell.SpecialFolders("StartMenu") & "/.win7b2fix"
    Set objWSHShell = Nothing
    Dim viewFix As String, appliedFix As String
    If FileOrDirExists(win7FixFile) = False Then
        viewFix = MsgBox("Your current version of Windows does not work correctly with this macro." & vbNewLine _
            & "There are steps available to resolve the issue." & vbNewLine _
            & "Click the Ok button to view the instructions for the fix.", vbOKCancel, "Attention")
        If viewFix = vbOK Then
            Dim IE As Object
            Set IE = CreateObject("internetexplorer.application")
            IE.visible = True
            IE.Navigate "https://collaborate.wellpoint.com/sites/WFMMacros/Production/SitePages/Windows%207%20Fix.aspx"
            Set IE = Nothing
            MsgBox "The Blue2 Macro Fix instructions have been opened in Internet Explorer." & vbNewLine & "Click Ok after you have completed the instructions.", vbExclamation, AppName
        End If
        appliedFix = MsgBox("Have you applied the Blue2 Macro Fix outlined on the SharePoint site?", vbYesNo, AppName)
        If appliedFix = vbYes Then
            Set fs = CreateObject("Scripting.FileSystemObject")
            Set a = fs.CreateTextFile(win7FixFile, True)
            a.WriteLine (Now())
            a.Close
            MsgBox "Thank you.  You should not see these messages on this PC any more.", vbInformation, AppName
        End If
    End If
    
End Sub


Public Function MsgPopup(Optional Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String, Optional SecondsToWait As Long = 0) As VbMsgBoxResult
'Replicates the VBA MsgBox() function, with an added parameter
'to automatically dismiss the message box after n seconds
'If dismissed automatically, this will return -1: NOT �cancel� or the default button choice.
'Nigel Heffernan, 2006. This code is in the public domain.
    Dim objWshell As Object
    Set objWshell = CreateObject("WScript.Shell")
    MsgPopup = objWshell.Popup(Prompt, SecondsToWait, Title, Buttons)
    Set objWshell = Nothing
End Function

Public Sub IE_Sledgehammer()
    Dim objWMI As Object, objProcess As Object, objProcesses As Object
    Set objWMI = GetObject("winmgmts://.")
    Set objProcesses = objWMI.ExecQuery( _
        "SELECT * FROM Win32_Process WHERE Name = 'iexplore.exe'")
    For Each objProcess In objProcesses
        Call objProcess.Terminate
    Next
    Set objProcesses = Nothing: Set objWMI = Nothing
End Sub

Public Function IsIeFinishedLoading(Optional timeOutSeconds As Double = 120) As Boolean
    On Error Resume Next
    Dim innerHtml As String
    IsIeFinishedLoading = False
    startTime = Timer
    timepassed = 0
    If IeState = -1 Or IeState = 0 Then Exit Function
    While IeState <> 4
        DoEvents
        If IeState = -1 Then Exit Function
        timepassed = Timer - startTime
        If timepassed > timeOutSeconds Then Exit Function
    Wend
    IsIeFinishedLoading = True
End Function

Public Function GetIEWindowFromTitle(sTitle As String, _
    Optional bCaseSensitive As Boolean = False, _
    Optional bExact As Boolean = False) As SHDocVw.InternetExplorer
'grabs instace of IE that already open (like a pop up window)
'** requires Reference to "Microsoft Internet Controls"
    Dim objShellWindows As New SHDocVw.ShellWindows
    Dim found As Boolean
    Dim startTime As Single
    found = False
    'Loop through shell windows
    For Each GetIEWindowFromTitle In objShellWindows
        found = GetIEWindowFromTitleHandler(GetIEWindowFromTitle, sTitle, bCaseSensitive, bExact)
        If found Then Exit For
    Next
    'Check whether a window was found
    If Not found Then
        Set GetIEWindowFromTitle = Nothing
    Else
        'pauseUntilIEReady GetIEWindowFromTitle
    End If
End Function

Private Function GetIEWindowFromTitleHandler(win As SHDocVw.InternetExplorer, _
    sTitle As String, _
    bCaseSensitive As Boolean, _
    bExact As Boolean) As Boolean
    GetIEWindowFromTitleHandler = False
    On Error GoTo handler
    'If the document is of type HTMLDocument, it is an IE window
    If TypeName(win.Document) = "HTMLDocument" Then
        'Check whether the title contains the passed title
        If bExact Then
            If (win.Document.Title = sTitle) Or ((Not bCaseSensitive) And (LCase(sTitle) = LCase(win.Document.Title))) Then GetIEWindowFromTitleHandler = True
        Else
            If InStr(1, win.Document.Title, sTitle) Or ((Not bCaseSensitive) And (InStr(1, LCase(win.Document.Title), LCase(sTitle), vbTextCompare) <> 0)) Then GetIEWindowFromTitleHandler = True
        End If
    End If
handler:
    'We assume here that if an error is raised it's because
    'the window is not of the correct type. Therefore we
    'simply ignore it and carry on.
End Function

Public Function GetIeVersion() As Integer
    Dim tester As String, IeCheck As InternetExplorer, startTime As Double, timepassed As Double
    On Error GoTo disconnected
    Set IeCheck = New InternetExplorer
    'IeCheck.visible = True
    IeCheck.Navigate "http://google.com"
    startTime = Timer
    timepassed = 0
    While IeCheck.ReadyState <> 4
        DoEvents
        timepassed = Timer - startTime
        If timepassed > 120 Then GoTo disconnected
    Wend
    tester = IeCheck.Document.body.innertext
    On Error GoTo ie8
    tester = IeCheck.Document.body.childElementCount
    GetIeVersion = 11
    GoTo quitIE
disconnected:
    GetIeVersion = -1
    GoTo quitIE
ie8:
    GetIeVersion = 8
    GoTo quitIE
quitIE:
    On Error Resume Next
    IeCheck.Quit
    Set IeCheck = Nothing
End Function

Public Function SetSelect(selectObject As Object, DisplayValue As String) As Boolean
'Selects an item (DisplayValue) from a combobox (selectObject)
'Usage:
'If Not SetSelect(IE.Document.all.Item("tspan"), "Custom") Then
'something went wrong
'Else
'continue...
'End If
    Dim x As Integer
    For x = 0 To selectObject.Options.Length - 1
        If selectObject.Options(x).text = DisplayValue Then
            selectObject.selectedIndex = x
            SetSelect = True
            Exit For
        End If
    Next
End Function

Public Sub SetIE(visible As Boolean)
    If IE Is Nothing Then Set IE = New InternetExplorer
    On Error GoTo gotError
    a = IE.visible
gotError:
    'MsgBox Err.Number & vbNewLine & Err.Description
    If Err.Number = 462 Or Err.Number = -2147023179 Or Err.Number = -2147417848 Then
        Set IE = Nothing
        Set IE = New InternetExplorer
    End If
    IE.visible = visible
End Sub

Public Function IeState() As Integer
    On Error GoTo gotError
    IeState = IE.ReadyState
    Exit Function
gotError:
    IeState = -1
End Function

Public Function StripInvalidChars(stringMsg As String, Optional escapeChars As Boolean = False, Optional removeLineBreaks As Boolean = False) As String
    Dim buf As String, badArray() As Variant, bit As Variant
    buf = stringMsg
    badArray = Array(vbNewLine, vbCr, vbLf, vbCrLf)
    If escapeChars = True Then
        For Each bit In badArray
            buf = Replace(buf, bit, IIf(removeLineBreaks = False, "\n", ""))
        Next
        buf = Replace(buf, """", "\""")
        buf = Replace(buf, "'", "\'")
        buf = Replace(buf, "�", "\'")
        buf = Replace(buf, "\\'", "\'")
    End If
    buf = Replace(buf, "&nbsp;", " ")
    buf = Replace(buf, "�", "'")
    buf = Replace(buf, "�", "...")
    buf = Replace(buf, "�", " ") 'Evil MS "space" character
    StripInvalidChars = buf
End Function

Public Function IeGetString(ByVal elementIdName As String, ByVal stringLoc As ElementStringLoc, Optional errorAction As ErrorNum = ErrorNum.Silent)
    'returns string from IE Element. Errors result in "" instead of [Object Required]
    On Error GoTo gotError
    IeGetString = ""
    With IE.Document.getElementById(elementIdName)
        Select Case stringLoc
            Case ElementStringLoc.innerHtml
                IeGetString = .innerHtml
            Case ElementStringLoc.innertext
                IeGetString = .innertext
            Case ElementStringLoc.outerhtml
                IeGetString = .outerhtml
            Case ElementStringLoc.OuterText
                IeGetString = .OuterText
            Case ElementStringLoc.Classlist
                IeGetString = .Classlist
            Case ElementStringLoc.StyleDisplay
                IeGetString = .Style.display
            Case ElementStringLoc.value
                IeGetString = .value
            Case ElementStringLoc.SelectedText
                IeGetString = .Options(.selectedIndex).text
        End Select
    End With
    Exit Function
gotError:
    If errorAction = Silent Then Exit Function
    Err.Raise errorAction, , "Failed to set """ & elementIdName & """ to """ & value & """"
End Function

Public Sub IePutString(ByVal elementIdName As String, value As String, Optional stringLoc As ElementStringLoc = ElementStringLoc.value, Optional errorAction As ErrorNum = ErrorNum.Silent)
    On Error GoTo gotError
    Select Case stringLoc
        Case ElementStringLoc.innerHtml
            IE.Document.getElementById(elementIdName).innerHtml = value
        Case ElementStringLoc.innertext
            IE.Document.getElementById(elementIdName).innertext = value
        Case ElementStringLoc.outerhtml
            IE.Document.getElementById(elementIdName).outerhtml = value
        Case ElementStringLoc.OuterText
            IE.Document.getElementById(elementIdName).OuterText = value
        Case ElementStringLoc.Classlist
            IE.Document.getElementById(elementIdName).Classlist = value
        Case ElementStringLoc.StyleDisplay
            IE.Document.getElementById(elementIdName).Style.display = value
        Case ElementStringLoc.value
            IE.Document.getElementById(elementIdName).value = value
        Case ElementStringLoc.Checked
            IE.Document.getElementById(elementIdName).Checked = value
        Case ElementStringLoc.SelectedText
            If Not SetSelect(IE.Document.getElementById(elementIdName), value) Then GoTo gotError
    End Select
    Exit Sub
gotError:
    If errorAction = Silent Then Exit Sub
    Err.Raise errorAction, , "Failed to set """ & elementIdName & """ to """ & value & """"
End Sub

Public Sub IeDoAction(ByVal elementIdName As String, actionType As IeElementAction, Optional errorAction As ErrorNum = ErrorNum.Silent)
    On Error GoTo gotError
    Select Case actionType
        Case IeElementAction.Click
            IE.Document.getElementById(elementIdName).Click
        Case IeElementAction.FireChange
            IE.Document.getElementById(elementIdName).fireEvent ("change")
        Case IeElementAction.submit
            IE.Document.getElementById(elementIdName).submit
    End Select
    Exit Sub
gotError:
    If errorAction = Silent Then Exit Sub
    Err.Raise errorAction, , "Failed to apply action to """ & elementIdName & """"
End Sub

Public Function IeWaitForEither(timeOut As Integer, search1 As String, search2 As String, Optional element1 As String = "", Optional element2 As String, _
    Optional elementLocation1 As ElementStringLoc = ElementStringLoc.innerHtml, Optional elementLocation2 As ElementStringLoc = ElementStringLoc.innerHtml, Optional caseSensitive1 As Boolean = False, Optional caseSensitive2 As Boolean = False) As Boolean
    IeWaitForEither = False
    For i = 0 To timeOut
        If ieWait(search1, 0.5, element1, elementLocation1) = True Then
            IeWaitForEither = True
            Exit Function
        End If
        If ieWait(search2, 0.5, element2, elementLocation2) = True Then
            IeWaitForEither = True
            Exit Function
        End If
        
    Next
    End Function


Attribute VB_Name = "signon_b2"
Attribute VB_Base = "0{5782117C-072C-4E32-8DA2-080E85EE07E3}{7B235D1D-9506-4D69-855E-6107B69D34DD}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False



'+----------------------------------------------------------------------------+
'|                             [signon_b2]
'|                            SignOn for B2
'|
'|  10/22   Bug fix in BoidCombobox_Change when BOID is blank in Options
'|  9/10    Updates for 64bit
'|  4/3     Updated to use Settings instead of Ranges
'|  1/27/20 Update for BOIDs Table
'|  5/2     get BOID returns actual correct BOID from Options tab
'|  4/30    BOID change changes "CurrentPlan" on Options tab, causing correct B2 url to select
'|  4/25    RunMode combobox does a better job remembering previous selection
'|  4/25    Forked from signon_b2_match
'|
'|  Notes: Global var "HH_Only" can set the Home/Host to a specified value
'+----------------------------------------------------------------------------+






Private Declare PtrSafe Function FindWindow _
    Lib "user32" Alias "FindWindowA" _
   (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
 
Private Declare PtrSafe Function ExtractIcon _
    Lib "shell32.dll" Alias "ExtractIconA" _
   (ByVal hInst As Long, _
    ByVal lpszExeFileName As String, _
    ByVal nIconIndex As Long) As Long
 
Private Declare PtrSafe Function SendMessage _
    Lib "user32" Alias "SendMessageA" _
   (ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Integer, _
    ByVal lParam As Long) As Long
 
Private Const WM_SETICON = &H80
Private DoRun As Boolean

Private Sub BOIDf_Change()
    'BoID = LCase(Left(BOIDf.Value, 2))
    boid = BOIDf.value
End Sub
Public Property Get username() As String
    username = UsernameTextbox.text
End Property
Public Property Get password() As String
    password = PasswordTextbox.text
End Property
Public Property Get runMode() As String
    runMode = RunModeCombobox.text
End Property
Public Property Get Run() As Boolean
    Run = DoRun
End Property
Public Property Let Run(ByVal running As Boolean)
    DoRun = running
    UpdateRunButton
End Property
Public Property Get boid()
    boid = Me.BoidCombobox.value
End Property
Public Property Get hostHome()
    hostHome = "Host"
    If Me.Home = True Then hostHome = "Home"
End Property

Private Sub BoidCombobox_Change()
Dim plan As String
plan = Nz(BoidCombobox.value)
PutSetting "Last Plan", plan
End Sub

Private Sub Host_Change()
    PutSetting "Last Host/Home", hostHome
…