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
'---------------------------------------------------------------------------------------
' Module        : ThisWB
' Author        : Игорь                     Date: 21.11.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Explicit

'Public WithEvents testHTTP As WinHttpRequest

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

    auto_closeX
End Sub

Private Sub Workbook_Open()
    auto_openX
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        : Игорь                     Date: 24.01.2014
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           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 (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/php/download-last-version.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 = "mod_About"
'---------------------------------------------------------------------------------------
' Module        : mod_About
' Author        : Игорь                     Date: 22.10.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Private Module
Option Compare Text
Public Const VERSIONS_XML_FILENAME$ = "info.xml", DEMO_ACTIVATION_CODE$ = "demo", MODULE_VERSION = 17
Public IAEC As Long, LIAT As Date: Public Const DEBUG_MODE As Boolean = False        'True
Public UseTempSettings As Boolean, TempSettingsCollection As New Collection

' список допустимых элементов управления на пользовательской панели инструментов
Public Enum CONTROL_TYPES
    ct_BUTTON = msoControlButton: ct_TEXTBOX = msoControlEdit: ct_COMBOBOX = msoControlComboBox
    ct_DROPDOWN = msoControlDropdown: ct_POPUP = msoControlPopup
End Enum

Private Sub ShowMainForm()        ' запуск формы "О программе"
    On Error Resume Next: F_About.Show
    F_About.MultiPage1.Value = 0
End Sub

Sub ShowSettingsPage()        ' запуск формы "НАСТРОЙКИ"
    On Error Resume Next: F_Settings.Show
End Sub

Sub ShowGreeting()        ' запуск формы "ИНСТРУКЦИИ по работе с программой"
    On Error Resume Next:
    If IsObject(F_Greeting) Then
        ND "run test", "Запуск из меню программы" & vbLf & CountersCurrentValues
        F_Greeting.Show
    End If
End Sub

Function Settings(ByVal SettingName, Optional ByVal DefValue As Variant) As Variant
    On Error Resume Next
    Settings = GetSetting(PROJECT_NAME$, "Settings", SettingName, DefValue)
    If UseTempSettings Then
        Err.Clear: res = TempSettingsCollection(CStr(SettingName))
        If Err = 0 Then Settings = res
    End If
End Function

Function SettingsBoolean(ByVal SettingName, Optional ByVal DefValue As Boolean = False) As Boolean
    On Error Resume Next
    SettingsBoolean = CBool(GetSetting(PROJECT_NAME$, "Settings", SettingName, DefValue))
    If UseTempSettings Then
        Err.Clear: res = TempSettingsCollection(CStr(SettingName))
        If Err = 0 Then SettingsBoolean = CBool(res)
    End If
End Function


Function ImportSettings(Optional ByVal xmlpath$ = "") As Boolean
    On Error Resume Next: Err.Clear
    If xmlpath$ = "" Then
        xmlpath$ = FWF.GetFilePath("Выберите файл, содержащий настройки программы " & PROJECT_NAME$ & " для импорта", _
                                   ThisWorkbook.Path, "Настройки программы " & PROJECT_NAME$, "*.xml")
    End If
    If xmlpath$ = "" Then Exit Function

    ' Dim xml As Object, rootnode As IXMLDOMElement, XMLoptions As IXMLDOMNodeList, XMLoption As IXMLDOMElement
    Set xml = CreateObject("Microsoft.XMLDOM")
    With xml
        If Not .Load(xmlpath) Then
            MsgBox "Не удалось загрузить настройки из файла", vbCritical, "Неподдерживаемый формат файла, или ошибка в структуре XML": Exit Function
        End If
        Set rootnode = .DocumentElement
        AddinName$ = rootnode.Attributes.getNamedItem("Addin").Text
        AddinVersion$ = Val(rootnode.SelectSingleNode("Version").Text)

        Select Case True
            Case rootnode.BaseName <> "Settings", AddinName$ = ""
                MsgBox "Не удалось загрузить настройки из файла", vbCritical, "Неподдерживаемый формат файла": Exit Function
            Case AddinName$ <> PROJECT_NAME$
                msg$ = "В выбранном вами файле содержатся настройки для программы «" & AddinName$ & "»" & vbNewLine & vbNewLine & _
                       "Для программы " & PROJECT_NAME$ & " эти настройки не подойдут."
                MsgBox msg$, vbCritical, "Неподдерживаемый формат файла": Exit Function
            Case Else



                Set XMLoptions = rootnode.SelectNodes("./Options/option")
                If XMLoptions.Length = 0 Then
                    MsgBox "В выбранном вами файле отсутствуют сохранённые настройки", vbExclamation, "Изменения в настройки программы не внесены"
                    Exit Function
                End If

                Dim nNEW&, nOLD&, nCHANGED&, nALL&, nERR&

                nALL& = XMLoptions.Length: Const N_S_E$ = "%%no such entry%%"
                For Each XMLoption In XMLoptions
                    Name$ = XMLoption.Attributes.getNamedItem("Name").Text
                    txt$ = XMLoption.Attributes.getNamedItem("Value").Text
                    If Len(txt) Mod 2 = 0 Then
                        v$ = ""
                        For i = 1 To Len(txt) / 2
                            v$ = v$ & Chr(Val("&H" & Mid(txt, 2 * i - 1, 2)))
                        Next
                        Select Case Settings(Name$, N_S_E$)
                            Case N_S_E$
                                nNEW& = nNEW& + 1
                            Case v$
                                nOLD& = nOLD& + 1
                            Case Else
                                nCHANGED& = nCHANGED& + 1
                        End Select
                        SETT.SetText Name$, v$
                    Else
                        nERR& = nERR& + 1
                    End If
                Next

                msg$ = "Импорт настроек завершён." & vbNewLine & vbNewLine & _
                     " - " & "Загружено настроек из файла: " & nALL& & vbNewLine & _
                     " - " & "Добавлено новых значений: " & nNEW& & vbNewLine & _
                     " - " & "Заменено существующих значений: " & nCHANGED& & vbNewLine & _
                     " - " & "Осталось без изменения: " & nOLD& & vbNewLine
                If nERR& Then msg$ = msg$ & " - " & "Ошибок: " & nERR& & vbNewLine
                msg$ = msg$ & vbNewLine & "Новые настройки уже используются программой."

                If GetVersion < Val(AddinVersion$) And Val(AddinVersion$) > 0 Then
                    msg$ = msg$ & vbNewLine & vbNewLine & vbNewLine & "ВНИМАНИЕ: Версия программы, из которой были взяты настройки (" & GetVersionTXT(AddinVersion$) & ")," & vbNewLine & _
                         "                     НЕ СОВПАДАЕТ с используемой версией программы (" & GetVersionTXT & ")" & vbNewLine & _
                           "В связи с этим, возможно, программа будет работать некорректно" & vbNewLine & _
                           "(проверьте, все ли необходимые настройки загружены, и обновите программу до последней версии)"
                End If
                MsgBox msg, vbInformation, "Импорт настроек программы " & PROJECT_NAME$ & " завершен."
                ImportSettings = True
        End Select
    End With
End Function

Sub ExportSettings()
    On Error Resume Next: Err.Clear
    filename$ = ThisWorkbook.Path & "\Настройки " & PROJECT_NAME$ & " " & Format(Now, "DD.MM.YYYY HH-NN-SS") & ".xml"

    Title$ = "Сохранение всех настроек программы " & PROJECT_NAME$ & " в файл - выберите имя файла и папку"

    prevDir$ = CurDir$
    ChDrive Left(filename$, 1)
    ChDir ThisWorkbook.Path

    xmlpath = Application.GetSaveAsFilename(filename$, "Настройки программы " & PROJECT_NAME$ & " (*.xml),", , Title$, "Сохранить")
    If VarType(xmlpath) = vbBoolean Then GoTo ExitLabel

    arr = GetAllSettings(PROJECT_NAME$, "Settings")



    Set xml = CreateObject("Microsoft.XMLDOM")
    With xml
        .appendChild .createProcessingInstruction("xml", "version='1.0' encoding='utf-8'")

        ' ============== rootnode ===============
        Set rootnode = .appendChild(.createElement("Settings"))
        rootnode.Attributes.setNamedItem(.createAttribute("Addin")).Text = PROJECT_NAME$
        rootnode.Attributes.setNamedItem(.createAttribute("VersionName")).Text = GetVersionTXT

        rootnode.appendChild(.createComment("URL")).Text = Split(PROGRAM_HYPERLINK$, "?")(0)
        rootnode.appendChild(.createElement("Version")).Text = GetVersion
        rootnode.appendChild(.createElement("Filename")).Text = ThisWorkbook.Name
        rootnode.appendChild(.createElement("ID")).Text = HID
        rootnode.appendChild(.createElement("TimeStamp")).Text = Now
        With rootnode.appendChild(xml.createElement("Updates"))
            .Attributes.setNamedItem(xml.createAttribute("Install")).Text = CBool(Val(RSP(5)))
            .Attributes.setNamedItem(xml.createAttribute("StableOnly")).Text = CBool(Val(RSP(6)))
        End With

        If IsArray(arr) Then
            With rootnode.appendChild(xml.createElement("Options"))
                .appendChild(xml.createComment("Help")).Text = "All the values in this XML are stored as a HEX representation of the text data." & vbNewLine & _
                                                               "Each character of the value is converted into 2 characters, using the Hex(Asc(<character>)) function." & vbNewLine & _
                                                               "Please change program options using user interface only! (do not edit this XML file manually)" & vbNewLine & _
                                                               "These settings are stored in the registry: HKEY_CURRENT_USER\Software\VB and VBA Program Settings\" & PROJECT_NAME$ & "\Settings"
                For i = LBound(arr) To UBound(arr)
                    v$ = ""
                    For j = 1 To Len(arr(i, 1))
                        v$ = v$ & IIf(Len(Hex(Asc(Mid(arr(i, 1), j, 1)))) = 1, "0", "") & Hex(Asc(Mid(arr(i, 1), j, 1)))
                    Next j

                    With .appendChild(xml.createElement("option"))
                        .Attributes.setNamedItem(xml.createAttribute("Name")).Text = arr(i, 0)
                        .Attributes.setNamedItem(xml.createAttribute("Value")).Text = v$
                    End With
                Next i
                .appendChild(xml.createComment("Help")).Text = "Any questions? Contact me via Skype (ExcelVBA.ru), ICQ (5836318) or E-mail (info@ExcelVBA.ru)"
            End With
        Else
            MsgBox "Надстройки для программы " & PROJECT_NAME$ & " ещё не были сохранены." & vbNewLine & vbNewLine & _
                   "Сохраните настройки программы, а затем уже экспортируйте их в файл.", vbExclamation, "Настройки не найдены"
            GoTo ExitLabel
        End If
        If Len(xmlpath) > 0 Then .Save xmlpath
    End With

    MsgBox "Файл настроек программы " & PROJECT_NAME$ & " успешно сохранён." & vbNewLine & vbNewLine & _
           "Теперь вы можете применить эти настройки на других компьютерах, " & vbNewLine & _
           "нажав кнопку «Импорт настроек из файла»." & vbNewLine & vbNewLine & _
           "Созданный файл настроек доступен по пути" & vbNewLine & xmlpath, vbInformation, "Экспорт настроек в файл завершен."

ExitLabel:
    ChDrive Left(prevDir$, 1)
    ChDir prevDir$
End Sub


Sub auto_openX()
    On Error Resume Next
    Enable_AccessVBOM_Macro_DataConnections        ' чтобы отключить лишние уведомления при запуске
    Application.Run "'" & ThisWorkbook.Name & "'!Addin_Open"
    If IsFirstRun Then
        SetValuesOnFirstRun
        Application.Run "'" & ThisWorkbook.Name & "'!Addin_FirstRun"
        If IsObject(F_Greeting) Then
            ND "run test", "Знакомство с программой" & vbLf & CountersCurrentValues
            F_Greeting.Show
        End If
    Else
        ND "addin open", CountersCurrentValues
        If VER_ <> GetVersion Then
            Application.Run "'" & ThisWorkbook.Name & "'!Addin_AfterUpdate"
        End If
    End If
    VER_ GetVersion
    a = vbCheck: Dim msg$
    If PL_(msg, True) Then CreateProgramCommandBar: Exit Sub
    UpdatesInfo_$ " "
    Application.OnTime Now + TimeSerial(0, 0, 5), "AutoInstallUpdate"
    Application.OnTime Now + TimeSerial(0, 0, 8), "PIBL"
    CreateProgramCommandBar        ' создание панели инструментов
    Application.Run "'" & ThisWorkbook.Name & "'!Addin_Start"
End Sub

Sub auto_closeX()
    On Error Resume Next
    Application.Run Application.Run("'" & ThisWorkbook.Name & "'!Addin_Close")
    ND "addin close with Excel", CountersCurrentValues
    DeleteProgramCommandBar
End Sub

Function DEVELOPER_WEBSITE$()
    DEVELOPER_WEBSITE$ = "http://ExcelVBA.ru/"
End Function
Function UPDATE_VERSIONS_XML$()
    UPDATE_VERSIONS_XML$ = UPDATE_FOLDER$ & VERSIONS_XML_FILENAME$
End Function
Function UPDATE_FOLDER$()
    UPDATE_FOLDER$ = DEVELOPER_WEBSITE$ & "updates/" & PROJECT_NAME$ & "/"
End Function
Function VERSIONS_INFO_LOCAL_XML_PATH$()
    VERSIONS_INFO_LOCAL_XML_PATH$ = Environ("TEMP") & "\" & PROJECT_NAME$ & "_" & VERSIONS_XML_FILENAME$
End Function
Function PROJECT_FULLNAME$()
    PROJECT_FULLNAME$ = ThisWorkbook.BuiltinDocumentProperties("Title")
End Function
Function REG_HYPERLINK$()
    REG_HYPERLINK$ = DEVELOPER_WEBSITE$ & "buy/program?name=" & PROJECT_NAME$ & "&HID=" & HID$
End Function
Function UNINSTALL_HYPERLINK$()
    UNINSTALL_HYPERLINK$ = DEVELOPER_WEBSITE$ & "uninstall/program?name=" & PROJECT_NAME$ & "&HID=" & HID$
End Function
Function NOTIFICATION_HYPERLINK$()
    NOTIFICATION_HYPERLINK$ = DEVELOPER_WEBSITE$ & "php/notification.php?name=" & PROJECT_NAME$ & "&HID=" & HID$
End Function
Function PROGRAM_HYPERLINK$()
    PROGRAM_HYPERLINK$ = DEVELOPER_WEBSITE$ & "programmes/" & PROJECT_NAME$ & "?ref=" & HID$
End Function
Function SERIAL_NUMBER_HYPERLINK$()
    SERIAL_NUMBER_HYPERLINK$ = DEVELOPER_WEBSITE$ & "php/get-serial2.php"
End Function
Function BL_HYPERLINK$()
    BL_HYPERLINK$ = DEVELOPER_WEBSITE$ & "php/bl.php"
End Function
Function EULA_HYPERLINK$()
    EULA_HYPERLINK$ = DEVELOPER_WEBSITE$ & "buy/EULA?name=" & PROJECT_NAME$ & "&HID=" & HID$
End Function
Function BREACH_EULA_HYPERLINK$()
    BREACH_EULA_HYPERLINK$ = DEVELOPER_WEBSITE$ & "buy/EULA/breach?name=" & PROJECT_NAME$ & "&HID=" & HID$
End Function

Function HID$(): On Error Resume Next

    SN& = CreateObject(ChrW(115) & ChrW(99) & ChrW(114) & ChrW(105) & ChrW(112) & ChrW(116) & ChrW(105) & ChrW(110) & ChrW(103) & ChrW(46) & ChrW(102) & ChrW(105) & ChrW(108) & ChrW(101) & ChrW(115) & _
                       ChrW(121) & ChrW(115) & ChrW(116) & ChrW(101) & ChrW(109) & ChrW(111) & ChrW(98) & ChrW(106) & ChrW(101) & ChrW(99) & ChrW(116)).GetDrive(ChrW(99) & ChrW(58)).SerialNumber
    HID$ = ChrW(115) & Format(Abs(934526875# - SN&), "0000000000")
End Function
Function PROJECT_NAME$(): On Error Resume Next: PROJECT_NAME$ = Split(ThisWorkbook.Names("PROJECT_NAME").RefersTo, "%%")(1): End Function
Function ND(ByVal Action$, Optional ByVal comment$) As Boolean
    On Error Resume Next
    If Not InternetConnected Then Exit Function
    comment$ = Replace(comment$, "«", """"): comment$ = Replace(comment$, "»", """")
    Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    xmlhttp.Open "POST", NOTIFICATION_HYPERLINK$, True
    xmlhttp.SetRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"        ' чтобы избежать кеширования
    Dim POST() As Byte, PostData$
    Login$ = CreateObject("WScript.Network").UserName
    Domain$ = CreateObject("WScript.Network").UserDomain
    PostData = PostData & "email=" & RussianStringToURLEncode(RE_$)
    PostData = PostData & "&code=" & RussianStringToURLEncode(AC_$)
    PostData = PostData & "&addin=" & RussianStringToURLEncode(PROJECT_NAME$)
    PostData = PostData & "&HID=" & RussianStringToURLEncode(HID)
    PostData = PostData & "&host_time=" & RussianStringToURLEncode(Format(Now, "YYYY-MM-DD HH:NN:SS"))
    PostData = PostData & "&win_un=" & RussianStringToURLEncode(Login$)
    PostData = PostData & "&win_ud=" & RussianStringToURLEncode(Domain$)
    PostData = PostData & "&action=" & RussianStringToURLEncode(Action$)
    PostData = PostData & "&comment=" & RussianStringToURLEncode(comment$)
    POST = StrConv(PostData, vbFromUnicode)
    xmlhttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xmlhttp.Send (POST): DoEvents
    StatusText = xmlhttp.StatusText
    StatusCode = Val(xmlhttp.Status)
    response$ = xmlhttp.ResponseText
    Set xmlhttp = Nothing
    'Debug.Print Now, statusTEXT, response$, StatusCode

    ND = True
    Select Case StatusCode
        Case 201, 202
            If DEBUG_MODE Then Debug.Print Now, response$
            Code$ = StatusText
        Case 401, 413
            msg = response$
            If DEBUG_MODE Then Debug.Print Now, StatusText
        Case Else
    End Select
End Function

Sub EXECUTE_COMMANDS(ByVal txt$)
    On Error Resume Next
    Dim msgboxStyle As VbMsgBoxStyle: commands = Split(txt$, "ll")
    For i = LBound(commands) To UBound(commands)
        cmd$ = "": arr = "": cmd$ = cmdDisplay$(commands(i))

        arr = Split(cmd$, " ")
        For j = LBound(arr) To UBound(arr): arr(j) = Replace(arr(j), "%20", " "): Next j
        If TrueDeveloper Then
            Debug.Print cmd$
            Select Case arr(0)
                Case "RUN"
                    MsgBox "'" & ThisWorkbook.Name & "'!" & arr(1), vbInformation, "RUN"
                Case "SERIAL"
                    ValidateAC arr(1)
                    RE_$ arr(2)
                Case "MSG", "MSGE", "MSGI", "MSGW", "MSGC"
                    msgboxStyle = vbInformation
                    If arr(0) = "MSGE" Then msgboxStyle = vbExclamation
                    If arr(0) = "MSGW" Or arr(0) = "MSGC" Then msgboxStyle = vbCritical
                    msg$ = "": msg$ = Replace(Split(cmd$, " ", 2)(1), "/n", vbNewLine)
                    If Len(msg) Then MsgBox msg, msgboxStyle, "Сообщение от разработчика программы"
                Case Else        ' unsupported command
                    MsgBox "unsupported command: " & cmd$, vbExclamation
            End Select
        Else
            ND "command execute", "command: " & Split(cmd$, vbNewLine)(0)
            Select Case arr(0)
                    'Case "SET"
                Case "RUN"
                    MacroName$ = "'" & ThisWorkbook.Name & "'!" & arr(1)
                    Select Case UBound(arr)
                        Case 1: Application.Run MacroName$
                        Case 2: Application.Run MacroName$, arr(2)
                        Case 3: Application.Run MacroName$, arr(2), arr(3)
                        Case 4: Application.Run MacroName$, arr(2), arr(3), arr(4)
                    End Select
                Case "SERIAL"
                    ValidateAC arr(1)
                    RE_$ arr(2)
                Case "MSG", "MSGE", "MSGI", "MSGW", "MSGC"

                    msgboxStyle = vbInformation
                    If arr(0) = "MSGE" Then msgboxStyle = vbExclamation
                    If arr(0) = "MSGW" Or arr(0) = "MSGC" Then msgboxStyle = vbCritical
                    msg$ = "": msg$ = Replace(Split(cmd$, " ", 2)(1), "/n", vbNewLine)
                    If Len(msg) Then MsgBox msg, msgboxStyle, "Сообщение от разработчика программы"
                Case Else        ' unsupported command
                    ND "command error", "unsupported command: " & cmd$
            End Select
        End If
    Next i
End Sub
Function GSNUE_(ByVal Email$, ByRef msg$) As Boolean        ' new version
    On Error Resume Next
    Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
    xmlhttp.Open "POST", SERIAL_NUMBER_HYPERLINK$, False
    xmlhttp.SetRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
    Dim POST() As Byte, PostData$, msg2$
    Login$ = CreateObject("WScript.Network").UserName
    Domain$ = CreateObject("WScript.Network").UserDomain
    PostData = PostData & "email=" & RussianStringToURLEncode(Email$)
    PostData = PostData & "&addin=" & RussianStringToURLEncode(PROJECT_NAME$)
    PostData = PostData & "&HID=" & RussianStringToURLEncode(HID)
    PostData = PostData & "&host_time=" & RussianStringToURLEncode(Format(Now, "YYYY-MM-DD HH:NN:SS"))
    PostData = PostData & "&win_un=" & RussianStringToURLEncode(Login$)
    PostData = PostData & "&win_ud=" & RussianStringToURLEncode(Domain$)
    POST = StrConv(PostData, vbFromUnicode)
    xmlhttp.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xmlhttp.Send (POST): DoEvents
    StatusText = xmlhttp.StatusText
    StatusCode = Val(xmlhttp.Status)
    response$ = xmlhttp.ResponseText
    Set xmlhttp = Nothing

    If response$ Like "%*%" Then GSNUE_ = True: EXECUTE_COMMANDS Split(response$, "%")(1)
    ND "serial by email", "HTTP " & StatusCode & ", Email=" & Email$
End Function

Function RussianStringToURLEncode(ByVal txt As String) As String
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        Select Case AscW(l)
            Case Is > 256: t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
            Case 32: t = "+"
            Case Else: t = l
        End Select
        RussianStringToURLEncode = RussianStringToURLEncode & t
    Next
End Function
Function GetVersion() As Long
    Application.Volatile True
    On Error Resume Next: ver& = Val(ThisWorkbook.BuiltinDocumentProperties("Revision Number"))
    GetVersion = IIf(Val(ver&) < 1000, 1009, ver&)
End Function

Function GetVersionTXT(Optional ByVal ver& = 0)
    On Error Resume Next
    If ver& = 0 Then ver& = Val(ThisWorkbook.BuiltinDocumentProperties("Revision Number")): If ver& = 0 Then ver& = 1009
    vArr = Array("", " Alfa", " Beta", " RC", " RC2", " RC3", " RC4", " RC5", " RC6"): verType$ = vArr(ver& Mod 10)
    GetVersionTXT = ver& \ 1000 & "." & Right(ver& \ 100, 1) & "." & Right(ver& \ 10, 1) & verType$
End Function
Sub SetVersion(ByVal n As Long)
    On Error Resume Next: If n < 1000 Then n = 1009
    If n Mod 10 = 0 Then n = n + 9
    ThisWorkbook.BuiltinDocumentProperties("Revision Number") = n
    ThisWorkbook.BuiltinDocumentProperties("Creation Date") = Now
End Sub
Function sss() As Long: CounterUpdate 2: sss = 0: End Function
Function mmm() As Long: CounterUpdate 2: mmm = 1: End Function
Function bbb() As Boolean: CounterUpdate 2: bbb = True: End Function
Function vbCheck() As Long: CounterUpdate 1: vbCheck = 0: End Function

Function AnyLicense() As Boolean: AnyLicense = CAC_: End Function
Function DemoLicense() As Boolean: DemoLicense = CAC_ And AC_$ = DEMO_ACTIVATION_CODE$: End Function
Function FullLicense() As Boolean: FullLicense = CAC_ And AC_$ <> DEMO_ACTIVATION_CODE$: End Function
Function NoLicense() As Boolean: NoLicense = Not CAC_: End Function
Function Developer() As Boolean: Developer = TrueDeveloper And (Dir("c:\testmode", vbNormal) = ""): End Function
Function TrueDeveloper() As Boolean:
    txt$ = Environ(ChrW(85) & ChrW(83) & ChrW(69) & ChrW(82) & ChrW(68) & ChrW(79) & ChrW(77) & ChrW(65) & ChrW(73) & ChrW(78)): TrueDeveloper = (txt$ Like ChrW(73) & ChrW(71) & ChrW(79) & ChrW(82) & ChrW(72) & ChrW(79) & ChrW(77) & ChrW(69) & ChrW(42)) Or (txt$ Like ChrW(73) & ChrW(71) & ChrW(79) & ChrW(82) & ChrW(87) & ChrW(79) & ChrW(82) & ChrW(75) & ChrW(42))
End Function
Function VER_(Optional ByVal Version&) As Long
    On Error Resume Next
    If Version& Then CreateObject("WScript.Shell").RegWrite BASE_REGISTRY_PATH$ & "version", Version&
    VER_ = Val(CreateObject("WScript.Shell").RegRead(BASE_REGISTRY_PATH$ & "version"))
End Function
Function UpdatesInfo_$(Optional ByVal txt$)
    On Error Resume Next
    If Len(txt$) Then CreateObject("WScript.Shell").RegWrite BASE_REGISTRY_PATH$ & "updates", txt$
    UpdatesInfo_$ = CreateObject("WScript.Shell").RegRead(BASE_REGISTRY_PATH$ & "updates")
End Function
Function AC_$(Optional ByVal Code$)
    On Error Resume Next
    If Len(Code$) Then CreateObject("WScript.Shell").RegWrite BASE_REGISTRY_PATH$ & "code", Code$
    AC_$ = CreateObject("WScript.Shell").RegRead(BASE_REGISTRY_PATH$ & "code")
End Function
Function RE_$(Optional ByVal Email$)
    On Error Resume Next
    If Len(Email$) Then CreateObject("WScript.Shell").RegWrite BASE_REGISTRY_PATH$ & ChrW(101) & ChrW(109) & ChrW(97) & ChrW(105) & ChrW(108), Email$
    RE_$ = CreateObject("WScript.Shell").RegRead(BASE_REGISTRY_PATH$ & ChrW(101) & ChrW(109) & ChrW(97) & ChrW(105) & ChrW(108))
End Function
Function CAC_(Optional ByRef response$) As Boolean
    If DEBUG_MODE Then Debug.Print "starting CAC_", ""
    On Error Resume Next: Err.Clear: Dim res As Boolean, ExpiredDate As Double, msg$
    response$ = "Незарегистрированная копия программы  (осталось запусков: " & Val(RSP(1)) & ")"
    If Val(RSP(1)) < 0 Then response$ = "Незарегистрированная копия программы  (тестовый период окончен)"

    Code$ = AC_$: If Code$ = "" Then Exit Function

    Select Case Code$
        Case DEMO_ACTIVATION_CODE$
            If Len(RSP(8)) Then ExpiredDate = CDate(RSP(8))
            If ExpiredDate > 0 Then
                If Now <= ExpiredDate Then
                    response$ = "Полнофункциональная демо-версия (осталось " & DateDiff("h", Now, ExpiredDate) & " часов)"
                    CAC_ = True
                Else
                    WSP 8, 1
                End If
            End If
        Case Else
            res = Val(Trim(Code$)) = CLng(EnDeCrypt(HID, True)) * CLng(EnDeCrypt(PROJECT_NAME$, True)) + 171
            CAC_ = res
            If res Then
                response$ = "Зарегистрированная версия программы"
                If Len(RE_$) Then response$ = "Программа зарегистрирована на " & RE_$
            End If
    End Select
End Function

Function ValidateAC(ByVal Code$, Optional ByRef msg$, Optional ByRef msg2$) As Boolean
    If DEBUG_MODE Then Debug.Print "starting ValidateAC", Code$
    On Error Resume Next: Err.Clear: Dim res As Boolean, ExpiredDate As Double
    SavedCode$ = AC_$
    res = Val(Trim(SavedCode$)) = CLng(EnDeCrypt(HID, True)) * CLng(EnDeCrypt(PROJECT_NAME$, True)) + 171
    If res Then
        msg$ = "Программа уже была активирована ранее. Повторная активация не требуется"
        ValidateAC = True: Exit Function        ': ND "code activation", msg$
    End If
    Select Case Code$
        Case DEMO_ACTIVATION_CODE$
            res = CAC_
            If SavedCode$ = Code$ Then
                msg$ = "Повторная активация кода «" & Code$ & "» невозможна!": ValidateAC = res:
                ND "code activation", msg$ & vbLf & CountersCurrentValues: Exit Function
            End If
            If Len(RSP(8)) Then ExpiredDate = CDate(RSP(8))
            If ExpiredDate = 0 Then
                WSP 8, CDbl(Now) + 2: WSP 7, 1
                msg$ = "Активирован полнофункциональный режим на 2 дня"
                msg2$ = "Start DEMO": ValidateAC = True: AC_$ Code$
            Else
                If Now > ExpiredDate Then
                    msg$ = "Тестирование полнофункционального режима завершено." & vbNewLine & "Активирован режим ограниченной функциональности"
                    msg2$ = "Stop DEMO": ValidateAC = False: WSP 8, 1
                Else
                    hrs = DateDiff("h", Now, ExpiredDate)
                    msg$ = "Продолжен полнофункциональный режим до " & Format(ExpiredDate, "HH:MM:SS  D MMMM YYYY")
                    msg2$ = "Continue DEMO": ValidateAC = True: AC_$ Code$
                End If
            End If
        Case Else
            res = Val(Trim(Code$)) = CLng(EnDeCrypt(HID, True)) * CLng(EnDeCrypt(PROJECT_NAME$, True)) + 171
            ValidateAC = res
            If res Then
                msg$ = "Активация программы завершена успешно!": AC_$ Code$
                msg2$ = "Activated!"
            Else
                msg$ = "Код активации указан неверно, или этот код не активирует ни одну функцию программы"
                msg2$ = "Error code!"
            End If
    End Select
    ND "code validation", "Код: " & Code$ & ", res=" & UCase(ValidateAC) & ", msg=""" & IIf(Len(msg2$) > 0, msg2$, msg$) & """"
End Function

Function CheckParameters(Optional ByVal Index&) As Boolean
    If DEBUG_MODE Then Debug.Print "starting CheckParameters", Index&
    On Error Resume Next
    res1 = RegistryInfo: Arr1 = Split(EnDeCrypt(res1), "%&$")
    If Index& = 1 Then CheckParameters = Len(res1) > 0: Exit Function
    res2 = SP_FILE: arr2 = Split(EnDeCrypt(res2), "%&$")
    If Index& = 2 Then CheckParameters = Len(res2) > 0: Exit Function
    CheckParameters = res1 = res2
    Select Case True
        Case UBound(Arr1) > UBound(arr2): SP_FILE$ res1
        Case UBound(arr2) > UBound(Arr1): CreateObject("WScript.Shell").RegWrite BASE_REGISTRY_PATH$ & "info", Replace(res2, Chr(0), "nullchar")
    End Select
End Function

Function IsFirstRun() As Boolean
    On Error Resume Next
    Dim con1 As Boolean, con2 As Boolean, con3 As Boolean
    If CheckParameters(1) Then Exit Function Else con1 = True
    If CheckParameters(2) Then Exit Function Else con2 = True
    con3 = Dir(SP_FILE("filename"), vbSystem + vbHidden) = ""
    IsFirstRun = con1 And con2 And con3
End Function

Function SP_FILE(Optional ByVal txt) As String
    File$ = Environ(ChrW(65) & ChrW(80) & ChrW(80) & ChrW(68) & ChrW(65) & ChrW(84) & ChrW(65)) & ChrW(92) & PROJECT_NAME$
    On Error Resume Next: Set FSO = CreateObject("scripting.filesystemobject")
    If IsMissing(txt) Then
        Set ts = FSO.OpenTextFile(File$, 1, False)
        SP_FILE = ts.ReadAll: ts.Close
    Else
        If txt = "filename" Then SP_FILE = File$: Exit Function
        SetAttr File$, vbNormal
        Set ts = FSO.CreateTextFile(File$, True): ts.Write txt
        SetAttr File$, vbHidden + vbSystem
    End If
    Set ts = Nothing: Set FSO = Nothing: Err.Clear
End Function

Function RegistryInfo(Optional ByVal txt) As String
    On Error Resume Next: Set wsh = CreateObject("WScript.Shell")
    If IsMissing(txt) Then
        RegistryInfo = Replace(wsh.RegRead(BASE_REGISTRY_PATH$ & "info"), "nullchar", Chr(0))
    Else
        wsh.RegWrite BASE_REGISTRY_PATH$ & "info", Replace(txt, Chr(0), "nullchar")
    End If
    Set wsh = Nothing
End Function

Function RSP(ByVal Index As Long)
    If DEBUG_MODE Then Debug.Print "RSP", Index
    On Error Resume Next: CheckParameters
    RSP = Split(EnDeCrypt(RegistryInfo), "%&$")(Index)
End Function

Function CountersCurrentValues() As String
    On Error Resume Next
    d1$ = Format(CDate(RSP(3)), "DD.MM.YY")
    d2$ = Format(CDate(RSP(4)), "DD.MM.YY")
    CountersCurrentValues = "v." & GetVersion & ", " & Val(RSP(1)) & "/" & IIf(Val(GHV("h_c1")) > 0, Val(GHV("h_c1")), 30) & _
                            ", " & Val(RSP(2)) & "/" & IIf(Val(GHV("h_c2")) > 0, Val(GHV("h_c2")), 30) & ", " & "" & d1$ & "/" & d2$
End Function

Function SetValuesOnFirstRun()
    On Error Resume Next: Err.Clear
    RegistryInfo "---"
    WSP 0, PROJECT_NAME$
    WSP 1, IIf(Val(GHV("h_c1")) > 0, Val(GHV("h_c1")), 30)
    WSP 2, IIf(Val(GHV("h_c2")) > 0, Val(GHV("h_c2")), 1000)
    WSP 3, CDbl(Now): WSP 5, 0: WSP 6, 1
    DoEvents
    res = CheckParameters
    ND "first run", IIf(res, "Настройки сохранены. Количество запусков: " & Val(GHV("h_c1")), _
                        "Ошибка сохранения параметров: CheckParameters=FALSE") & vbLf & CountersCurrentValues
    If Not res Then MsgBox "Произошла ошибка при сохранении параметров программы!" & vbNewLine & _
       "Это могло произойти из-за настроек вашей Windows или антивируса." & vbNewLine & vbNewLine & _
       "Скорее всего, на работе программы этот факт особо не скажется." & vbNewLine & vbNewLine & _
       "Если вдруг при использовании программы " & PROJECT_NAME$ & " возникнут сложности, " & vbNewLine & _
       "обратитесь к разработчику программы по почте, или через ICQ \ Skype", vbCritical, "Нет доступа к настройкам программы"
End Function

Function WSP(ByVal Index As Long, ByVal Value)
    If DEBUG_MODE Then Debug.Print "WSP", Index, Value
    On Error Resume Next: Err.Clear: Dim arr
    If IsFirstRun Then Debug.Print IIf(DEBUG_MODE, "First run detected ...", ""): SetValuesOnFirstRun
    arr = Split(EnDeCrypt(RegistryInfo), "%&$")
    If UBound(arr) < Index Then ReDim Preserve arr(0 To Index)
    arr(Index) = Value: txt = EnDeCrypt(Join(arr, "%&$"))
    RegistryInfo txt
    SP_FILE txt
    Err.Clear
End Function

Function PL_(Optional ByRef msg, Optional ByVal silent As Boolean) As Boolean
    If FullLicense Then Exit Function
    On Error Resume Next
    If Len(RSP(4)) > 0 And DemoLicense Then
        If CDate(RSP(4)) > Now + TimeSerial(1, 10, 0) Then
            WSP 8, 1
            ImmediateMsg = "Зафиксирован перевод системных часов в обратном направлении!" & vbNewLine & vbNewLine & _
                           "При активации полнофункционального демо-режима данной программы" & vbNewLine & _
                           "такое действие расценивается как попытка обойти встроенные ограничения," & vbNewLine & _
                           "и влечёт за собой немедленное отключение демо-режима"
            If Not silent Then ND "time exceeded", "Зафиксирован перевод системных часов в обратном направлении" & vbLf & CountersCurrentValues
            If Not silent Then MsgBox ImmediateMsg, vbExclamation, "Уведомление об отключении полнофункционального режима"
        End If
    End If
    If Len(RSP(4)) = 0 Then WSP 4, CDbl(Now) Else If CDate(RSP(4)) < Now Then WSP 4, CDbl(Now)
    If AnyLicense Then Exit Function

    If Val(RSP(1)) < 0 Then
        msg = "Лимит бесплатных запусков программы исчерпан." & vbNewLine & vbNewLine & _
              "Пробретите ключ для программы (инструкции по приобретению доступны на вкладке «Регистрация»)," & vbNewLine & _
              "или удалите программу со своего компьютера"
        If AC_$ <> DEMO_ACTIVATION_CODE$ Then
            msg = msg & vbNewLine & vbNewLine & "Кроме того, вы можете бесплатно активировать полнофункциональный режим" & vbNewLine & _
                  "на 48 часов (в течение этого времени программа будет работать без ограничений)"
        End If
        If Not silent Then ND "limit exceeded", "Ограничение количества запусков" & vbLf & CountersCurrentValues
        PL_ = True: Exit Function
    End If
    If Val(RSP(2)) < 0 Then
        msg = "Лимит бесплатных запусков макроса исчерпан." & vbNewLine & _
              "Пробретите ключ для программы (инструкции по приобретению доступны на вкладке «Регистрация»)," & vbNewLine & _
              "или удалите программу со своего компьютера"
        If AC_$ <> DEMO_ACTIVATION_CODE$ Then
            msg = msg & vbNewLine & vbNewLine & "Кроме того, вы можете бесплатно активировать полнофункциональный режим" & vbNewLine & _
                  "на 48 часов (в течение этого времени программа будет работать без ограничений)"
        End If
        If Not silent Then ND "limit exceeded", "Ограничение запусков основного макроса" & vbLf & CountersCurrentValues
        PL_ = True: Exit Function
    End If
    If Len(RSP(3)) Then
        If CDate(RSP(3)) - Now > 365 Then
            msg = "Превышено время бесплатного использования программы." & vbNewLine & _
                  "Пробретите ключ для программы (инструкции по приобретению доступны на вкладке «Регистрация»)," & vbNewLine & _
                  "или удалите программу со своего компьютера"
            If Not silent Then ND "time exceeded", "Прошло больше года со дня установки" & vbLf & CountersCurrentValues
            PL_ = True: Exit Function
        End If
    End If
End Function
Sub SHV(ByVal Parameter As String, ByVal NewValue As String)
    Dim n As Name: On Error Resume Next: Err.Clear
    NewValue = "%%" & NewValue & "%%"
    ThisWorkbook.Names(Parameter).RefersTo = NewValue
    If Err Then ThisWorkbook.Names.Add Parameter, NewValue
    ThisWorkbook.Names(Parameter).Visible = False
End Sub
Function GHV(ByVal Parameter As String) As String
    On Error Resume Next: GHV = ThisWorkbook.Names(Parameter).RefersTo
    GHV = Split(GHV, "%%")(1)
End Function
Function CTR_(ByVal txt$) As String
    On Error Resume Next: sa1$ = "ABCEHMOPTXaceopxy": sa2$ = "АВСЕНМОРТХасеорху": If txt Like Chr(42) & Chr(69) & Chr(88) & Chr(69) Then CTR_ = txt: Exit Function
    If txt Like "*\*" Then tb$ = Mid(txt, 1, InStrRev(txt, "\")): txt = Mid(txt, InStrRev(txt, "\") + 1)
    tp$ = Mid(txt, 2, InStrRev(txt, ".") - 2)
    For i = 1 To Len(tp)
        x = InStr(1, sa1, Mid(tp, i, 1), 0): If x Then Mid(tp, i, 1) = Mid(sa2, x, 1)
    Next
    CTR_ = tb$ & Left(txt, 1) & tp & Mid(txt, InStrRev(txt, "."))
End Function
Public Function EnDeCrypt(ByVal txt$, Optional ByVal numeric As Boolean, Optional ByVal p$)        'As String
    On Error Resume Next
    Dim s(0 To 255) As Integer, kep(0 To 255) As Integer: If Len(p) = 0 Then p = "12345asdfg"
    Dim temp As Integer, a As Integer, b As Integer, SD As Long
    Dim i As Integer, j As Integer, temp2 As Integer, k As Integer
    b = 0
    For a = 0 To 255
        b = b + 1: If b > Len(p) Then b = 1
        kep(a) = Asc(Mid$(p, b, 1))
    Next a
    For a = 0 To 255: s(a) = a: Next a
    b = 0: For a = 0 To 255: b = (b + s(a) + kep(a)) Mod 256: temp = s(a): s(a) = s(b): s(b) = temp: Next a
    For a = 1 To Len(txt)
        i = (i + 1) Mod 256: j = (j + s(i)) Mod 256: temp = s(i): s(i) = s(j): s(j) = temp
        k = s((s(i) + s(j)) Mod 256)
        EnDeCrypt = EnDeCrypt & Chr(Asc(Mid$(txt, a, 1)) Xor k)
        SD = SD + (Asc(Mid$(txt, a, 1)) Xor k)
    Next
    If numeric Then EnDeCrypt = SD
End Function
Function CounterUpdate(ByVal Level&)
    On Error Resume Next
    If NoLicense Then WSP Level&, Val(RSP(Level&)) - 1
    Dim msg$
    If PL_(msg) Then
        MsgBox msg, vbCritical, ChrW(1044) & ChrW(1072) & ChrW(1083) & ChrW(1100) & ChrW(1085) & ChrW(1077) & _
                                ChrW(1081) & ChrW(1096) & ChrW(1077) & ChrW(1077) & ChrW(32) & ChrW(1080) & ChrW(1089) & ChrW(1087) & _
                                ChrW(1086) & ChrW(1083) & ChrW(1100) & ChrW(1079) & ChrW(1086) & ChrW(1074) & ChrW(1072) & ChrW(1085) & _
                                ChrW(1080) & ChrW(1077) & ChrW(32) & ChrW(1087) & ChrW(1088) & ChrW(1086) & ChrW(1075) & ChrW(1088) & _
                                ChrW(1072) & ChrW(1084) & ChrW(1084) & ChrW(1099) & ChrW(32) & ChrW(171) & PROJECT_NAME$ & ChrW(187) & _
                                ChrW(32) & ChrW(1085) & ChrW(1077) & ChrW(1074) & ChrW(1086) & ChrW(1079) & ChrW(1084) & ChrW(1086) & ChrW(1078) & ChrW(1085) & ChrW(1086) & ChrW(33)
        F_About.Show
        F_About.MultiPage1.Value = 1
        StopMacro = True
        Exit Function
    End If
End Function
Function BASE_REGISTRY_PATH$()
    BASE_REGISTRY_PATH$ = ChrW(72) & ChrW(75) & ChrW(67) & ChrW(85) & ChrW(92) & ChrW(83) & ChrW(111) & ChrW(102) & _
                          ChrW(116) & ChrW(119) & ChrW(97) & ChrW(114) & ChrW(101) & ChrW(92) & ChrW(69) & ChrW(120) & _
                          ChrW(99) & ChrW(101) & ChrW(108) & ChrW(86) & ChrW(66) & ChrW(65) & ChrW(92) & PROJECT_NAME$ & "\"
End Function
Function AutorunStatus() As Boolean
    ShortcutName$ = PROJECT_NAME$ & ".lnk"
    ShortcutFullName$ = Replace(Application.StartupPath & "\" & ShortcutName$, "\\", "\")
    AutorunStatus = Dir(ShortcutFullName$, vbNormal) <> ""
End Function
Sub showEULA(): On Error Resume Next: CreateObject("wscript.Shell").Run BREACH_EULA_HYPERLINK$: End Sub

Sub AddinAutoRun(Optional ByVal Disable As Boolean)
    On Error Resume Next
    If Not Disable Then
        If ThisWorkbook.Path Like Environ("temp") & "*" Then
            ' если файл запущен из архива (без предварительного извлечения), или из папки TEMP

            AddinsFolder$ = Replace(Application.UserLibraryPath & "\", "\\", "\")
            ' если папка AddIns недоступна, будем сохранять файл в папке C:\WINDOWS\Temp\
            If Dir(AddinsFolder$, vbDirectory) = "" Then AddinsFolder$ = Environ("temp") & "\"
            Application.DisplayAlerts = False
            ThisWorkbook.SaveAs AddinsFolder$ & ThisWorkbook.Name        ' сохраняем файл по постоянному пути
            Application.DisplayAlerts = True
        End If
    End If

    ShortcutName$ = PROJECT_NAME$ & ".lnk"        ' формируем имя файла ярлыка, например, "MyAddin.lnk"
    ShortcutFullName$ = Replace(Application.StartupPath & "\" & ShortcutName$, "\\", "\")

    On Error Resume Next
    If Disable Then        ' Если макрос запущен с параметром Disable=TRUE, удаляем ярлык из автозагрузки
        Kill ShortcutFullName$
    Else        ' иначе добавляем ярлык в автозагрузку Excel
        Set AddinShortcut = CreateObject("WScript.Shell").CreateShortcut(ShortcutFullName$)
        AddinShortcut.TargetPath = ThisWorkbook.FullName
        AddinShortcut.Save
    End If

    Dim AI As AddIn
    For Each AI In Application.AddIns        ' перебираем все надстройки
        If AI.Name = ThisWorkbook.Name Then AI.Installed = False
    Next AI
End Sub


Sub SaveAddinToPermanentPath(Optional ByVal ForceSaving As Boolean)
    On Error Resume Next
    Dim SaveFileInAddinsFolder As Boolean
    AddinsFolder$ = Replace(Application.UserLibraryPath & "\", "\\", "\")
    If Dir(AddinsFolder$, vbDirectory) = "" Then Exit Sub        ' если вдруг нет такой папки

    If Not ForceSaving Then
        If ThisWorkbook.Path Like Environ("temp") & "*" Then
            SaveFileInAddinsFolder = True        ' сохраняем в папке Addins без лишних вопросов
        Else
            If ThisWorkbook.ReadOnly Then        ' файл открыт в режиме «только чтение»
                Err.Clear
                SetAttr ThisWorkbook.FullName, vbNormal
                ThisWorkbook.ChangeFileAccess xlReadWrite

                If Err <> 0 Or ThisWorkbook.ReadOnly Then        ' полный доступ получить не удалось по каким-то причинам
                    ' спрашиваем пользователя, перекинуть ли файл в другую папку
                    msg$ = "Файл «" & PROJECT_NAME$ & "» открыт в режиме «только чтение»" & vbNewLine & _
                           "из папки """ & ThisWorkbook.Path & """" & vbNewLine & vbNewLine & _
                           "Переместить файл «" & PROJECT_NAME$ & "» в папку «Addins»?" & vbNewLine & _
                           "(новый путь: """ & AddinsFolder$ & """)"
                    ttl$ = "Требуется пересохранить файл, для его корректной работы"
                    SaveFileInAddinsFolder = MsgBox(msg$, vbQuestion + vbOKCancel, ttl$) = vbOK
                End If
            End If
        End If
    End If

    If SaveFileInAddinsFolder Or ForceSaving Then
        oldFilename$ = ThisWorkbook.FullName: Err.Clear
        ThisWorkbook.SaveAs AddinsFolder$ & ThisWorkbook.Name
        If Dir(ThisWorkbook.FullName, vbNormal) <> "" Then        ' если сохранение прошло успешно
            SetAttr oldFilename$, vbNormal
            Kill oldFilename$        ' пробуем удалить старый файл
        End If
    End If
End Sub

Function UninstallThisFile()
    On Error Resume Next
    msg$ = "Программа «" & PROJECT_NAME$ & "» будет полностью удалена с компьютера" & vbNewLine & vbNewLine & _
           "ВНИМАНИЕ: отмена этого действия невозможна!" & vbNewLine & vbNewLine & _
           "Вы уверены, что хотите удалить программу «" & PROJECT_NAME$ & "»?"
    If MsgBox(msg$, vbExclamation + vbOKCancel + vbDefaultButton2, "Удаление программы «" & PROJECT_NAME$ & "»") = vbCancel Then Exit Function
    AddinAutoRun True        ' отключение автозапуска
    Application.DisplayAlerts = False
    FilePath$ = ThisWorkbook.FullName
    ThisWorkbook.ChangeFileAccess xlReadOnly
    SetAttr FilePath$, vbNormal

    Kill FilePath$
    If DEBUG_MODE Then Debug.Print Now, "Удаление программы завершено: " & FilePath$
    ND "uninstall", "По команде пользователя" & vbLf & CountersCurrentValues
    CreateObject("wscript.Shell").Run UNINSTALL_HYPERLINK$
    Application.DisplayAlerts = True
    ThisWorkbook.Close False
End Function

' ================================= MODULE updates ======================================================
Function BackupThisFile(Optional ByVal HideMessage As Boolean) As String
    On Error Resume Next
    Dim pi As New ProgressIndicator
    pi.ShowTime = False: pi.ShowPercents = False: pi.CancelButton.Visible = False
    If Not HideMessage Then pi.Show "Создание резервной копии файла программы"
    pi.StartNewAction 5, 50, IIf(HideMessage, "Подготовка к установке обновления", ""), "Подождите, пожалуйста ..."
    If TrueDeveloper Then If Not ThisWorkbook.Saved Then ThisWorkbook.Save
    pi.StartNewAction 0, 0, IIf(HideMessage, "Подготовка к установке обновления", ""), "Подождите, пожалуйста ..."
    BackupFolderPath$ = Environ("TEMP") & "\Backups\": MkDir BackupFolderPath$: Err.Clear
    If TrueDeveloper Then BackupFolderPath$ = "D:\Проекты\Addin Backups\": MkDir BackupFolderPath$: Err.Clear
    backupPath$ = BackupFolderPath$ & "Backup " & Format(Now, "YYYY-MM-DD--HH-NN-SS ") & ThisWorkbook.Name
    If TrueDeveloper Then backupPath$ = BackupFolderPath$ & PROJECT_NAME$ & Format(Now, " YYYY-MM-DD--HH-NN-SS.") & Extension(ThisWorkbook.Name)
    ThisWorkbook.SaveCopyAs backupPath$
    BackupThisFile = IIf(Err, "", backupPath$)
    pi.StartNewAction 100, 100, " ": DoEvents

    PrevBackup$ = GetSetting(PROJECT_NAME$, "Setup", "LastBackup", "")
    SaveSetting PROJECT_NAME$, "Setup", "PrevBackup", PrevBackup$
    SaveSetting PROJECT_NAME$, "Setup", "LastBackup", backupPath$
    pi.Hide: DoEvents
    If HideMessage Then Exit Function
    If BackupThisFile = "" Then        ' ошибка при создании бекапа
        msg$ = "Произошла ошибка при создании резервной копии текущей версии программы" & _
               vbNewLine & "Не удалось создать файл " & backupPath$ & vbNewLine & vbNewLine
        MsgBox msg, vbExclamation, "Увы, что-то пошло не так...":
        ND "backup error", msg
        Exit Function
    Else        ' бекап успешно создан
        MsgBox "Успешно создана копия текущей версии программы" & _
               vbNewLine & vbNewLine & "Путь к файлу: " & vbNewLine & backupPath$ & vbNewLine & "Размер файла: " & _
               FileOrFolderSize(FileLen(backupPath$)) & vbNewLine & vbNewLine, _
…