Malicious Office (OLE) — malware analysis report

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
' https://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
' https://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
' https://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 = "sh_actions"
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 = "Лист1"
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 = "mod_CommonFunctions"
'---------------------------------------------------------------------------------------
' Module        : mod_CommonActions
' Author        : Igor Vakhnenko            Date: 11.11.2013
' Professional application development for Microsoft Excel
' https://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 = 50 'xlExcel12
        Case "XLSX": FileFormatByExtension = 51 ' xlOpenXMLWorkbook
        Case "XLSM": FileFormatByExtension = 52 ' 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
' https://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, 1, "Compare2Strings", "Сравнение текста 2 ячеек", msoButtonIconAndCaption ', True
    Add_Control subMenu2, ct_BUTTON, 543, "Edit_ReplaceTables", tt("MENU_ReplaceTables") & " …", msoButtonIconAndCaption, True
    Add_Control subMenu2, ct_BUTTON, 461, "Edit_ResourceFiles", tt("MENU_ResourceFiles") & " …", 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
        
        Set subMenu2 = Add_Control(AddinMenu, ct_POPUP, 0, "", " ", , True)
        Add_Control subMenu2, ct_BUTTON, 793, "RunParserBySelection", tt("MENU_RunParserByActiveCell"), msoButtonIconAndCaption
        Add_Control subMenu2, ct_BUTTON, 0, "CleanHeader_PriceMonitoring", "Преобразовать ссылки в названия сайтов", msoButtonIconAndCaption, True
        Add_Control subMenu2, ct_BUTTON, 0, "RestoreHyperlinksStyle", "Восстановить стиль оформления гиперссылок", msoButtonIconAndCaption
        Add_Control subMenu2, ct_BUTTON, 0, "PM_CopyColumnsAndDeleteBlankCells", "Скопировать ссылки из выделенных столбцов на новый лист", msoButtonIconAndCaption
        
        arr = GetAllSettings(PROJECT_NAME$, "History")
        If IsArray(arr) Then
            Add_Control(subMenu2, ct_BUTTON, 0, "", "Последние использованные парсеры", msoButtonIconAndCaption, True).Enabled = 0
            For i = LBound(arr) To UBound(arr)
                HistoryItem$ = arr(i, 1)
                If HistoryItem$ Like "*:" Then
                    HistoryItem$ = Replace(HistoryItem$, ":", "")
                Else
                    HistoryItem$ = Replace(HistoryItem$, ":", "     из папки   ")
                End If
                Add_Control subMenu2, ct_BUTTON, 39, "ActivateParserFromHistory", HistoryItem$, msoButtonIconAndCaption, , arr(i, 1)
            Next i
        End If
        
    End If
    
    
    If Developer Then
        Add_Control(AddinMenu, ct_BUTTON, 0, "0", "  ", msoButtonIconAndCaption, False).Enabled = 0
        Set subMenuD = Add_Control(AddinMenu, ct_POPUP, 0, "", "Разработчик", , True)
        Add_Control subMenuD, ct_BUTTON, 12, "Parser_CreateDescription", "Сформировать описание парсера", msoButtonIconAndCaption, True
        Add_Control subMenuD, ct_BUTTON, 3, "Parser_ResaveResultExample", "Пересохранить файл результата под нужным именем", msoButtonIconAndCaption
        
        Add_Control(subMenuD, ct_BUTTON, 0, "0", "", msoButtonIconAndCaption, True).Enabled = 0
        'Add_Control subMenuD, ct_BUTTON, , "ShowFirstRunForm", "Show FirstRun Form", msoButtonIconAndCaption, True
        Add_Control subMenuD, ct_BUTTON, , "ToggleIsAddin", "Show/Hide TR Sheet", msoButtonIconAndCaption, True
        Add_Control subMenuD, ct_BUTTON, 11, "ShowBuiltInActionsEditor", "Редактор встроенных наборов действий", msoButtonIconAndCaption, True
        
        Add_Control subMenuD, ct_BUTTON, 0, "Pr_PM", "P - PM", msoButtonIconAndCaption, True
        Add_Control subMenuD, ct_BUTTON, 0, "Up_PM", "U - PM", msoButtonIconAndCaption
        Add_Control subMenuD, ct_BUTTON, 0, "PM_Clone", "Clone PM template", msoButtonIconAndCaption
    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$ = "https://ExcelVBA.ru/programmes/Parser/manuals" & URL$
            ThisWorkbook.FollowHyperlink URL$
        End If
    Else
        URL$ = "https://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 ShowBuiltInActionsEditor()
    On Error Resume Next
    With F_ActionSetEditor
        Set .SourceSheet = sh_actions
        .Initialize
        .Show
    End With
End Sub

Sub AddItemsIntoCellContextMenu()
    On Error Resume Next
    For Each menu In ContextMenuList
        With Application.CommandBars(menu)
            .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
    Next menu
End Sub

Sub RemoveItemsFromCellContextMenu()
    On Error Resume Next
    For Each menu In ContextMenuList
        Application.CommandBars(menu).Reset
    Next menu
End Sub

Function ContextMenuList() As Variant
    ContextMenuList = Array("Cell", "List Range Popup")
End Function

Sub OpenCellHyperlink()
    On Error Resume Next
    Dim hl$, coll As New Collection, msg$, cell As Range, link, i&, cellValue$
    For Each cell In Intersect(ActiveSheet.UsedRange, Selection).Cells
        If Len(cell) Then
            hl$ = "": hl$ = GetCellHyperlinkAddress(cell, True)
            
            ' дописываем к ссылке цену из ячейки, если настраивается мониторинг цен
            If Dir(PARSERS_FOLDER$ & "*ВСЕ САЙТЫ*.xlp", vbNormal) <> "" Then
                cellValue$ = cell.Value
                If Val(cellValue$) = 0 Then cellValue$ = ""
                If Len(cellValue$) Then hl$ = Process_URL_Parameter(hl$, "set", "FOUND_PRICE", cellValue$)
            End If
            
            For i = 1 To 2000
                DoEvents
            Next
            If IsURL(hl$, False) Then coll.Add hl$
            If coll.Count > 20 Then Exit For
        End If
    Next cell
    
    If coll.Count > 6 Then
        msg$ = "Уверены, что хотите открыть в браузере сразу " & coll.Count & " ссылок?"
        If MsgBox(msg$, vbDefaultButton2 + vbOKCancel) = vbCancel Then Exit Sub
    End If
    
    For Each link In coll
        FWF.FollowHyperlink link
…