Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 9ea835468a8e593b…

MALICIOUS

Office (OLE)

3.19 MB Created: 2018-08-15 15:01:24 Authoring application: AddinUpdater First seen: 2018-08-26
MD5: 8f3930c29aaa4c39cfb223664ac362c4 SHA-1: c4ef11043ee027eff6951c300276b79e41d39692 SHA-256: 9ea835468a8e593bab04615b9b36006faa1de1f275a0cb1cc0bb92df8f5d24b1
978 Risk Score

Malware Insights

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

The sample is a malicious Excel add-in containing obfuscated VBA macros. The macros utilize `URLDownloadToFile` and `CreateObject` to download and execute a second-stage payload from URLs associated with `ExcelVBA.ru`. The `Workbook_Open` subroutine is designed to automatically execute upon opening the workbook, indicating a loader functionality. The presence of `cmd.exe` references and `WScript.Shell` usage further supports the execution of downloaded payloads.

Heuristics 23

  • ClamAV: Xls.Malware.Generic-6823680-0 critical CLAMAV_DETECTION
    ClamAV detected this file as malware: Xls.Malware.Generic-6823680-0
  • Reference to URLDownloadToFile API critical SC_STR_URLDOWNLOAD
    Reference to URLDownloadToFile API
  • VBA macros detected medium 14 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
        Shell "Cmd.exe /c echo " & Chr(7), vbHide
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
        AddinPath$ = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Parser.xla"
  • URLDownloadToFile in VBA critical OLE_VBA_DOWNLOAD
    URLDownloadToFile in VBA
    Matched line in script
        Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  • VBA ActiveX event runs worksheet-decoded XLM formulas critical OLE_VBA_ACTIVEX_XLM_CELL_STAGER
    VBA code attached to an ActiveX/UserForm event reconstructs formula text from worksheet constants using Split/Replace/Mid or character shifting, then executes it through ExecuteExcel4Macro or Run. This is a high-confidence malware stager that hides XLM formula execution in sheet cells; it is not a document-parser CVE.
    Matched line in script
        test$ = Application.Run("ParserAddinTest")
  • VBA downloads and writes a file to disk critical OLE_VBA_HTTP_DROP_EXEC
    VBA reads an HTTP response body and writes it to disk (ADODB.Stream SaveToFile). Combined with the auto-exec/Shell paths this is a download-drop dropper even when the COM ProgIDs are built dynamically to evade keyword scanning.
    Matched line in script
                        oStream.Write .ResponseBody
  • 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
        Application.Run "RunBuiltinParser_FromWorksheet", ActiveSheet
  • VBA macro-virus self-replication / AV tampering critical OLE_VBA_MACRO_VIRUS_REPLICATION
    VBA macro programmatically rewrites VBA project code through the VBE object model (CodeModule/VBComponents InsertLines/DeleteLines/AddFromString or OrganizerCopy) to copy itself into the global template and other open documents, and/or disables Office macro-virus protection (Options.VirusProtection = False). This is the defining behavior of the W97M document macro-virus family — self-replicating code with no benign document use, independent of any AV signature.
    Matched line in script
            CodeMod.AddFromString code$
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        AddinPath$ = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Parser.xla"
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
        With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  • cmd.exe reference in VBA high OLE_VBA_CMD
    cmd.exe reference in VBA
    Matched line in script
        Shell "Cmd.exe /c echo " & Chr(7), vbHide
  • 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
        With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Compiled VBA/cache stream contains an auto-execution token together with shell/download/object-execution tokens. This catches p-code-only or source-extraction-failure macro documents where visible source is unavailable.
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_Open()
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
            ResponseFilename$ = Environ("tmp") & "\response.txt"
  • Reference to CreateProcess API high SC_STR_CREATEPROCESS
    Reference to CreateProcess API
  • Suspicious cmd.exe invocation with execution flag high SC_STR_CMD
    Suspicious cmd.exe invocation with execution flag
  • Reference to Windows Script Host high SC_STR_WSCRIPT
    Reference to Windows Script Host
  • Clipboard command execution lure high SE_CLIPBOARD_COMMAND_LURE
    Document tells the user to copy or paste clipboard content into Run, PowerShell, cmd, or another shell-like execution context
  • Suspicious extracted artifact high EXTRACTED_FILE_STATIC_TRIAGE
    One or more files extracted from inside this sample matched static suspicious-content checks such as script obfuscation, encoded payload blobs, packed data, or execution/download terms.
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://ExcelVBA.ru/ Referenced by macro
    • http://excelvba.ru/programmes/ParserReferenced by macro
    • http://excelvba.ru/updates/download.php?addin=ParserReferenced by macro
    • http://excelvba.ru/programmes/Parser�Referenced by macro
    • http://excelvba.ru/programmes/Parser/manualsReferenced by macro
    • https://ExcelVBA.ru/programmes/Parser/actionsReferenced by macro
    • http://bbs.vbstreets.ru/viewtopic.php?p=6659672#p6659672Referenced by macro
    • http://ExcelVBA.ru/programmes/Parser/samples/testReferenced by macro
    • http://ExcelVBA.ru/themes/excelvba/parser.cssReferenced by macro
    • http://�ipv4.goReferenced by macro
    • http://ExcelVBA.ru/programmes/Parser/actions/Referenced by macro
    • http://excelvba.ru/programmes/Parser/manuals/ExtraSetupOptionsReferenced by macro
    • https://rucaptcha.com?from=2405413A@zReferenced by macro
    • http://ExcelVBA.ru/programmes/Parser/manuals/captcha/RuCaptchaSetupReferenced by macro
    • http://excelvba.ru/programmes/Parser/manuals/SpecialVariablesReferenced by macro
    • http://excelvba.ru/programmes/Parser/actions/Referenced by macro
    • http://excelvba.ru/programmes/Parser/order�Referenced by macro
    • http://excelvba.ru/programmes/Parser/manuals/errors/OutputArrayIntoCellReferenced by macro
    • http://ExcelVBA.ru/programmes/ParserReferenced by macro
    • http://ExcelVBA.ru�Referenced by macro
    • http://excelvba.ruReferenced by macro
    • http://site.ru)C@�Referenced by macro
    • http://ExcelVBA.ru/helpReferenced by macro
    • http://www.sql.ru/forum/actualutils.aspx?action=gotomsg&tid=1189047&msg=18526348BReferenced by macro
    • http://92.255.180.13:9001/QuestionImages/2105/6afadad0-32ed-4bd2-b362-f3773b9ee79d/1/1.jpgReferenced by macro
    • http://ExcelVBA.ru/sites/default/files/pixture_logo.pngReferenced by macro
    • http://www.nncron.ru/help/RU/add_info/regexp.htmReferenced by macro
    • http://excelvba.ru/programmesReferenced by macro
    • http://excelvba.ru/programmes/FillDocumentsReferenced by macro
    • http://xn--e1amhdlg6e.xn--p1ai/media/Referenced by macro
    • http://�������.��/media/Referenced by macro
    • http://�����������.���������.��/������Referenced by macro
    • http://xn--80aebe3cdmfdkg.xn--d1abbgf6aiiy.xn--p1ai/%D1%81%D0%BE%D0%B2%D0%B5%D1%82%D1%8BReferenced by macro
    • http://www.zhaojunpeng.com/posts/2016/10/28/excel-urldecodeReferenced by macro
    • http://vbaccelerator.comReferenced by macro
    • http://vbaccelerator.com/Referenced by macro
    • http://ExcelVBA.ru/resources/Parser/rt_editor.xlsReferenced by macro
    • http://www.cpearson.com/Excel/FormControl.aspxReferenced by macro
    • http://www.herber.de/forum/archiv/1192to1196/1192164_Punycode_Unicode.htmlReferenced by macro
    • http://�����������.���������.��/���������Referenced by macro
    • http://site.ru)�Referenced by macro
    • http://excelvba.ru/code/GreatestCommonDivisor�Referenced by macro
    • http://excelvba.ru/programmes/Parser/manuals/macroReferenced by macro
    • http://excelvba.ru/programmes/Parser/actions/LoadHTML_MultiThreadingReferenced by macro
    • http://my.jetscreenshot.com/28544/20161009-xeop-0kb.jpgReferenced by macro
    • http://rucaptcha.com/in.phpReferenced by macro
    • https://rucaptcha.com/res.php?key=Referenced by macro
    • http://rucaptcha.com/load.php?rnd=Referenced by macro
    • http://www.cyberforum.ru/visual-basic/thread903024.htmlReferenced by macro
    • http://excelvba.ru/updates/plugin.php?name=Referenced by macro
    +34 more URL(s)

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 4525633 bytes
SHA-256: 8e0a2fb8bbf01dfdcad70531581c4cdd6ac35801c666fc1e6f92c7492ed07d52
Detection
ClamAV: No threats found
Obfuscation or payload: likely
Carved artifact contains 1 eval/decoder/string-building token(s). Carved artifact contains 59 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
'---------------------------------------------------------------------------------------

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    RemoveItemsFromCellContextMenu
    If Not IE Is Nothing Then IE.Quit: Set IE = Nothing
    If Not wHTTP Is Nothing Then Set wHTTP = Nothing

    Close_All_Plugins
    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
    AddItemsIntoCellContextMenu
End Sub


Attribute VB_Name = "shm"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
'---------------------------------------------------------------------------------------
' Add-in        : Parser                    URL: http://excelvba.ru/programmes/Parser
'
' Author        : Igor Vakhnenko            Date: 24.01.2014
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/                     Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

#If VBA7 Then        '  Office 2010-2013
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
            (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, _
             ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
#Else        '  Office 2003-2007
    Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
                                               (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
                                                ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Sub RunBuiltinParser()
    On Error Resume Next
    If Not AddinStarted Then Exit Sub
    Application.Run "RunBuiltinParser_FromWorksheet", ActiveSheet
End Sub

Sub ShowBuiltinParser()
    On Error Resume Next
    If Not AddinStarted Then Exit Sub
    Application.Run "ShowBuiltinParser_FromWorksheet", ActiveSheet
End Sub

Function AddinStarted() As Boolean
    On Error Resume Next
    ' проверяем, запущена ли надстройка Parser
    test$ = Application.Run("ParserAddinTest")
    If Err.Number = 0 Then AddinStarted = True: Exit Function

    If Err.Number = 1004 Then        ' макрос не выполнен - надстройка не запущена
        ' читаем в реестре путь к файлу надстройки, пытаемся найти и запустить надстройку
        AddinPath$ = GetSetting("Parser", "Setup", "AddinPath", "")
        If FileExists(AddinPath$) Then
            Set WB = Workbooks.Open(AddinPath$)        ' пробуем открыть (запустить) надстройку
            t = Timer: Err.Raise 777
            While (Err > 0) And (Abs(Timer - t) < 6)
                Err.Clear: DoEvents: test$ = Application.Run("ParserAddinTest")        ' снова проверяем
            Wend
            If Err.Number = 0 Then AddinStarted = True: Exit Function
        End If
    End If

    ' надстройка не запустилась, не найдена, или какая-то другая проблема
    ttl$ = "Для работы этого файла необходима надстройка «Парсер сайтов»"
    msg$ = "Необходимая для работы этого файла надстройка «Parser» не найдена на вашем компьютере." & vbNewLine & vbNewLine & _
           "Скачать и запустить надстройку?"
    If MsgBox(msg, vbQuestion + vbOKCancel, ttl$) = vbCancel Then Exit Function

    URL$ = "http://excelvba.ru/updates/download.php?addin=Parser"
    AddinPath$ = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Parser.xla"

    Kill AddinPath$
    If URLDownloadToFile(0, URL$, AddinPath$, 0, 0) = 0 Then        ' надстройка успешно загружена
        If FileExists(AddinPath$) Then
            Workbooks.Open AddinPath$        ' пробуем открыть (запустить) надстройку
            Err.Clear: test$ = Application.Run("ParserAddinTest")        ' снова проверяем
            If Err.Number = 0 Then AddinStarted = True: Exit Function
        End If
    End If

    msg$ = "Не удалось скачать и запустить надстройку с сайта ExcelVBA.ru" & vbNewLine & _
           "(возможно, приложению Excel закрыт доступ в интернет)" & vbNewLine & vbNewLine & _
           "После нажатия кнопки ОК в этом сообщении, будет открыта страница программы," & vbNewLine & _
           "где вы сможете скачать надстройку «Parser» (после чего запустить её, и продолжить работу с этим файлом)"

    MsgBox msg$, vbExclamation, "При загрузке или запуске надстройки возникли проблемы"
    CreateObject("wscript.Shell").Run "http://excelvba.ru/programmes/Parser"
End Function

Private Function FileExists(ByVal Filename$) As Boolean
    On Error Resume Next: FileExists = CreateObject("Scripting.FileSystemObject").FileExists(Filename$)
End Function

Attribute VB_Name = "URLerrors"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "shtr"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
'---------------------------------------------------------------------------------------
' Author        : Igor Vakhnenko                   Date: 08.01.2016
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Const Prefix$ = "MENU"

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

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

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

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

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


Attribute VB_Name = "mod_CommonFunctions"
'---------------------------------------------------------------------------------------
' Module        : mod_CommonActions
' Author        : Igor Vakhnenko            Date: 11.11.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/                     Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Compare Text: Option Private Module

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

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

    On Error Resume Next
    ' устраняем возможные ошибки пользовательского ввода
    Const enARR$ = "ABCEHKMOPTX", ruARR$ = "АВСЕНКМОРТХ"
    Const cc& = 256        ' ограничение на максимальный номер столбца
    Dim i&, arr As Variant, j&, spl As Variant, cn&

    For i = 1 To Len(enARR$): txt = Replace(txt, Mid(ruARR$, i, 1), Mid(enARR$, i, 1)): Next i
    txt = Replace(txt, " ", ""): txt = Replace(txt, ";", ",")
    txt = Replace(txt, ":", "-"): txt = Replace(txt, ".", ","): txt = UCase(txt)
    For i = 1 To Len(txt)
        If Not Mid(txt, i, 1) Like "[A-Z0-9,-]" Then Mid(txt, i, 1) = ","
    Next i
    While InStr(1, txt, ",,"): txt = Replace(txt, ",,", ","): Wend
    While InStr(1, txt, "--"): txt = Replace(txt, "--", "-"): Wend
    txt = Replace(txt, ",-", ","): txt = Replace(txt, "-,", ",")
    If Left(txt, 1) = "-" Or Left(txt, 1) = "," Then txt = Mid(txt, 2)
    If Right(txt, 1) = "-" Or Right(txt, 1) = "," Then txt = Left(txt, Len(txt) - 1)
    norm1$ = Replace(txt$, ",", ", ")        ' возвращаем «нормализованную» строку для подстановки в поле

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

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

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

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

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

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

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

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

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

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

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

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

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

Function grv(ByVal n$)
    On Error Resume Next: With SETT: grv = .GetRegValue(.U(n$)): End With
End Function

Function GetResponse(ByRef BytesArr, ByVal Encoding$) As String
    On Error Resume Next
    Dim ResponseFilename$
    Set ADODBStream = CreateObject("ADODB.Stream")
    With ADODBStream
        ResponseFilename$ = Environ("tmp") & "\response.txt"
        If Len(Encoding$) Then .Charset = Encoding$
        .Type = 1        ' adTypeBinary:
        .Open: .Write BytesArr
        .SaveToFile ResponseFilename$, 2
        .Type = 2        'adTypeText
        .LoadFromFile ResponseFilename$
        GetResponse = .ReadText
        .Close
        Kill ResponseFilename$
    End With
    Set ADODBStream = Nothing
End Function

Function WEB_PARSERS_FOLDER$()
    WEB_PARSERS_FOLDER$ = "resources/" & PROJECT_NAME$ & "/samples"
End Function

Function IsURL(ByVal txt$, Optional ByVal AllowFileURL As Boolean) As Boolean
    On Error Resume Next
    IsURL = IsURL Or (txt$ Like "http://?*.?*")
    IsURL = IsURL Or (txt$ Like "https://?*.?*")
    IsURL = IsURL Or (txt$ Like "ftp://?*.?*")
    If AllowFileURL Then
        IsURL = IsURL Or (txt$ Like "\\?*\?*")
        IsURL = IsURL Or (txt$ Like "[A-Z]:\?*")
    End If
End Function


Function FileFormatByExtension(ByVal ext$) As XlFileFormat
    Select Case ext$
        Case "CSV", "DAT", "TXT": FileFormatByExtension = xlCSV
        Case "XLS": FileFormatByExtension = xlWorkbookNormal
        Case "XLSB": FileFormatByExtension = xlExcel12
        Case "XLSX": FileFormatByExtension = xlOpenXMLWorkbook
        Case "XLSM": FileFormatByExtension = xlOpenXMLWorkbookMacroEnabled
        Case Else: FileFormatByExtension = xlWorkbookNormal
    End Select
End Function

Function RemoveExtraSeparators(ByRef txt$, Optional ByVal sep$ = ARSEP)
    On Error Resume Next
    If sep$ = "" Then Exit Function
    Dim sep2$: sep2$ = sep$ & sep$
    While InStr(1, txt$, sep2$, vbBinaryCompare): txt$ = Replace(txt$, sep2$, sep$): Wend
    If txt$ Like "*" & sep$ Then txt = Left(txt, Len(txt) - Len(sep$))
    If txt$ Like sep$ & "*" Then txt = Mid(txt, Len(sep$) + 1)
End Function

Sub ExtendOrCollapseForm(ByRef CB As CommandButton)
    On Error Resume Next
    ' разворачивает\сворачивает форму по высоте
    Set UF = CB.Parent
    If UF Is Nothing Then Exit Sub
    'Dim zo&, k As Double: zo = SETT.GetNumber("ComboBox_Zoom", 100): If zo < 40 Then zo = 100

    ' в тэге формы прописана начальная и конечная высота, и скрываемые объекты:
    ' например: h=200-414 hide=Frame2,Frame4,Frame5
    txt_height$ = Split(Split(UF.tag)(0), "h=")(1)
    If Not txt_height Like "#*-*#" Then Exit Sub
    H1& = Split(txt_height, "-")(0)
    H2& = Split(txt_height, "-")(1)

    txt_hide$ = Split(Split(UF.tag)(1), "hide=")(1)
    arr_hide = Split(txt_hide, ",")


    Dim NormalMode As Boolean        ' TRUE, если лишнее на форме скрыто
    NormalMode = CB.Caption Like "* >>"

    NewHeight& = IIf(NormalMode, H2&, H1&)
    'k = Round(IIf(IIf(NormalMode, H1&, H2&) = UF.Height, zo / 100, 1), 2)

    ButtonsPositionBottom = UF.Height - CB.Top    '* k
    UF.Height = NewHeight&    ' * k

    For Each item In arr_hide
        UF.Controls(item).Visible = NormalMode
    Next

    For Each Button In UF.Controls
        If Button.Name Like "CommandButton*" Then
            If Button.HelpContextID = 2 Then
                Button.Top = UF.Height - ButtonsPositionBottom
            End If
        End If
    Next
    CB.Caption = CB.tag & " " & IIf(NormalMode, " <<", " >>")
    UF.Height = UF.Height
End Sub

Function ClearLinksErrors(ByVal txt$) As String
    On Error Resume Next
    txt$ = Replace(txt$, "=""about:blank", "=""")
    txt$ = Replace(txt$, "=""about:", "=""")
    ClearLinksErrors = txt$
End Function

Function GetTagInfoFromClipboard(Optional ByVal html$) As Variant
    On Error Resume Next
    ' ищет HTML-код в буфере обмена (или в переменной txt, если буфер обмена пуст)
    ' и возвращает массив с данными по первому найденному тегу, из 3 элементов:
    ' array(TagName, TagAttributeName, TagAttributeValue)
    ' Используется для быстрой вставки действия «Поиск HTML тегов»

    Dim txt$, tag As Variant, res$
    GetTagInfoFromClipboard = ""
    txt = shtr.clipBoardText
    If Len(txt) < 3 Then If Len(html$) Then txt = html
    If Len(txt) = 0 Then Exit Function

    txt = GetTags(txt, "Any tag", , , "TagHeaderOnly 1")
    For Each tag In Array("id", "name", "itemprop", "class")
        res = GetAttributeFromTag(txt, tag)
        If Len(res) Then GetTagInfoFromClipboard = Array(Mid(Split(txt)(0), 2), tag, res): Exit Function
    Next
    tag = "": tag = Split(Split(txt, " ")(1), "=")(0)
    If Len(tag) Then
        res = GetAttributeFromTag(txt, tag)
        If Len(res) Then GetTagInfoFromClipboard = Array(Mid(Split(txt)(0), 2), tag, res)
    End If
End Function

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

Option Compare Text: Option Private Module        ': Option Explicit
Public Const PROJECT_NAME$ = "Parser", 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, NeedToSelectParser As Boolean
    Application.ScreenUpdating = False
    If Not RefreshOnly Then Run DeleteOldCommandBar
    Set AddinMenu = GetCommandBar(PROJECT_NAME, True Or RefreshOnly)

    ' menu begin

    Set coll = FilenamesCollection(PARSERS_FOLDER$, "*" & PARSER_EXT$, 1)
    curr_WP_name$ = CURRENT_PARSER$

    Dim APs As WebsiteParsers, combo As CommandBarComboBox
    Set APs = AllParsers(True)        ' APs.LoadAllFromFolder
    If APs.Items.Count > 0 Then
        Mode& = IIf(APs.Items.Count = 1, msoComboNormal, msoComboLabel)
        ' Mode& = msoComboNormal
        Set combo = Add_Control(AddinMenu, ct_DROPDOWN, 0, "ChangeActiveParser_FromMenu", tt("MENU_Parser") & ": ", Mode&, True, "DFS_FromMenu")
        WP_arr = APs.ToArray
        For i = LBound(WP_arr) To UBound(WP_arr): combo.AddItem WP_arr(i): Next i
        For i = 1 To combo.ListCount
            If combo.list(i) = curr_WP_name$ Then combo.ListIndex = i: Exit For
        Next i
        NeedToSelectParser = combo.ListIndex = 0
        combo.OnAction = "'" & ThisWorkbook.Name & "'!ChangeActiveParser_FromMenu"

        If NeedToSelectParser = True And coll.Count = 1 Then
            curr_WP_name$ = WP_arr(1)
            CURRENT_PARSER$ curr_WP_name$
            combo.ListIndex = 1
            NeedToSelectParser = False
        End If
    End If

    If coll.Count Then
        ' 3021, 1075, 6280, 6522
        Add_Control(AddinMenu, ct_BUTTON, 0, "0", " ", msoButtonCaption, False).Enabled = 0

        If NeedToSelectParser Then
            Add_Control(AddinMenu, ct_BUTTON, 0, "0", tt("MENU_SelectParserOrCreateNewOne"), msoButtonCaption, True).Enabled = 0
        Else
            Set MainMacroButton = Add_Control(AddinMenu, ct_BUTTON, 6280, "StartParcing", tt("MENU_StartLoading"), msoButtonIconAndCaption, False)
            ' Add_Control AddinMenu, ct_BUTTON, 6280, "StartParcing", tt("MENU_StartLoading"), msoButtonIconAndCaption, False
            Add_Control(AddinMenu, ct_BUTTON, 0, "0", tt("MENU_or"), msoButtonCaption, False).Enabled = 0
            Add_Control AddinMenu, ct_BUTTON, 548, "EditActiveParser", tt("MENU_Configure"), msoButtonIconAndCaption, False
        End If
    Else
        Add_Control AddinMenu, ct_BUTTON, 548, "AddNewParser", tt("MENU_CreateAndConfigureNewParser"), msoButtonIconAndCaption, True
    End If


    Add_Control(AddinMenu, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, False).Enabled = 0
    Set subMenu2 = Add_Control(AddinMenu, ct_POPUP, 0, "", tt("MENU_ExtraSettings"), , True)

    Add_Control subMenu2, ct_BUTTON, 1664, "AddNewParser", tt("MENU_AddNewParser"), msoButtonIconAndCaption, True

    If coll.Count > 1 Then
        Set subMenu_PC = Add_Control(subMenu2, ct_POPUP, 548, "", tt("MENU_EditParser"), msoButtonIconAndCaption, False)
        If coll.Count > 25 Then
            stp& = 10
            For i& = 1 To coll.Count Step stp&
                i1& = i: i2& = Application.Min(i + stp& - 1, coll.Count)
                capt$ = tt("MENU_ParserDropdownPrefix") & " " & UCase(Left(Dir(coll(i1)), 1)) & " .. " & UCase(Left(Dir(coll(i2)), 1)) & "  (" & i2 - i1 + 1 & ")"
                Set subMenu_PC_ = Add_Control(subMenu_PC, ct_POPUP, 502, "", capt$, msoButtonIconAndCaption)
                For ind& = i1 To i2
                    Filename = Replace(Dir(coll(ind&)), PARSER_EXT$, "")
                    Add_Control subMenu_PC_, ct_BUTTON, 3885, "EditParser", Filename, msoButtonIconAndCaption, , coll(ind&)
                Next ind
            Next i
        Else
            For Each Filename In coll
                Add_Control subMenu_PC, ct_BUTTON, 3885, "EditParser", Replace(Dir(Filename), PARSER_EXT$, ""), msoButtonIconAndCaption, , Filename
            Next
        End If

        If Not NeedToSelectParser Then
            Add_Control subMenu2, ct_BUTTON, 3265, "DeleteActiveParser", tt("MENU_DeleteCurrentParser", curr_WP_name$), msoButtonIconAndCaption, True
        End If
    End If

    Add_Control subMenu2, ct_BUTTON, 222, "ShowSettingsPage", tt("MENU_CommonSettings"), msoButtonIconAndCaption, True
    Add_Control subMenu2, ct_BUTTON, 1759, "CreateProgramCommandBar", tt("MENU_refreshToolbar"), msoButtonIconAndCaption
    Add_Control subMenu2, ct_BUTTON, 1, "ShowParserDescriptionAtLocalhost", tt("MENU_ShowAlgorithm"), msoButtonIconAndCaption, True
    Add_Control subMenu2, ct_BUTTON, 543, "Edit_ReplaceTables", tt("MENU_ReplaceTables"), msoButtonIconAndCaption, True
    Add_Control subMenu2, ct_BUTTON, 0, "DeleteScheduledTasks", "Отменить все запланированные запуски парсера", msoButtonIconAndCaption, True
    RunWithDelay "LoadAllSettings", 10

    If SETT.GetBoolean("DeveloperMode") Then
        Add_Control subMenu2, ct_BUTTON, 0, "ShowActionsForm", "Показать список доступных действий", msoButtonIconAndCaption, True
        Add_Control subMenu2, ct_BUTTON, 0, "ShowTestActionsForm", "Тестировать новое действие", msoButtonIconAndCaption
        Add_Control subMenu2, ct_BUTTON, 0, "Toggle_ShowWebQuerySheet", "Показать / скрыть лист WebQuery", msoButtonIconAndCaption
        'If Developer Then Add_Control subMenu2, ct_BUTTON, 1, "ShowParserDescriptionAtWebsite", "Показать описание парсера на странице ExcelVBA.ru", msoButtonIconAndCaption
    End If
    Add_Control subMenu2, ct_BUTTON, 49, "OpenManual", "Открыть справку по программе", msoButtonIconAndCaption, True


    AddSettingsSwitcher AddinMenu, ct_DROPDOWN, , "StartParcing", MainMacroButton

    ' menu end
    ' Add3Buttons AddinMenu
    Add_Control(AddinMenu, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, False).Enabled = 0
    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


    If Not RefreshOnly Then
        RunWithDelay "ActivateAddinsTab"
        AddUpdateButton AddinMenu
        RunWithDelay "ActivateAddinsTab"
    End If

    If SETT.GetBoolean("DeveloperMode") Then
        Add_Control(AddinMenu, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, True).Enabled = 0
        Add_Control AddinMenu, ct_BUTTON, 1755, "SetActiveFolder", tt("MENU_SettingsFolderByActiveFile"), msoButtonIcon, True        ' 1660
        Add_Control AddinMenu, ct_BUTTON, 1668, "ResetActiveFolder", tt("MENU_SettingsFolderDefault"), msoButtonIcon, True
        Add_Control AddinMenu, ct_BUTTON, 3, "SaveToCurrentFolder", tt("MENU_SaveWorkbookToOpenedFolder"), msoButtonIcon, True
        Add_Control AddinMenu, ct_BUTTON, 793, "RunParserBySelection", tt("MENU_RunParserByActiveCell"), msoButtonIcon, True
    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 SaveDefaultSettings()
    On Error Resume Next
    With SETT
        .LoadAllSettings
        .AddDefaultValue "TextBox_ParsersFolder", Replace(DEFAULT_PARSERS_FOLDER$, ThisWorkbook.Path, ROOT_FOLDER_PREFIX$)
        .AddDefaultValue "FavouritesActions", "LoadHTML;GetTags;GetPagerLinks;GetHyperlinkAndText;TextBetween;CheckCondition;JoinArrayItems;SelectedArrayItems;ProgressIndicatorNew;SetVariable;GetVariable"
        .AddDefaultValue "TextBox_CacheFolder", DEFAULT_CACHE_FOLDER$
        .AddDefaultValue "TextBox_PluginFolder", Replace(DEFAULT_PLUGIN_FOLDER$, ThisWorkbook.Path, ROOT_FOLDER_PREFIX$)

        .AddDefaultValue "CheckBox_ScrollBalloonWindow", False
        .AddDefaultValue "ComboBox_MaxBalloons", 10
    End With

    With SETT
        .SetText "", "Parser.Settings", "HKCR\.xlp\"
        .SetText "Content Type", "text/xml", "HKCR\.xlp\"
        .SetText "PerceivedType", "text", "HKCR\.xlp\"
        .SetText "", "Файл настроек парсера", "HKCR\Parser.Settings\"
        .SetText "AlwaysShowExt", "", "HKCR\Parser.Settings\"
        .SetText "", "imageres.dll,109", "HKCR\Parser.Settings\DefaultIcon\"

        .SetText "", "Parser.ReplaceTable", "HKCR\.rt\"
        .SetText "Content Type", "text/xml", "HKCR\.rt\"
        .SetText "PerceivedType", "text", "HKCR\.rt\"
        .SetText "", "Таблица замен для парсера", "HKCR\Parser.ReplaceTable\"
        .SetText "", "shell32.dll,69", "HKCR\Parser.ReplaceTable\DefaultIcon\"
    End With
    SHChangeNotify &H8000000, 0, 0, 0    ' обновляем иконки файлов в Проводнике Windows
End Sub

Sub OpenManual()
    FWF.FollowHyperlink "http://excelvba.ru/programmes/Parser/manuals"
End Sub

Sub SettingSetChanged()
    RunWithDelay "CreateProgramCommandBar", 0.5
End Sub

Sub StartParcing()
    On Error Resume Next
    StopMacro = False
    RunActiveParser
End Sub

Sub UpdateAddinToolbar()
    RunWithDelay "CreateProgramCommandBar", 0.6
End Sub

Sub ShowActionsForm()
    On Error Resume Next
    FP_SelectAction.Show
End Sub

Sub ShowTestActionsForm()
    On Error Resume Next
    Set ActiveAAs = New ArrayActions
    CreateNewInstanceOfWinHttpRequest
    ActiveAAs.Load "TestActionsForm"
    With FP_ArrayActions_Edit
        .CommandButton_DeleteAllActions.Visible = True
        .Show
    End With
End Sub

Sub SetActiveFolder()
    On Error Resume Next
    Folder$ = ActiveWorkbook.Path
    If Folder$ = "" Then Folder$ = GetOpenedFolder

    If Folder$ = "" Then
        MsgBox "Необходимо открыть сохранённый файл, а потом нажимать кнопку", vbCritical
        Exit Sub
    End If

    CURRENT_XLP_FOLDER$ Folder$ & IIf(Right(Folder$, 1) = "\", "", "\")
    CreateNewInstanceOfWinHttpRequest
    UpdateAddinToolbar
End Sub

Sub EditParserBySelection()
    On Error Resume Next: Dim WP_name$
    WP_name$ = Trim(ActiveCell.EntireColumn.Cells(1)): If WP_name$ = "" Then Exit Sub
    If AllParsers(True).ParserExists(WP_name$) Then
        If WP_name$ <> CURRENT_PARSER$ Then
            CURRENT_PARSER$ WP_name$
            UpdateAddinToolbar
        End If
        AllParsers.GetActiveParser.Edit
    Else
        MsgBox "Парсер «" & WP_name$ & "» не найден!", vbCritical: Exit Sub
    End If
End Sub

Sub RunParserBySelection()
    On Error Resume Next: Dim WP_name$
    WP_name$ = Trim(ActiveCell.EntireColumn.Cells(1)): If WP_name$ = "" Then Exit Sub
    If AllParsers(True).ParserExists(WP_name$) Then
        If WP_name$ <> CURRENT_PARSER$ Then
            CURRENT_PARSER$ WP_name$
            RunWithDelay "CreateProgramCommandBar", 0.3
        End If
        RunWithDelay "RunActiveParser"
    Else
        MsgBox "Парсер «" & WP_name$ & "» не найден!", vbCritical: Exit Sub
    End If
End Sub
Sub ResetActiveFolder()
    CURRENT_XLP_FOLDER$ "-"
    CreateNewInstanceOfWinHttpRequest
    UpdateAddinToolbar
End Sub

Sub ChangeActiveParser_FromMenu()        ' срабатывает при изменении значения в комбобоксе или текстбоксе
    On Error Resume Next
    WP_name$ = Application.CommandBars.ActionControl.text
    If WP_name$ = CURRENT_PARSER$ Then Exit Sub
    CURRENT_PARSER$ WP_name$
    Set ParserVariables = Nothing
    CreateNewInstanceOfWinHttpRequest
    UpdateAddinToolbar
End Sub

Function GetFile_MainPicture() As String
    ' создаёт во временной папке файл, возвращает путь к созданному файлу
    On Error Resume Next: Dim F_TXT$, buf$, tmp_file$: Const BufLen& = 5000
    F_TXT$ = F_TXT$ & "424DB61500000000000036040000280000006E00000028000000010008000000000080110000465C0000465C0000000100000001000001560100D4F5E9006FD9A600C85A0F009A20060036CD6B00DFBBAB0016BC4F00AC877800DF934E0004B81900C4A39D005C9B1E00A08B3400C5784F006BEA9B00CF98700001A6090070B97A0049ED540047965000B9DFBA0061B67000A05D530087CA8900FCF5FA00207D2800E4E4E400AAA1A5002CB32100DC7A2600A6E9BD00FEBB6B00FD9D3700AA786700C4CDC900BA590F0034E37100C68A8400DADEDB0015D4530097E3B10060D7950049E0590009BE420004841400C6826E0091B690009AD19D00B8704000C5722C00EE9B5300AD4C2F0029A82F0061F56900DAFAF100C7806300EADFD300DF81330001BD380035924900A8D6AE0054B170008DE4AD005DE18C00CA9E8E0073BD8C00BCC2C700C4F1D30032E03F00BD817600D28A4A00FBB060008A953300C26D2400B44E09002E903A009AB7680046C2510092C89F0003760B0002A9370047AB2B005EDC7000C4BBBD004AE88400E6CCC60053BC4000F3EEED00CBE6DC000FDB2400AECCB300F0A35B00EB93450033DB4E0085E6BE00EC7C28009A6C610070C58400F28D2C00CD83420098F0CD0052DA8300ACEFD800A796920027D14000AEC4"
    F_TXT$ = F_TXT$ & "8400E2F2E200BD66250042C67200FAB1530016BE290082BA5D007CB7550077E18E009ECEA000059B330034C062005ED27800E0721A00E1AB8000F0FBF7004ED48000F5BF8A00A8C3A700F8EBDD00AC400900CADFD400AF9A88001BCB5200F1E7DA0036B73E00FFDC8000D3D4D300CE945F00779B2F00ECEDEC00C4B5AD00B77F3700079B0C00DA9B5F0006D41E0070DC9100E0B28D007AE4B600D9A37700BB61430093CE960051AE5F0080CEA2006CDC7D00BCA09400ECE6DC00FFCD7700C2663B00CE5A2300056A09008CDCAD008CECC40001C91C00A9938600DE8D460024D86000C97D3B001CA6220071DD8200E2C1BD009FDECB00DBA991000F923000D0823D00E8EBE50040DD7400CC968600C9CFD2006DD48F00BFF3E20004CB3C0014721900B4692F0041E67C00B45A4600D2722400BC9C800027B15600B3EACC0066BA8300BB6B5400FFFFFE0038BC4A005AF0640025C03200EFB1600031A43E002DD76500FBA0460098E6BF00E38B3D0045C08200BF806D00BE651A004AA55C0034DD6E00A33005007CDBA700CAE4C900AEB4B8005EED9300CA7A3400E3FBF40077CC940066A12D00D09A7C00B2DAB40060B67A0004640600CD854F003F9E57003DB04D009CBEAE0054C46300B6BCC00003C31D0053E88900CC8A620086DF940005CD"
    F_TXT$ = F_TXT$ & "430088DC8D00D5A89F00C5641600CB8B5600C2735C00E5EFE90014A92000DBF0DC00BB6E6800E7D8CA00CBEBD3000E9619001E9E2900C6753300D5B3AC00B6625B0088E0BC00F3F2F300D5DDDC00AEADAF003AAD4A009A913700AC883900BC623400D4F1D60071D17F00B5521A003A8F4200B5805C00BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBC19BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC0000BCBCBCBCBCBCF4272343AEAE1B58BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC3093303030303030303030303030303030303030303030303030303DD527F4F4BCBCBCBCBCBCBC0000BCBCBCBCBC58436808C7B70B54AEF588BCBCBCBCBCBCBCBCBCBC"
    F_TXT$ = F_TXT$ & "BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC27936B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B6B27CD3D184F851B88BCBCBCBCBC0000BCBCBCBCBCAEFF632121C35D471089AE1B58BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC1515BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC79D51823271BBCBCBCBC0000BCBCBCBC88D4636E7B7D19ABEC06E0E054AEF51BF5F5271B1B58BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC73EDBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCCD1885851BBCBCBC0000BCBCBCBCE83AC378BCBCBCBCBCBC88410E0E6868A0A0A0681CF643F558BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC8830BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC3D73278588BCBC0000BCBCBCBCEC77C306BCBCBCBC88AEF668465DC0C0C0C0C05C8C8608A0CE85F4BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC"
    F_TXT$ = F_TXT$ & "BCBCBCBCBCBCBCBCBCBCBC154F79D1D1D1D1D13737373737D1D1D1D1D1D1D1D1D1D1D1D137373737D179BCBCBC6B1885851BBCBC0000BCBCBCBC567733F1BCBCBC1BCE080E5C9984849999999999999999C08680DD1BBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC01F3CC02020202909090905F5F9E656565656565656565659E9E9E9E9EC46567B079BC93238527F4BC0000BCBCBCBCECE509D4F4BCF51C9A60209920484848485C5C484848209999C010F61BBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC67752C2C818181A2C2CACAB45555DFCFCF0F0F0F0F0FCFCF40DFDFDF666602C467013D5B2785F4BC0000BCBCBCBC1B030986271B689B6320485C335D09A1A1C5A1A10933338C5C204886F6E8BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC017A3B3BE2282828A2CA2525B45555DFCFCF0F0F0FCFCF40DF5555B4B4AC0505CC679D30277FF4BC0000BCBCBCBC199A3A860B1C9B21485C09094764D03232D03232D064470909098C5CE689F4BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC79CC073BE2E22828A2C22525B4B455DFDFCFCFCF"
    F_TXT$ = F_TXT$ & "CFCF40DF5555B425CACAAC05814067D28527BCBC0000BCBCBCBCBC2EE55C22923A48330947D8A33232E610D410E63232AA644747470909FFAEBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC67053BB1E228282828A2252525B4B4B4555555555555B4B4252525C2A2A2C2052CCCC42388BCBC0000BCBCBCBCBC06248CF0B63333A147D8AA3232D82E464646BB9A4A32D0A3A3AAA347AAB788BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC372A3B3BB1E2285EC2056D7A66402A720F0F0F0F8E40407A7A6D0575812828A281B8657F19BCBC0000BCBCBCBCBC58FA4A64AA09A1646464A34A6CBB0658F4F439C7FDC8C84A4A4A4A32D08A85BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC795F073BB1B128766242954F3D157FF5ABABABF57F235BDB4F424242752C2C81812CCC59BCBCBC0000BCBCBCBCBCBC1024F0A36464646464A3C83498BCBCBCBCBCBCB5FD6C6C6C32F0F0D02441BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC67053BE2B1816202954FDB3DD5CD7F59F5597FD5E372A5967676166D51513B073B2AB0BCBCBC0000BCBCBCBCBCBC39FD4AF0"
    F_TXT$ = F_TXT$ & "A3AA646464AA4BADBCBCBCBCBCBCBC06349292E7E7E7E7E792C7BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCD1023B3BB1C216C1F7DA9494161262181862125313BE363636453E3E51515151512A37BCBCBC0000BCBCBCBCBCBCBC382432D0A3646464AACB1CAE23AEAEAEAEAEAE54545454545454545423F4BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC6BBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC65073B3B7AD6508B8B8BA4351D83838335BF131313BE3645C1D6D651515151740279BCBCBC0000BCBCBCBCBCBCBC56FDC832D0A3A364A37E08080808A0A0A0A0A08080808080808080A0801BBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC6A4DCDBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC376D3B2C7695B250EFE9A4A435353535BF45451313BE2BA43EBA6207515174B8A7BCBCBCBC0000BCBCBCBCBCBCF4BC2E244AF0D0A36464A3AAC3C3C36E6E6E6E6E6E6E6E486E6E48C0486339BCBCBCBCBCBCBCBCBC8239393939393939394D0CD371D56BBCBCBCBCBCBCBCBCBCBCBCBC79903B2CAF9D940050EFA4A48B8BEE0A5A5A452B2B2BA4C9BABA42B85151A9C601BCBCBCBC0000BCBCBCBCBCBC851B9834E54AF0A3A3A3D03AC5C55D5D5D5D5D335C48482048204848203339BCBCBCBCBC"
    F_TXT$ = F_TXT$ & "BCBCBCBC868A8AF90DF84949498787D30C52571844BCBCBCBCBCBCBCBCBCBCBC6707079D9D29C9002D3535A48B118D5A5A5E2B2B83A93E4262426D5174A99579BCBCBCBC0000BCBCBCBCBCBCD40B79E4FD4A32D0A3D0A3D0D0D0D0D0D0D03AAA64A13333333333335DAA98BCBCBCBCBCBCBCBCBC868AF90D0D0D49498787D3D3D3521D1D6F2B1FBCBCBCBCBCBCBCBCBC377A75299D9D2914001AC1C1E99F8D8D5E2B2BBFEFC14CC9D2D23E2C5105B0BCBCBCBCBC0000BCBCBCBCBCBC913243F4386C4A32D0F0FAE7E0383838E0E0E0D8D0AA0909090909A11EF058BCBCBCBCBCBCBCBCBC868AF90D0D0D49498787D3D3D3521D1DBF2B1FBCBCBCBCBCBCBCBCBCBC5F761F292929C414001A35DE9F8D5E2B2B832D2D4CFE4CC9D28E075102D1BCBCBCBCBC0000BCBCBCBCBCBC06030E233992324AF04A040B56A6A6A6A6A6564124A34747474764AA030EBCBCBCBCBCBCBCBCBCBC8C8A8AF90DF84949498787D30C5257E3FBBCBCBCBCBCBCBCBCBCBCBCBCB09D1F1F1FC4C41FFE500A9F9F5E53534E50D79C9C509CB2423F070767BCBCBCBCBCBC0000BCBCBCBCBCBC394B77E0AEF1FA324A327E89BCBCBCBCBCBC79974BAA476464AAA3D07E2EBCBCBCBCBCBCBCBCBCBCAB82829898989898984D0CD3701579BCBCBCBCBCBCBCBCBCBCBCBCBC"
    F_TXT$ = F_TXT$ & "BC79ED1F1F1F1F1FB9AF0ADE9F695353DCEE509CD70000D7D63F3F6DC637BCBCBCBCBCBC0000BCBCBCBCBCBCBCBB2477E0AE41FA32320317231BF419F41B433403476464A3D032C8CBA6BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC6A4DECBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCE8B91F1F1F67CC0ADE9F69535376F72D2D501AD6D6D2C43F29AF5FBCBCBCBCBCBCBC0000BCBCBCBCBCBCBCE47EE577E6DD0892D0B60361DBDD43DD1C1703AA64A3A3F0324A7E3419BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC6BB91F443F0ADE9F699696A5DC94C92D2D50D99D3F3F3F299D44BCBCBCBCBCBCBC0000BCBCBCBCBCBCBC19347EE560E6F6229AD03A60312222FF9A600964A3D0F0326CC8CBE4BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC01B0296FDE9FB1A5A58EF7141616C92D2D503C959D3F3FB979BCBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCA6044BE51EA16822FAD0C52121C321C35DAAD0F03232C8C84BB519BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCED6F0A9F6FA572E14E50D7161612942D2D503C959D9D59BCBCBCBC"
    F_TXT$ = F_TXT$ & "BCBCBCBC0000BCBCBCBCBCBCBCBCBC26044B24B63A10226C32D0C55DA1AAF032324A6CC8C832B598BCF488BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC6BBF0A9F9FA5E13FDC5230009C121212942D2D503C5B7F6BBCBCBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBC467E3224E57764FFB34A323232324A4A6CC84AA3D8B5A6BCBC39F1BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC79BCE8830A9FDE963F29FC3523195B001A121262942D2D50141B8888BCBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBCBC26B5D8D8F09BB6B3C84A4A4A3232F0AA86100EBBECBCBCBC584119BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC796BBD0A0ADEA51F29E1352388ABBC7C001A421893162D509C147F6BBCBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBCBCBC06F238D491108C8C868C1091788F8F10E7AD58BCBCBCBCBC411BBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC79BC188B1111E94E834E355B19AB8888192F00B2FE4CFEB2D79CB24F6BBCBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBCBCBCBC580B462E26ADA8A8A8A841D42E"
    F_TXT$ = F_TXT$ & "464656BCBCBCBCBCBCBC4139BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC79F4F4D5933093181818D5F48888888888F47C2F2F2F2F2F2F7C27F4ED79BCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC39F10B412626410BEB041723F52788F4BCBCF41B4682BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC88F419BCBC19191919191988888888888888F419191919191919F4F4CDD1BCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC56B5342254AE85F5F55989E6BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC88F4F4F48888888888ABAB88881B1B1B881B1B1B1B1B1BABABAB88F4EDFBBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC563892FFAD8989418A06BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCE8888888888888F4F4F48888888888888888888888E8ABABEAFBFBFB44FBBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCAB06A8919178ECBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC"
    F_TXT$ = F_TXT$ & "BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC0000BCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC0000"
    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


'Sub ApplyZoomTo(ByRef UF)
'    On Error Resume Next
'    zo = SETT.GetNumber("ComboBox_Zoom", 100)
'    If zo < 40 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
'    ' Debug.Print UF.Zoom, UF.InsideHeight, UF.Height, UF.InsideWidth, UF.Width
'End Sub

Sub OnlineHelp(ByVal URL$, Optional ByVal CallerName As String)
    On Error Resume Next
    If URL$ = "" Then
        msg$ = "Справка для этого действия пока недоступна." & vbNewLine & vbNewLine & _
               "Вы можете найти нужную информацию самостоятельно, " & vbNewLine & _
               "посетив страницу программы на сайте ExcelVBA.ru" & vbNewLine & vbNewLine & _
               "Перейти на страницу программы «Парсер» в интернете?"
        If MsgBox(msg, vbInformation + vbOKCancel + vbDefaultButton2, "Справка по программе «Парсер»") = vbCancel Then
            Exit Sub
        Else
            URL$ = "programmes/Parser"
            URL$ = "http://ExcelVBA.ru/" & URL$
            ThisWorkbook.FollowHyperlink URL$
        End If
    Else
        URL$ = "http://ExcelVBA.ru/" & Split(URL$, "ExcelVBA.ru/")(0)
        FWF.FollowHyperlink URL$
    End If
End Sub

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

Sub AddItemsIntoCellContextMenu()
    On Error Resume Next
    With Application.CommandBars("cell")
        .Reset    ' сброс контекстного меню ячеек

        ' добавляем пункты в контекстное меню ячеек
        With .Controls.Add(1)
            .OnAction = "OpenCellHyperlink": .FaceId = 1018
            .Caption = "ПАРСЕР: Открыть гиперссылку в браузере"
        End With
        With .Controls.Add(1)
            .OnAction = "CopyCellHyperlink": .FaceId = 19
            .Caption = "ПАРСЕР: Копировать гиперссылку из ячейки"
        End With
    End With
End Sub

Sub RemoveItemsFromCellContextMenu()
    On Error Resume Next
    Application.CommandBars("cell").Reset
End Sub

Sub OpenCellHyperlink()
    On Error Resume Next: Dim hl$
    hl$ = GetCellHyperlinkAddress(ActiveCell)
    If IsURL(hl$, False) Then FWF.FollowHyperlink hl$
End Sub

Sub CopyCellHyperlink()
    On Error Resume Next: Dim hl$
    hl$ = GetCellHyperlinkAddress(ActiveCell)
    If IsURL(hl$, True) Then
        If WindowsClipboard_SetText(hl$) = 0 Then MsgBox "Не получилось скопировать ссылку", vbExclamation, "Нет доступа к буферу обмена Windows"
    End If
End Sub



Attribute VB_Name = "mod_Functions"
'---------------------------------------------------------------------------------------
' Module        : mod_Functions
' Author        : EducatedFool                     Date: 20.03.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/                     Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Explicit: Option Compare Text: Option Private Module

Function CreateAbsolutePathFromRelative(ByVal Filename$) As String
    On Error Resume Next
    Filename$ = Trim(Filename$): If Filename$ = "" Then Exit Function

    Select Case True
        Case Filename$ Like "[A-z]:\?*", Filename$ Like "\\?*\?*"
            CreateAbsolutePathFromRelative = Filename$
        Case Filename$ Like "\[!\]*"
            CreateAbsolutePathFromRelative = ThisWorkbook.Path & Filename$
        Case Filename$ Like "[!\]*"
            CreateAbsolutePathFromRelative = PARSERS_FOLDER & Filename$
    End Select
End Function

Function PasteImageIntoCell(ByRef cell As Range, Optional ByVal URL$, _
                            Optional AuthMode As Boolean = False, Optional ByRef WP As WebsiteParser) As Boolean
    On Error Resume Next
    'Dim cell As Range: Set cell = ActiveCell

    If URL$ = "" Then URL$ = cell.Value
    Dim Filename$, img_folder$, oStream As Object
    img_folder$ = FWF.temp_folder & "parser_images\": MkDir img_folder$
    Filename$ = img_folder$ & ConvertURLtoFilename(URL$)

    If Not FWF.FileExists(Filename$) Then


        If AuthMode Then
            ' выполняем запрос для получения файла
            With HTTP
                .Open "GET", URL$, True
                If WP.Options.UseClientCertificate Then .SetClientCertificate WP.Options.ClientCertificateName
                .SetTimeouts 3000, 3000, 3000, 5000

                .SetRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
                .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
                AddRequestHeadersFromStore
                If Not CookiesStore Is Nothing Then .SetRequestHeader "Cookie", GetCookiesFromStore
               
                .Send
                DoEvents
                Dim ResponseHeaders$, ResponseOK As Boolean

                If Not .WaitForResponse(4) Then
                    ResponseOK = False
                Else
                    ' проверяем заголовки ответа сервера
                    ResponseHeaders$ = .GetAllResponseHeaders
                    ResponseOK = Val(.Status) \ 100 = 2
                End If

                ' сохраняем ответ сервера в файл
                'Debug.Print .GetAllResponseHeaders

                If ResponseOK Then
                    Set oStream = CreateObject("ADODB.Stream")
                    oStream.Open
                    oStream.Type = 1
                    oStream.Write .ResponseBody
                    oStream.SaveToFile Filename$, 2        ' 1 = no overwrite, 2 = overwrite
                    oStream.Close
                    Set oStream = Nothing
                    ' Debug.Print "Downloading file with auth done: Len = " & Len(.ResponseText)
                Else
                    'Debug.Print "error downloading file using WinHTTP: Status = " & .Status
                    Exit Function
                End If
                'ShowText .GetAllResponseHeaders
            End With
        Else
            If Not FWF.DownLoadFileFromURL(URL$, Filename$) Then Exit Function
        End If
…

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