Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 f5a0e02a24dfe53b…

MALICIOUS

Office (OLE)

838.5 KB Created: 2019-10-25 11:50:27 Authoring application: AddinUpdater First seen: 2020-09-04
MD5: 38aae943723d200669916bbfec75d15d SHA-1: 91cae3667ec95b975b0133ab355d1db7858910b3 SHA-256: f5a0e02a24dfe53bc30ef860c8b6e61b96355eb5d7acf96fefcd03f4d7fdb374
720 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1204.002 Malicious File T1105 Ingress Tool Transfer

The sample contains a Workbook_Open macro that executes obfuscated VBA code. This code utilizes WScript.Shell and URLDownloadToFile to download and execute a second-stage payload from URLs such as http://ExcelVBA.ru/. The presence of CreateProcess, URLDownloadToFile, and WScript.Shell calls strongly indicates a downloader functionality. The ClamAV detection of 'Xls.Malware.Powmet-6922919-0' further supports its malicious nature.

Heuristics 18

  • ClamAV: Xls.Malware.Powmet-6922919-0 critical CLAMAV_DETECTION
    ClamAV detected this file as malware: Xls.Malware.Powmet-6922919-0
  • Reference to URLDownloadToFile API critical SC_STR_URLDOWNLOAD
    Reference to URLDownloadToFile API
  • VBA macros detected medium 11 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
        On Error Resume Next: Dim Folder$, downloads_folder$, changed As Boolean, v
    Const USF$ = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\"
    downloads_folder$ = Replace(SETT.GetText("{374DE290-123F-4565-9164-39C4925E467B}", , USF$), "%USERPROFILE%", Environ("USERPROFILE"))
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
            URL$ = Replace(URL$, "%hid%", HID)
        CreateObject("WScript.Shell").Run URL$
    End If
  • URLDownloadToFile in VBA critical OLE_VBA_DOWNLOAD
    URLDownloadToFile in VBA
    Matched line in script
    #If VBA7 Then        '  Office 2010-2013
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
  • VBA ActiveX event runs worksheet-decoded XLM formulas critical OLE_VBA_ACTIVEX_XLM_CELL_STAGER
    VBA code attached to an ActiveX/UserForm event reconstructs formula text from worksheet constants using Split/Replace/Mid or character shifting, then executes it through ExecuteExcel4Macro or Run. This is a high-confidence malware stager that hides XLM formula execution in sheet cells; it is not a document-parser CVE.
    Matched line in script
        On Error Resume Next
    MSG_StopMacro$ = Run(TWN & "tt", "PI_MSG_StopMacro")
    If MSG_StopMacro$ = "" Then MSG_StopMacro$ = "Do you really want to stop the macro?"
  • Obfuscated auto-exec VBA loader critical OLE_VBA_OBFUSCATED_AUTOEXEC_LOADER
    Auto-exec VBA reconstructs strings with a heavy custom decoder (numeric char-array, repeated hex-string decode, or junk-token Replace removal) and feeds them to a COM-instantiation or execution sink. This obfuscated-loader shape keeps CreateObject/Shell/URL indicators out of the macro source.
    Matched line in script
    Function ClipboardText()
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
  • VBA ActiveX event launches decoded Excel4 macro critical OLE_VBA_ACTIVEX_XLM_STAGER
    The compiled VBA p-code (identifier table) references an auto-firing ActiveX/control event together with ExecuteExcel4Macro, while the decompressed source does not — the VBA-stomping shape of the ActiveX-event XLM stager. The control event bridges into XLM formula execution to call Win32 / drop payloads, hidden from source-level scanners.
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        filename$ = Environ("TEMP") & "\macro_log.txt"
    With CreateObject("scripting.filesystemobject").CreateTextFile(filename, True)
        .Write Mid(LogString, 3): .Close
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
    Function ClipboardText()
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
  • VBA instantiates a COM class by raw CLSID high OLE_VBA_GETOBJECT_CLSID_EVASION
    VBA uses GetObject("new:{CLSID}") to instantiate a COM class by raw CLSID rather than a CreateObject ProgID — an uncommon bypass of name-based macro detection.
    Matched line in script
    Function ClipboardText()
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_Open()
    On Error Resume Next: Dim FirstRun As Boolean
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
        Next: res$ = res$ & buf$
    tmp_file$ = Environ("tmp") & "\file_MainPicture_" & PROJECT_NAME$: Kill tmp_file$
    ff& = FreeFile: Open tmp_file$ For Binary Access Write As #ff
  • Reference to CreateProcess API high SC_STR_CREATEPROCESS
    Reference to CreateProcess API
  • Reference to Windows Script Host high SC_STR_WSCRIPT
    Reference to Windows Script Host
  • Suspicious extracted artifact info EXTRACTED_FILE_STATIC_TRIAGE
    One or more files extracted from inside this sample matched static suspicious-content checks such as script obfuscation, encoded payload blobs, packed data, or execution/download terms.
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://ExcelVBA.ru/ Referenced by macro
    • http://ExcelVBA.ru/programmes/Lookup/CopyRowsReferenced by macro
    • http://ExcelVBA.ru/php2/updates.php���Referenced by macro
    • http://ExcelVBA.ru/545Referenced by macro
    • http://ExcelVBA.ru/php2/updates.phpReferenced by macro
    • http://Excel-Automation.com/Referenced by macro
    • http://www.wordarticles.com/Shorts/RibbonVBA/RibbonVBADemo.phpReferenced by macro
    • http://excelvba.ru/Referenced by macro
    • https://excelvba.ru/programmes/LookupReferenced by macro

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 631038 bytes
SHA-256: 0f2a2a8ca5bf1cd268bc27850191ab23229c8fa5563da199775a8ffd2f0fa87b
Detection
ClamAV: No threats found
Obfuscation or payload: likely
Carved artifact contains 10 long base64-like blob(s).
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisWB"
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
'---------------------------------------------------------------------------------------
' Author        : Igor Vakhnenko                   Date: 25.12.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    DeleteProgramCommandBar
End Sub

Private Sub Workbook_Open()
    On Error Resume Next: Dim FirstRun As Boolean
    FirstRun = SETT.IsFirstRun
    If FirstRun Then ShowFirstRunForm
    If SetupCancelled Then
        Application.DisplayAlerts = False
        If TrueDeveloper Then MsgBox "Setup Cancelled", vbInformation Else ThisWorkbook.Close False
        Application.DisplayAlerts = True
        Exit Sub
    End If
    Enable_AccessVBOM_Macro_DataConnections        ' disables notifications
    SaveSetting PROJECT_NAME$, "Setup", "AddinPath", ThisWorkbook.FullName
    If FirstRun Then If IsObject(F_Greeting) Then F_Greeting.Show
    CreateProgramCommandBar 0
End Sub


Attribute VB_Name = "shtr"
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
'---------------------------------------------------------------------------------------
' Author        : Igor Vakhnenko                   Date: 08.01.2016
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Const PREFIX$ = "MENU"


Function NewTranslateID() As String
    On Error Resume Next
    Dim ra As Range, coll As New Collection
    Set ra = shtr.Range(shtr.Range("a" & TRANSLATE_SHEET_FIRST_ROW), shtr.Range("A" & shtr.Rows.Count).End(xlUp))
    arr = ra.Value
    For i = LBound(arr) To UBound(arr)
        coll.Add arr(i, 1), CStr(arr(i, 1))
    Next i

    For i = 1 To 1000
        Err.Clear: id$ = PREFIX$ & "_" & Format(i, "0000")
        coll.Add id$, id$
        If Err = 0 Then NewTranslateID = id$: Exit Function
    Next
    MsgBox "Can't create ID$", vbExclamation, "Function NewTranslateID()"
End Function

Function ClipboardText()
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        ClipboardText = .GetText
    End With
End Function

Sub SetClipboardText(ByVal txt$)
    With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .SetText txt$
        .PutInClipboard
    End With
End Sub

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    On Error Resume Next
    If Target.Column = 1 And Target.Cells.Count = 1 Then
        If Target <> "" Then Cancel = True: SetClipboardText "tt(""" & Target & """) "
    End If
End Sub


Attribute VB_Name = "mod_CommonFunctions"
'---------------------------------------------------------------------------------------
' Module        : mod_CommonFunctions                    Version:
' Author        : Igor Vakhnenko                   Date: 20.12.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------
Option Compare Text: Option Private Module

Function ColumnsStringToRangeAddress(ByVal txt$) As String
    ' gets string like "A-F,8" and returns range "$A:$F,$H:$H"
    On Error Resume Next
    Dim ra As Range, col As Variant
    With ThisWorkbook.Worksheets(1)
        For Each col In ParseColumnsStringEx(txt)
            If ra Is Nothing Then Set ra = .Cells(Val(col)) Else Set ra = Union(ra, .Cells(Val(col)))
        Next
    End With
    ColumnsStringToRangeAddress = ra.EntireColumn.Address
End Function

Function ParseColumnsStringEx(ByVal txt$, Optional ByRef norm1$, Optional ByRef norm2$) As Variant
    ' Принимает в качестве параметра строку типа "A-C;8,,11-9, Е-К; 4,21,"
    ' Возвращает одномерный (горизонтальный) массив в формате Array(1,2,3,8,11,10,9,5,6,7,8,9,10,11,4,21)
    ' (пустые значения удаляются; диапазоны типа 9-15 и 17-13 раскрываются,
    '  буквенные диапазоны заменяются на числовые, русские буквы заменяются латинскими)

    On Error Resume Next
    ' устраняем возможные ошибки пользовательского ввода
    Const enARR$ = "ABCEHKMOPTX", ruARR$ = "АВСЕНКМОРТХ"
    Const cc& = 2560        ' ограничение на максимальный номер столбца
    Dim i&, arr, n&, tmpArr, spl, j&, cn&
    For i = 1 To Len(enARR$): txt = Replace(txt, Mid(ruARR$, i, 1), Mid(enARR$, i, 1)): Next i
    txt = Replace(txt, " ", ""): txt = Replace(txt, ";", ",")
    txt = Replace(txt, ":", "-"): txt = Replace(txt, ".", ","): txt = UCase(txt)
    For i = 1 To Len(txt)
        If Not Mid(txt, i, 1) Like "[A-Z0-9,-]" Then Mid(txt, i, 1) = ","
    Next i
    While InStr(1, txt, ",,"): txt = Replace(txt, ",,", ","): Wend
    While InStr(1, txt, "--"): txt = Replace(txt, "--", "-"): Wend
    txt = Replace(txt, ",-", ","): txt = Replace(txt, "-,", ",")
    If Left(txt, 1) = "-" Or Left(txt, 1) = "," Then txt = Mid(txt, 2)
    If Right(txt, 1) = "-" Or Right(txt, 1) = "," Then txt = Left(txt, Len(txt) - 1)
    norm1$ = Replace(txt$, ",", ", ")        ' возвращаем «нормализованную» строку для подстановки в поле

    arr = Split(txt$, ","): ReDim tmpArr(0 To 0)
    For i = LBound(arr) To UBound(arr)
        spl = Split(arr(i), "-")
        For j = LBound(spl) To UBound(spl)
            cn& = 0: cn& = ColumnNameToColumnNumber(spl(j)): If cn& Then spl(j) = cn&
            If Not spl(j) Like String(Len(spl(j)), "#") Then spl(j) = ""
        Next j
        If Val(spl(0)) > cc& Then spl(0) = "": spl(UBound(spl)) = ""
        If Val(spl(UBound(spl))) > cc& Then spl(UBound(spl)) = cc&
        If UBound(spl) > 1 Then arr(i) = spl(0) & "-" & spl(UBound(spl)) Else arr(i) = Join(spl, "-")
        If UBound(spl) = 1 Then If spl(0) = spl(1) Then arr(i) = spl(0)
        If UBound(spl) = 1 Then If spl(0) = "" Then arr(i) = spl(1)
    Next i
    norm2$ = Join(arr, ","): norm2$ = Replace(norm2$, ",-", ","): norm2$ = Replace(norm2$, "-,", ",")
    While InStr(1, norm2$, ",,"): norm2$ = Replace(norm2$, ",,", ","): Wend
    If Left(norm2$, 1) = "," Then norm2$ = Mid(norm2$, 2)
    If Right(norm2$, 1) = "," Then norm2$ = Left(norm2$, Len(norm2$) - 1)

    For i = LBound(arr) To UBound(arr)
        Select Case True
            Case arr(i) = "", Val(arr(i)) < 0
            Case IsNumeric(arr(i))
                tmpArr(UBound(tmpArr)) = arr(i): ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)
            Case arr(i) Like "*#-#*"
                spl = Split(arr(i), "-")
                If UBound(spl) = 1 Then
                    If IsNumeric(spl(0)) And IsNumeric(spl(1)) Then
                        If spl(0) <= cc& Then
                            If spl(1) > cc& Then spl(1) = cc&
                            For j = Val(spl(0)) To Val(spl(1)) Step IIf(Val(spl(0)) > Val(spl(1)), -1, 1)
                                tmpArr(UBound(tmpArr)) = j: ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)
                            Next j
                        End If
                    End If
                End If
        End Select
    Next i
    If UBound(tmpArr) Then
        ReDim Preserve tmpArr(0 To UBound(tmpArr) - 1)
        ParseColumnsStringEx = tmpArr
    End If
End Function

Function GetFilePathEx(Optional ByVal FileType$ = "", Optional ByVal DialogTitle$, _
                       Optional ByVal FilterDescription$ = "Excel files", Optional ByVal FilterExtention$ = "*.*") As String
    On Error Resume Next
    InitialPath$ = ThisWorkbook.Path & "\"
    If DialogTitle$ = "" Then DialogTitle$ = tt("SelectFileDialogCaption")
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = tt("SelectButtonCaption"): .Title = DialogTitle$
        .InitialFileName = SETT.GetText("GetFilePathEx_" & FileType, InitialPath)
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        GetFilePathEx = .SelectedItems(1)
        Folder$ = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), "\"))
        SETT.SetText "GetFilePathEx_" & FileType, Folder$
    End With
End Function

Function PickNewColor(Optional ByVal i_OldColor As Double = xlNone) As Double
    ' shows pick color dialog and returns selected color (RGB format)
    On Error Resume Next:
    PickNewColor = i_OldColor
    Const BGColor As Long = 13160660, ColorIndexLast As Long = 32
    Dim myOrgColor As Double, myNewColor As Double, WB As Workbook
    Dim myRGB_R As Integer, myRGB_G As Integer, myRGB_B As Integer
    If ActiveWorkbook Is Nothing Then Application.ScreenUpdating = False: Set WB = Workbooks.Add
    myOrgColor = ActiveWorkbook.Colors(ColorIndexLast)        'save original palette color

    i_Color = IIf(i_OldColor = xlNone, BGColor, i_OldColor): myRGB_R = i_Color Mod 256
    i_Color = i_Color \ 256: myRGB_G = i_Color Mod 256
    i_Color = i_Color \ 256: myRGB_B = i_Color Mod 256
    ActiveWorkbook.ResetColors        'AppActivate Application.Name
    If Application.Dialogs(xlDialogEditColor).Show(ColorIndexLast, myRGB_R, myRGB_G, myRGB_B) Then
        PickNewColor = ActiveWorkbook.Colors(ColorIndexLast)
        ThisWorkbook.Colors(ColorIndexLast) = myOrgColor
    End If
    If Not WB Is Nothing Then WB.Close False: Application.ScreenUpdating = True
End Function

Function GetKeyName(ByVal KeyCode As Integer, ByVal Shift As Integer) As String
    Select Case KeyCode
        Case 112 To 135: Button$ = "F" & (KeyCode - 111)
        Case 32: Button$ = "SpaceBar"
        Case 8: Button$ = "BackSpace"
        Case 9: Button$ = "Tab"
        Case 13: Button$ = "Enter"
        Case 16: Button$ = ""        '"Shift"
        Case 17: Button$ = ""        '"Ctrl"
        Case 18: Button$ = ""        '"Alt"
        Case 20: Button$ = "CapsLock"
        Case 27: Button$ = "Esc"
        Case 33: Button$ = "PageUp"
        Case 34: Button$ = "PageDown"
        Case 35: Button$ = "End"
        Case 36: Button$ = "Home"
        Case 37: Button$ = "Left Arrow"
        Case 38: Button$ = "Up Arrow"
        Case 39: Button$ = "Right Arrow"
        Case 40: Button$ = "Down Arrow"
        Case 44: Button$ = "PrintScreen"
        Case 45: Button$ = "Insert"
        Case 46: Button$ = "Delete"
        Case vbKeyNumlock: Button$ = "Numlock"
        Case 145: Button$ = "ScrollLock"

        Case 91: Button$ = "Win(Left)"
        Case 92: Button$ = "Win(Right)"
        Case 96 To 105: Button$ = "Numpad (" & KeyCode - 96 & ")"
        Case vbKeyMultiply: Button$ = "Numpad (*)"
        Case vbKeyAdd: Button$ = "Numpad (+)"
        Case vbKeySubtract: Button$ = "Numpad (-)"
        Case vbKeyDecimal: Button$ = "Numpad (,)"
        Case vbKeyDivide: Button$ = "Numpad (/)"

        Case 166: Button$ = "Browser Back"
        Case 167: Button$ = "Browser Forward"
        Case 168: Button$ = "Browser Refresh"
        Case 169: Button$ = "Browser Stop"
        Case 170: Button$ = "Browser Search"
        Case 171: Button$ = "Browser Favorites"
        Case 172: Button$ = "Browser Home"
        Case 173: Button$ = "Volume Mute"
        Case 174: Button$ = "Volume Down"
        Case 175: Button$ = "Volume Up"
        Case 176: Button$ = "Next Track"
        Case 177: Button$ = "Previous Track"
        Case 178: Button$ = "Stop Media"
        Case 179: Button$ = "Play/Pause"
        Case 180: Button$ = "Start Mail"
        Case 181: Button$ = "Select Media"
        Case 182: Button$ = "Start App 1"
        Case 183: Button$ = "Start App 2"

        Case 48 To 57, 65 To 90: Button$ = Chr(KeyCode)
        Case Else: Button$ = "{button " & KeyCode & "}"
    End Select

    If Len(Button$) Then
        If (Shift And 1) Then GetKeyName = GetKeyName & "Shift + "
        If (Shift And 2) Then GetKeyName = GetKeyName & "Ctrl + "
        If (Shift And 4) Then GetKeyName = GetKeyName & "Alt + "
    End If
    GetKeyName = GetKeyName & Button$
End Function

Function Chars(ByVal txt As String) As Variant
    On Error Resume Next: ReDim arr(0 To Len(txt) - 1)
    For i = LBound(arr) To UBound(arr): arr(i) = Mid(txt, i + 1, 1): Next i
    If Err Then Chars = Array() Else Chars = arr
End Function

Function SafeText(ByVal txt As String) As String
    For i = 1 To Len(txt)
        SafeText = SafeText & IIf(i = 1, "", "-") & AscW(Mid(txt, i, 1))
    Next i
End Function

Function RestoreText(ByVal txt As String) As String
    On Error Resume Next: arr = Split(txt, "-")
    For i = LBound(arr) To UBound(arr): arr(i) = ChrW(Val(arr(i))): Next i
    RestoreText = Join(arr, "")
End Function

Function ColumnNameByColumnNumber(ByVal col As Long) As String
    resA1 = Application.ConvertFormula("=r1c" & col, xlR1C1, xlA1)
    ColumnNameByColumnNumber = col & " «" & Split(resA1, "$")(1) & "»"
End Function

Function ColumnNameToColumnNumber(ByVal txt$) As Long
    On Error Resume Next    ' преобразует имя столбца в номер.   в случае ошибки возвращает 0
    ColumnNameToColumnNumber = Split(Application.ConvertFormula(txt$ & "1", xlA1, xlR1C1, True), "C")(1)
End Function


Attribute VB_Name = "mod_Main"
'---------------------------------------------------------------------------------------
' Module        : mod_Main                    Version:
' Author        : Igor Vakhnenko                   Date: 16.10.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Compare Text: Option Private Module ' : Option Explicit
Public Const PROJECT_NAME$ = "Lookup", PROJECT_YEAR& = 2013

Private Sub CreateCommandBar(): CreateProgramCommandBar 0: End Sub

Sub CreateProgramCommandBar(Optional ByVal RefreshOnly As Boolean = True)
    On Error Resume Next
    SaveDefaultSettings

    Dim AddinMenu As CommandBar, coll As Collection, i&, MainMacroButton As Object
    Application.ScreenUpdating = False
    If Not RefreshOnly Then Run DeleteOldCommandBar
    Set AddinMenu = GetCommandBar(PROJECT_NAME, True Or RefreshOnly)

    Set MainMacroButton = Add_Control(AddinMenu, ct_BUTTON, 501, "LookupData", tt("MENU_001"), msoButtonIconAndCaption, True)
    AddSettingsSwitcher AddinMenu, ct_DROPDOWN, , "LookupData", MainMacroButton

    Add3Buttons AddinMenu
    If Not RefreshOnly Then
        RunWithDelay "ActivateAddinsTab"
        AddUpdateButton AddinMenu
        RunWithDelay "ActivateAddinsTab"
    End If
    If Developer Then
        Add_Control(AddinMenu, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, False).Enabled = 0
        Add_Control AddinMenu, ct_BUTTON, , "ShowFirstRunForm", "Show FirstRun Form", msoButtonIconAndCaption, True
        Add_Control AddinMenu, ct_BUTTON, , "ToggleIsAddin", "Show/Hide TR Sheet", msoButtonIconAndCaption, True
    End If
    Application.ScreenUpdating = True
End Sub

Sub ToggleIsAddin()
    On Error Resume Next
    ThisWorkbook.IsAddin = Not ThisWorkbook.IsAddin
End Sub

Sub SaveDefaultSettings()
    On Error Resume Next
    With SETT
        .LoadAllSettings
        '---------------------------------------------------------------
        .AddDefaultValue "OptionButton_SF_ActiveWorkbook", True
        .AddDefaultValue "OptionButton_SF_ActiveSheet", True
        .AddDefaultValue "ComboBox_SF_SheetIndex", 1
        .AddDefaultValue "CheckBox_IgnoreCase", True
        .AddDefaultValue "CheckBox_IgnoredCharsEnabled", True
        .AddDefaultValue "TextBox_IgnoredChars", "{TAB}{SPACE}{160}{CR}{LF}", , True

        .AddDefaultValue "ComboBox_SF_Found_Color_Interior", vbGreen
        .AddDefaultValue "ComboBox_SF_Found_Color_Font", xlNone
        .AddDefaultValue "TextBox_SF_Found_ColumnsList", "A-F"
        .AddDefaultValue "ComboBox_SF_NotFound_Color_Interior", 13408767        'vbRed
        .AddDefaultValue "ComboBox_SF_NotFound_Color_Font", xlNone
        .AddDefaultValue "TextBox_SF_NotFound_ColumnsList", "A-B"

        .AddDefaultValue "ComboBox_SF_FirstRow", 2
        .AddDefaultValue "ComboBox_SF_LastRowColumn", "auto"

        '---------------------------------------------------------------
        .AddDefaultValue "OptionButton_DF_ActiveWorkbook", True
        .AddDefaultValue "OptionButton_DF_ActiveSheet", True
        .AddDefaultValue "ComboBox_DF_SheetIndex", 1

        .AddDefaultValue "ComboBox_DF_Found_Color_Interior", 15849925        ' blue
        .AddDefaultValue "ComboBox_DF_Found_Color_Font", xlNone
        .AddDefaultValue "TextBox_DF_Found_ColumnsList", "A-F"
        .AddDefaultValue "ComboBox_DF_NotFound_Color_Interior", 10092543        'yellow
        .AddDefaultValue "ComboBox_DF_NotFound_Color_Font", xlNone
        .AddDefaultValue "TextBox_DF_NotFound_ColumnsList", "A-B"

        .AddDefaultValue "ComboBox_DF_FirstRow", 2
        .AddDefaultValue "ComboBox_DF_LastRowColumn", "auto"

        '---------------------------------------------------------------
        .AddDefaultValue "TextBox_SF_CompareColumnsList", "2"
        .AddDefaultValue "TextBox_DF_CompareColumnsList", "3"
        .AddDefaultValue "TextBox_SF_CopyColumnsList", "8, 5-3, K-M, R, S"
        .AddDefaultValue "TextBox_DF_CopyColumnsList", "H-N, P, R"

        .AddDefaultValue "CheckBox_CopyNewRows", False
        '---------------------------------------------------------------
        .AddDefaultValue "TextBox_CopyRows_SF_ColumnsList", "0,3-5,0,0,2,1"
        .AddDefaultValue "CheckBox_CopyRows_SF_CheckColumnEnabled", False
        .AddDefaultValue "TextBox_CopyRows_SF_CheckColumnMask", "?*"
        .AddDefaultValue "ComboBox_CopyRows_DF_LastRowColumn", 1, True
        .AddDefaultValue "ComboBox_CopyRows_SF_CheckColumnNumber", 1, True

        .AddDefaultValue "ComboBox_CopyRows_DF_Color_Interior", 10092441        ' light green
        .AddDefaultValue "ComboBox_CopyRows_DF_Color_Font", xlNone
        .AddDefaultValue "TextBox_CopyRows_DF_ColouringColumnsList", "A-F"

        .AddDefaultValue "CheckBox_CopyRows_DF_Border", True
    End With
End Sub


Function GetFile_MainPicture() As String
    ' создаёт во временной папке файл, возвращает путь к созданному файлу
    On Error Resume Next: Dim F_TXT$, buf$, tmp_file$: Const BufLen& = 5000
    F_TXT$ = F_TXT$ & "FFD8FFE000104A46494600010101012C012C0000FFDB0043000504040504030505040506060506080E0908070708110C0D0A0E141115141311131316181F1B16171E1713131B251C1E2021232323151A26292622291F222322FFDB00430106060608070810090910221613162222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222FFC00011080029005003012200021101031101FFC4001A000003010101010000000000000000000004060700050801FFC40037100001040004040405020309000000000001020304110005122106132231074151711423246181153233428234354352627291A1B1FFC400190100020301000000000000000000000000040500020301FFC4002B11000103030301060700000000000000000100020304112112133141053371C1D1F03234516181B1E1FFDA000C03010002110311003F00BCE799D670C66B25197BCB212F389D0EBC50000AA1A6BCBF1819ACFB373A39F25F492F212A4B6F5D03762EFBF6AFCE04E278A6566F280806754877A5D25213D47F6F49B0702C760B6DB23E11C674C86CE94926BBEF75DC5EC3EFDB05B5A2C3096BDEEB9CA74566531B8115C0EBC80B8CDAD4B90FE93A8A16492350D8909AF657A61278DB"
    F_TXT$ = F_TXT$ & "8A38832ACE16DE5599262B20F509CF14EFCB411A2CEE2C9B24F6230D4EB01FCAE26A8EB7DB30DAD464D8BA42CD51AD81A23DD5E9789D788D1512788D6972046989424DA27F4947CB6F6412074F91FE9FCA9AC716B0106D9F557AF7B9B134836CF91547F0BF39CD7388D3D59D4A4BEF364005B5EB40EB58D89DEE80047A8C51B129F0752A4C5CD438CB4CAB5D9432BD68FE239BDFF98F73F7F4ED8AB5E34A624C409F795AD1B8BA06927EBFB283CD5C5B3934D71B2A4AD0C2D4929EE0849AAC4A8E7F9F87D412F5B009A5FC490A03EE2EBFEF152CE7FB8331EFFD99CEDDFF0069C451705467ADEFD212AEA27E23590AEFDC8D1FF3BF960D88037BA952E208B15D0CDB8973A622BA634E790F2592A429C73E58572C9B5EF611A85DFA038E6F09717F12CFE2C851F31CD23BF116E84A9319ED4A279880411BF4D120FB8ED7581B881B232F923937AA3D687C7CB590D11A5760740ED7B6D7EF8E6704C511B8EB2E4B7974288D07C52A33BA9765D458D3E86859DB703B6C30AEADEE6D4D81C612A74AFDE0351E9D7FA9C38A6326566F28182ECED321D1A41D3A3A8EC0E8360FBE04623252863E91C6B4C86D40293A8A6AFA81D1DD37B7AD9C17C52DA1ECE256B6644AD321D14C2820A3A8ED7B5DFBE048CC37A59210EB25121B58E6EE456AEAB03C81"
    F_TXT$ = F_TXT$ & "EDBDDE1D37808B7F25333F113320E5F709C9A830DB4971D1A6BA17B01A45EF5F851F4C4FFC458EB91C40E06B2F19969429250F2F945B05A6C148E91608B07D87ADE1FE4B08970B2F2A8EE4FF00A36C172F4247CB58AA02FCEBFABED89EF8931933B8817F40EE6A116290E0694D7CB6B6BF3EDEBFCBF90A2B7E01E3EAAFDA1DD37C7C8A7AF0943C2166E90C222BC0F437AB98916E3A4289005955D9F3B2463E4283C6E97A6D393D2F17EDE5AA4B41B717A53D4D0524D3754001554455D93BC1A472E06648F855C4DC2BE1D6A0A29B71C37636DFBFDAF157C4823D70B72473C1FBAB52C42481B9239E0DBA948F96B3C42CE4F9F1E22796A64C4F91ADC6D6A0AD2BD47A123CB4F7BED89DAE0A4E60B77F497892A27E212A001DFBD68F3C5B73A35906626EBE99CDFD3A4E222B61AF8F5ABE0A6EA2A2798958D0ADFBE9FBFB61853B748B2B4EDD200BA173E6008329298D6A763E9E5A93497A9A23428E814076BDB638078219758E35CBCB994A21053E01752F87147E63742B4D8040DCFF00A123D307E7CC24E5B29286F99CF63498E7FC621A2347ED355B26EBFF0031C9E038898BC750143277E05BC0739C7C38156EA0E9AB277ABFC1F524AAADF9A1F84A9FDF0F109E38A52A566F27509CB01F76843B4A93D4763D62EFC8E0069B25318812FA65"
    F_TXT$ = F_TXT$ & "36AB77F70235751EADC0F3F718B9E361B096DD139753026F75319684498F9725D53F21422B40AD9572D29210BD8EFDF7A3FEE1841F12A2AE6710A94A893B334A410170145251F2DAD8907AAEBD7BA7B1F2F46636049A2DD16BD97678379A1B7B594AFC1E0E081989721C8876ABE4C84F5D971C2544F9EABBF638AA636363B147B6D0D57862DA6060E881CE2CE459804F7F8772B6BFE5388A29A273073A334D5A89B493CA56FE435F6FC6DBF6C5E7CF1B1BB1FA54922DC232BCF39D4753D0E7212CBEEF398D0A689FE2D34404036749F2BDF7C05C0D0571B8CA0286593E302F8A7A539CCD8BA8240DCD5E907BED58F49E31ED81A5804B26E1286342D2FD57F617FFD9"
    For i = 1 To Len(F_TXT$) / 2
        buf$ = buf$ & Chr(Val("&H" & Mid(F_TXT$, 2 * i - 1, 2)))
        If Len(buf$) > BufLen& Then res$ = res$ & buf$: buf$ = "": DoEvents
    Next: res$ = res$ & buf$
    tmp_file$ = Environ("tmp") & "\file_MainPicture_" & PROJECT_NAME$: Kill tmp_file$
    ff& = FreeFile: Open tmp_file$ For Binary Access Write As #ff
    Put #ff, , res$
    Close #ff
    If FileLen(tmp_file$) = Len(F_TXT$) / 2 Then GetFile_MainPicture = tmp_file$
End Function





Attribute VB_Name = "mod_Functions"
'---------------------------------------------------------------------------------------
' Module        : mod_Functions                    Version:
' Author        : Igor Vakhnenko                   Date: 20.12.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Compare Text: Option Private Module

Function OpenWorkbooksList() As Variant
    On Error Resume Next
    Dim WB As Workbook, coll As New Collection, Item, i&
    For Each WB In Application.Workbooks
        If WB.Windows(1).Visible Then
            If WB.Path <> "" Then coll.Add WB.FullName
        End If
    Next
    ReDim arr(1 To coll.Count, 1 To 2)
    For Each Item In coll
        i = i + 1
        arr(i, 1) = Item
        arr(i, 2) = Dir(Item, vbNormal)
    Next
    OpenWorkbooksList = arr
End Function

Function ColoringEnable(ByVal FileType$) As Boolean
    On Error Resume Next        ' FileType$ = "SF" or "DF"
    ColoringEnable = SETT.GetBoolean("CheckBox_" & FileType$ & "_Found_Color_Interior") Or _
                     SETT.GetBoolean("CheckBox_" & FileType$ & "_NotFound_Color_Interior") Or _
                     SETT.GetBoolean("CheckBox_" & FileType$ & "_Found_Color_Font") Or _
                     SETT.GetBoolean("CheckBox_" & FileType$ & "_NotFound_Color_Font")
End Function

Function SpecialCells_TypeConstants(ByRef ra As Range) As Range
    ' возвращает диапазон, содержащий все заполненные ячейки диапазона ra
    On Error Resume Next: en& = Err.Number
    If ra.Worksheet.ProtectContents Then        ' если лист защищён
        Dim cell As Range
        ' перебираем все ячейки в диапазоне
        For Each cell In Intersect(ra, ra.Worksheet.UsedRange).Cells
            If Trim(cell.Value) <> "" Then        ' если ячейка непустая
                ' то добавляем её в результат
                If SpecialCells_TypeConstants Is Nothing Then
                    Set SpecialCells_TypeConstants = cell
                Else
                    Set SpecialCells_TypeConstants = Union(SpecialCells_TypeConstants, cell)
                End If
            End If
        Next cell

    Else        ' если защита листа не установлена - используем штатные средства Excel
        Set SpecialCells_TypeConstants = ra.SpecialCells(xlCellTypeConstants)
    End If
    If en& = 0 Then Err.Clear
End Function

Function SpecialCells_VisibleRows(ByRef ra As Range) As Range
    On Error Resume Next: en& = Err.Number
    If ra.Worksheet.ProtectContents Then
        Dim ro As Range
        For Each ro In Intersect(ra, ra.Worksheet.UsedRange.EntireRow).Rows
            If ro.EntireRow.Hidden = False Then
                If SpecialCells_VisibleRows Is Nothing Then
                    Set SpecialCells_VisibleRows = ro
                Else
                    Set SpecialCells_VisibleRows = Union(SpecialCells_VisibleRows, ro)
                End If
            End If
        Next ro
    Else
        Set SpecialCells_VisibleRows = ra.SpecialCells(xlCellTypeVisible)
    End If
    If en& = 0 Then Err.Clear
End Function

Function ParseString(ByVal txt As String) As Variant
    ' получает в качестве параметра текстовую строку для проверки
    ' возвращает двумерный массив размером N * 4 (где N - длина текстовой строки)
    On Error Resume Next
    n = Len(txt): ReDim arr(1 To n, 1 To 4)
    For i = LBound(arr) To UBound(arr)
        arr(i, 1) = i
        l$ = Mid(txt, i, 1)
        arr(i, 2) = l$
        arr(i, 3) = Asc(l$)
        arr(i, 4) = AscW(l$)
    Next i
    ' arr(1, 1) = "#": arr(1, 2) = "Char": arr(1, 3) = "Asc": arr(1, 4) = "AscW"
    ParseString = arr
End Function

Sub ParseActiveCell()
    On Error Resume Next
    If ActiveSheet Is Nothing Then Exit Sub
    With New Fchar
        .Show
        .TextBox_txt = ActiveCell.Value
    End With
End Sub

Attribute VB_Name = "F_Progress"
Attribute VB_Base = "0{1A96730F-B0A1-4909-A08E-78D5619C68F3}{CAB2315E-AB66-4947-A7B5-6028CD3D090D}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
'---------------------------------------------------------------------------------------
' Module        : F_Progress                    Version: 2
' Author        : Igor Vakhnenko                   Date: 21.07.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Public Indicator As ProgressIndicator, ButtonMacro$
Dim MSG_StopMacro$, MSG_StopMacroTitle$

Private Sub UserForm_Initialize()
    On Error Resume Next
    MSG_StopMacro$ = Run(TWN & "tt", "PI_MSG_StopMacro")
    If MSG_StopMacro$ = "" Then MSG_StopMacro$ = "Do you really want to stop the macro?"
    MSG_StopMacroTitle$ = Run(TWN & "tt", "PI_MSG_StopMacroTitle")
    If MSG_StopMacroTitle$ = "" Then MSG_StopMacroTitle$ = "Processing is not complete yet"
    Err.Clear
End Sub

Private Sub CommandButton_RunMacro_Click()
    On Error Resume Next
    If Len(ButtonMacro$) Then Run TWN & ButtonMacro$
End Sub

Private Sub CommandButton_stop_Click()
    On Error Resume Next
    If StopMacro Then        ' macro finished
        If IsObject(F_Greeting) Then
            If F_Greeting.Visible Then
                Unload Me
                Exit Sub
            End If
        Else
            End
        End If
    Else        ' macro is running
        If MsgBox(MSG_StopMacro$, vbQuestion + vbDefaultButton2 + vbYesNo, MSG_StopMacroTitle$) = vbYes Then
            StopMacro = True
        End If
    End If
End Sub

Private Sub SpinButton_log_Change()
    On Error Resume Next
    n = Me.SpinButton_log.Value
    Me.Height = IIf(n = 0, 82, 92 + n * 40)
    Me.TextBox_Log.Height = 40 * n
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    On Error Resume Next
    If Not Indicator Is Nothing Then Indicator.QueryClose
End Sub

Attribute VB_Name = "ProgressIndicator"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
'---------------------------------------------------------------------------------------
' Module        : ProgressIndicator                    Version: 2
' Author        : Igor Vakhnenko                   Date: 21.07.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Explicit

Public FP As New F_Progress
Public SubActionIndex As Single, SubActionsCount As Single, SubActionsStep&
Private FPVisible As Boolean, FPStartTime As Date, Position&
Private PrS&, PrE&, Percent As Double, LogString$

Public Parent As ProgressIndicator, Children As New Collection
Public ShowPercents As Boolean, ShowTime As Boolean, ShowTimeInLog As Boolean

Dim MSG_EstimatedTime$, BTN_Stop$

Function AddChildIndicator(ByVal Caption$, Optional ByVal FPPosition& = 1) As ProgressIndicator
    On Error Resume Next
    Set AddChildIndicator = New ProgressIndicator
    Set AddChildIndicator.Parent = Me
    AddChildIndicator.Show Caption, FPPosition
    Children.Add AddChildIndicator
End Function

Private Sub Class_Initialize()
    Set FP = New F_Progress: ShowPercents = True: FPVisible = True
    PrS = 0: PrE = 100: Set_ProgressBar 0: FP.PrBar.Caption = ""
    FPStartTime = Now: ShowTime = True: ShowPercents = True: SubActionsStep = 1
    Set FP.Indicator = Me

    On Error Resume Next
    MSG_EstimatedTime$ = Run(TWN & "tt", "PI_MSG_EstimatedTime")
    If MSG_EstimatedTime$ = "" Then MSG_EstimatedTime$ = "Estimated time left"
    BTN_Stop$ = Run(TWN & "tt", "PI_BTN_Cancel")
    If BTN_Stop$ = "" Then BTN_Stop$ = "Cancel"
    FP.CommandButton_stop.Caption = BTN_Stop$
    Err.Clear
End Sub

Sub Show(ByVal Caption$, Optional ByVal FPPosition& = 0, Optional LogSize& = 0)
    On Error Resume Next
    SetProgressFormCaption Caption: On Error Resume Next:
    FP.PrBar.Width = ProgressBar_Default_Width
    Position = FPPosition
    FP.Tag = Caption: FP.Show:
    If Position <> 0 Then Move Position
    FP.Repaint: DoEvents
    FP.SpinButton_log.Value = LogSize
    FP.SpinButton_log.Visible = LogSize > 0
    SetLogSize LogSize
End Sub

Sub Hide()
    Unload FP
    FPVisible = False
End Sub

Sub Repaint()
    FP.Repaint: DoEvents
    If Application.ScreenUpdating = False Then Application.ScreenUpdating = True: Application.ScreenUpdating = False
End Sub

Sub Move(ByVal Position&)
    If Abs(Position) > 3 Then Exit Sub
    If Not Me.Parent Is Nothing Then
        FP.Top = Me.Parent.FP.Top + Me.Parent.FP.Height + 10 + (FP.Height + 3) * (Position - 1)
    Else
        FP.Top = FP.Top + (FP.Height + 3) * Position
    End If
End Sub

Public Property Get Visible(): Visible = FPVisible: End Property

Public Property Let Line1(ByVal NewValue$): FP.L1.Caption = ProcessLabel(NewValue): Me.FP.Repaint: DoEvents: End Property
Public Property Let Line2(ByVal NewValue$): FP.L2.Caption = ProcessLabel(NewValue): Me.FP.Repaint: DoEvents: End Property
Public Property Let Line3(ByVal NewValue$): FP.L3.Caption = ProcessLabel(NewValue): Me.FP.Repaint: DoEvents: End Property
Public Property Let Caption(ByVal NewValue$): SetProgressFormCaption NewValue: End Property

Private Sub SetProgressFormCaption(Optional ByVal Caption$ = "")
    Dim txt$, dt$
    If Len(Caption) > 0 Then FP.Tag = Caption
    txt = Trim(FP.Tag): If ShowPercents Then txt = Fix(Percent) & " %   " & txt
    dt = Format(Now - FPStartTime, "HH:NN:SS")
    If ShowTime Then txt = "( " & dt & " )    " & txt
    FP.Caption = txt
End Sub

Private Function TimeToFinish$()
    On Error Resume Next: Dim dt As Single
    If Percent < 15 Then Exit Function
    dt = (Now - FPStartTime) * (100 - Percent) / Percent
    TimeToFinish$ = Format(dt, "H:NN:SS")
    TimeToFinish$ = MSG_EstimatedTime$ & ": " & TimeToFinish$
End Function

Sub SetFocus()
    FP.Show 0: If Position <> 0 Then Move Position
End Sub

Private Sub UpdateLabels(Optional ByVal L1_txt$, Optional ByVal L2_txt$, Optional ByVal L3_txt$)
    If Len(L1_txt$) > 0 Then FP.L1.Caption = ProcessLabel(L1_txt$)
    If Len(L1_txt$) + Len(L2_txt$) > 0 Then FP.L2.Caption = ProcessLabel(L2_txt$)
    If Len(L1_txt$) + Len(L2_txt$) + Len(L3_txt$) > 0 Then FP.L3.Caption = ProcessLabel(L3_txt$)
End Sub

Private Function ProcessLabel$(ByVal txt$)
    If txt Like "*$index*" Then txt = Replace(txt, "$index", SubActionIndex)
    If txt Like "*$count*" Then txt = Replace(txt, "$count", SubActionsCount)
    If txt Like "*$time*" Then txt = Replace(txt, "$time", TimeToFinish)
    ProcessLabel = txt
End Function

Sub SubAction(Optional ByVal L1_txt$ = "", Optional ByVal L2_txt$ = "", Optional ByVal L3_txt$ = "")
    On Error Resume Next
    If SubActionsCount = 0 Then SubActionsCount = 1
    SubActionIndex = SubActionIndex + 1 * SubActionsStep
    If SubActionIndex > SubActionsCount Then SubActionIndex = SubActionsCount
    Percent = PrS + (PrE - PrS) * ((SubActionIndex - 1) / SubActionsCount)
    UpdateLabels L1_txt$, L2_txt$, L3_txt$
    Set_ProgressBar Percent: DoEvents
End Sub

Sub StartNewAction(Optional ByVal Pr_Start& = 0, Optional ByVal Pr_End& = 100, _
                   Optional ByVal L1_txt$ = "", Optional ByVal L2_txt$ = " ", Optional ByVal L3_txt$ = " ", _
                   Optional ByVal Actions_Count& = 0)
    On Error Resume Next
    PrS = Pr_Start: PrE = Pr_End: SubActionIndex = 0: SubActionsCount = Actions_Count
    UpdateLabels L1_txt$, L2_txt$, L3_txt$
    Set_ProgressBar PrS
End Sub

Sub UpdateFromChild(ByVal ChildPercent As Double)
    If SubActionsCount = 0 Then
        Percent = PrS + (PrE - PrS) * (ChildPercent / 100)
    Else
        Percent = PrS + (PrE - PrS) / SubActionsCount * (SubActionIndex - 1) + (PrE - PrS) / SubActionsCount * (ChildPercent / 100)
    End If
    Set_ProgressBar Percent
End Sub

Private Sub Set_ProgressBar(ByVal NewPercent As Double)
    On Error Resume Next: Percent = NewPercent
    If NewPercent > 100 Then Percent = 100
    If NewPercent < 0 Then Percent = 0
    FP.PrBar.Width = Int(Percent * ProgressBar_Default_Width / 100)
    SetProgressFormCaption
    FP.Repaint
    If Not Parent Is Nothing Then Parent.UpdateFromChild Percent
End Sub

Private Sub Class_Terminate()
    On Error Resume Next
    Unload FP: FPVisible = False
    Set FP = Nothing: Set Children = Nothing: Set Parent = Nothing
End Sub

Private Function ProgressBar_Default_Width() As Double
    ProgressBar_Default_Width = FP.Width - 18
End Function

Function CancelButton() As MSForms.CommandButton
    Set CancelButton = FP.CommandButton_stop
End Function

Sub SetLogSize(ByVal n&)
    On Error Resume Next
    If n < 0 Then n = 0
    If n > 5 Then n = 5
    FP.SpinButton_log.Value = n
    FP.SpinButton_log.Visible = n > 0
End Sub

Sub Log(ByVal txt$, Optional ByVal MaxLen& = 0)
    On Error Resume Next: Dim currtime$, newtext$
    If ShowTimeInLog Then currtime$ = Time & vbTab
    LogString = LogString & vbNewLine & currtime$ & txt
    newtext$ = Mid(LogString, 3): If MaxLen& Then newtext$ = Right(newtext$, MaxLen&)
    FP.TextBox_Log.Text = newtext$
    If FP.SpinButton_log.Value = 0 Then FP.SpinButton_log.Value = 2: FP.SpinButton_log.Visible = True
    FP.CommandButton_stop.SetFocus: FP.TextBox_Log.SetFocus
End Sub

Sub ClearLog()
    LogString = "": FP.TextBox_Log.Text = ""
End Sub

Sub ShowLog()
    On Error Resume Next: Dim filename$
    filename$ = Environ("TEMP") & "\macro_log.txt"
    With CreateObject("scripting.filesystemobject").CreateTextFile(filename, True)
        .Write Mid(LogString, 3): .Close
    End With
    FollowHyperlink """" & filename$ & """"
End Sub

Sub AddButton(ByVal Caption$, ByVal Macro$)
    Const dd& = 18
    If FP.SpinButton_log = 0 Then FP.SpinButton_log = 1
    With Me.FP.CommandButton_RunMacro
        .Caption = Caption$
        .Visible = True
        .Top = FP.Height - .Height - dd - 20
        .Left = FP.Width - .Width - dd - 15
    End With
    FP.ButtonMacro = Macro$
End Sub

Function MacroButton() As MSForms.CommandButton
    Set MacroButton = FP.CommandButton_RunMacro
End Function

Sub QueryClose()
    On Error Resume Next
    Dim pi As ProgressIndicator
    For Each pi In Children
        pi.QueryClose
        pi.Hide
    Next pi
End Sub



Attribute VB_Name = "FWF"
'---------------------------------------------------------------------------------------
' Module        : FWF                    Version: 2
' Author        : Igor Vakhnenko                   Date: 25.12.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Private Module: Option Compare Text: Option Explicit

#If VBA7 Then        '  Office 2010-2013
    Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
             ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
#Else        '  Office 2003-2007
    Declare 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
#End If

Function DownLoadFileFromURL(ByVal URL$, ByVal LocalPath$, Optional ByVal DisableCache As Boolean = False) As Boolean
    On Error Resume Next: Dim shortFilename$
    If (LocalPath$ = "") Or (URL$ = "") Then Exit Function
    If Not LocalPath$ Like "*\*" Then LocalPath$ = Environ("TEMP") & "\" & LocalPath$
    Kill LocalPath$
    shortFilename$ = Mid(LocalPath$, InStrRev(LocalPath$, "\") + 1)
    If shortFilename$ <> Replace_symbols(shortFilename$) Then
        Debug.Print "Wrong symbols in filename: " & shortFilename$
        Exit Function
    End If
    If DisableCache Then Randomize: URL$ = URL$ & "?HID=" & HID & "&rnd=" & Left(Rnd(Now) * 1E+15, 10)
    DownLoadFileFromURL = URLDownloadToFile(0, URL$, LocalPath$, 0, 0) = 0
End Function

Function GetFileExtension(ByVal filename$) As String
    On Error Resume Next: filename$ = Replace(filename$, "/", "\")
    filename$ = Split(filename$, "\")(UBound(Split(filename$, "\")))
    If filename$ Like "*.*" Then GetFileExtension = Split(filename$, ".")(UBound(Split(filename$, ".")))
End Function


Function GetFolderPath(Optional ByVal DialogTitle$, Optional ByVal InitialPath$ = "c:\") As String
    On Error Resume Next
    If DialogTitle$ = "" Then DialogTitle$ = tt("SelectFolderDialogCaption")
    Dim PS$: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
        .ButtonName = tt("SelectButtonCaption")
        .Title = DialogTitle$: .InitialFileName = InitialPath$
        If .Show <> -1 Then Exit Function
        GetFolderPath = .SelectedItems(1)
        If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

Function GetFilePath(Optional ByVal DialogTitle$, Optional ByVal InitialPath$ = "c:\", _
                     Optional ByVal FilterDescription$ = "Excel files", Optional ByVal FilterExtension$ = "*.xls*") As String
    On Error Resume Next
    If DialogTitle$ = "" Then DialogTitle$ = tt("SelectFileDialogCaption")
    With Application.FileDialog(msoFileDialogOpen)
        .Title = DialogTitle$: .InitialFileName = InitialPath$
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtension
        If .Show <> -1 Then Exit Function
        GetFilePath = .SelectedItems(1)
    End With
End Function

Function GetFilenamesCollection(Optional ByVal DialogTitle$, Optional ByVal InitialPath$ = "c:\") As FileDialogSelectedItems
    On Error Resume Next
    If DialogTitle$ = "" Then DialogTitle$ = tt("SelectFilesDialogCaption")
    With Application.FileDialog(3)        ' msoFileDialogFilePicker
        .Title = DialogTitle$: .InitialFileName = InitialPath$
        If .Show <> -1 Then Exit Function
        Set GetFilenamesCollection = .SelectedItems
    End With
End Function

Function FilenamesCollection(ByVal FolderPath$, Optional ByVal mask$ = "*", Optional ByVal SearchDeep& = 999) As Collection
    On Error Resume Next: Dim FSO As Object: Set FilenamesCollection = New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    GetAllFileNamesUsingFSO FolderPath, mask, FSO, FilenamesCollection, SearchDeep
    Set FSO = Nothing        ': Application.StatusBar = False
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath$, ByVal mask$, ByRef FSO, ByRef FileNamesColl As Collection, ByVal SearchDeep&)
    On Error Resume Next: Dim oCurrFolder As Object, oFile As Object, oSubFolder As Object
    Const ExcludeFiles$ = "Thumbs.db, desktop.ini"

    Set oCurrFolder = FSO.GetFolder(FolderPath)
    If Not oCurrFolder Is Nothing Then
        ' Application.StatusBar = "Searching in: " & FolderPath$
        For Each oFile In oCurrFolder.files
            If oFile.Name Like "*" & mask Then
                If InStr(1, ExcludeFiles$, oFile.Name, vbTextCompare) = 0 Then
                    If InStr(1, oFile.Name, "~$", vbTextCompare) <> 1 Then FileNamesColl.Add oFile.Path
                End If
            End If
        Next
        SearchDeep& = SearchDeep& - 1
        If SearchDeep& Then
            For Each oSubFolder In oCurrFolder.SubFolders
                GetAllFileNamesUsingFSO oSubFolder.Path, mask, FSO, FileNamesColl, SearchDeep&
            Next
        End If
        Set oFile = Nothing: Set oSubFolder = Nothing: Set oCurrFolder = Nothing
    End If
End Function

Function SubFoldersCollection(ByVal FolderPath$, Optional ByVal mask$ = "*") As Collection
    On Error Resume Next: Dim FSO As Object, oSubFolder As Object

    Set SubFoldersCollection = New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Right(FolderPath$, 1) <> "\" Then FolderPath$ = FolderPath$ & "\"

    For Each oSubFolder In FSO.GetFolder(FolderPath$).SubFolders
        If oSubFolder.Path Like FolderPath$ & mask$ Then SubFoldersCollection.Add oSubFolder.Path & "\"
    Next oSubFolder
    Set oSubFolder = Nothing: Set FSO = Nothing
End Function


Function ReadTXTfile(ByVal filename$) As String
    On Error Resume Next: Dim FSO As Object, ts As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set ts = FSO.OpenTextFile(filename$, 1, True): ReadTXTfile = ts.ReadAll: ts.Close
    Set ts = Nothing: Set FSO = Nothing
End Function

Function SaveTXTfile(ByVal filename$, ByVal txt$) As Boolean
    On Error Resume Next: Err.Clear: Dim FSO As Object, ts As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set ts = FSO.CreateTextFile(filename$, True)
    ts.Write txt: ts.Close
    SaveTXTfile = Err = 0: Set ts = Nothing: Set FSO = Nothing
End Function

Function AddIntoTXTfile(ByVal filename$, ByVal txt$) As Boolean
    On Error Resume Next: Err.Clear: Dim FSO As Object, ts As Object
    Set FSO = CreateObject("scripting.filesystemobject")
    Set ts = FSO.OpenTextFile(filename$, 8, True): ts.Write txt: ts.Close
    AddIntoTXTfile = Err = 0: Set ts = Nothing: Set FSO = Nothing
End Function


Function Replace_symbols(ByVal txt$, Optional ReplaceWith$ = "_", Optional ByVal AllowPathSeparator As Boolean = False) As String
    On Error Resume Next: Dim i&, CharsList$: CharsList$ = "/\:?*|""<>"
    If AllowPathSeparator Then CharsList$ = Replace(CharsList$, Application.PathSeparator, "")
    For i& = 1 To Len(CharsList$)
        txt$ = Replace(txt$, Mid(CharsList$, i&, 1), ReplaceWith$)
    Next
    Replace_symbols = txt$
End Function

Sub OpenFolder(ByVal FolderPath$)        ' to open FolderPath$ in Windows Explorer
    On Error Resume Next: If FolderPath$ = "" Then Exit Sub
    If FolderExists(FolderPath$) Then
        FollowHyperlink "explorer.exe /e, """ & FolderPath$ & """"
    Else
        MsgBox tt("UnableToOpenFolder", vbNewLine & FolderPath$ & vbNewLine), vbExclamation, tt("FolderNotFound")
    End If
End Sub

Sub FollowHyperlink(ByVal URL$)
    On Error Resume Next
    If Len(URL$) Then
…

Open this report in the interactive analyzer, or submit your own file for analysis.