Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ЭтаКнига"
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

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 = "modMain"
'---------------------------------------------------------------------------------------
' Module        : modMain
' Автор     : EducatedFool  (Игорь)                    Дата: 30.01.2011
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' http://excelvba.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
' Номер счёта WebMoney для оплаты: R318574877619
'---------------------------------------------------------------------------------------

Public Const ShName = "Результаты поиска"
Option Compare Text
Dim pi As ProgressIndicator

Function GetFile_MainPicture() As String
    ' создаёт во временной папке файл, возвращает путь к созданному файлу
    On Error Resume Next: Dim F_TXT$, buf$, tmp_file$: Const BufLen& = 5000
    F_TXT$ = F_TXT$ & "FFD8FFE000104A46494600010101012C012C0000FFDB0043000302020302020303030304030304050805050404050A070706080C0A0C0C0B0A0B0B0D0E12100D0E110E0B0B1016101113141515150C0F171816141812141514FFDB00430103040405040509050509140D0B0D1414141414141414141414141414141414141414141414141414141414141414141414141414141414141414141414141414FFC00011080036003603012200021101031101FFC4001C0000010501010100000000000000000000000405060708020309FFC400351000010303040002070509000000000000010203040005110607122131410813142232617115175181822325424352627292A1FFC40017010101010100000000000000000000000000010203FFC40017110101010100000000000000000000000000011141FFDA000C03010002110311003F00FAA750DD47BA36DB2DD1768831276A3BE21216BB6D9D90EB8D02320B8A5292DB791D80B5A4A87C20D79EEE6A79DA6B49845A0817BBA4A6AD7014A190879D38E6479F04852F1E7C6BDF45E98B6E8EB222DF001280A2A79F59CBB25D3DADD7147B529449249FC681B15AFB56454A5F93B7B3D718FF002E14E8EF4948F9B6A52523F259A91692D7569D68C3EAB7BCB4C98CA08930A4B4A6644751F0"
    F_TXT$ = F_TXT$ & "0E36A0143383838C28025248EE96ACB6B18A82EE3DB9FB7C61AAAD69FDF96741790E207BF258C82EC65FF52560759E92A4A55FC2282CDA2925AAE2CDE2D70E7C7505C794CA1F6D43CD2A4823FE1A57405145141537A474A361D31A77542D0A72069CBFC3B8CFE3D94C6254CBAE7D101EE64F904135216AE1EAC256C3A87D9580A041E940F8107E952FB8DBA2DDEDF260CE8EDCB8529A532FC779214875B502149503D1041208F9D6719DB7BB89B2615134A4156E0688413EC96E54A4B575B6A3C9A4A9C212FB69F22541606061472A3A99D1728BCA48F7B927EA33513DD5DC08FA476FEFB725A54EA9B8CA6D96B8F6EBCBF71B6D23CD4A5280007893558FDED6AC98E7B341DA6D70F4E3D06A45BC46681F9BCE108C7CF35537A40CFDE2DB09BA3F7335558EDEF69CB4DC10FF00D8B11CF6A8F6D73B087262801C967202568CA1B590791570CEAE446E5DBEB23FA6B4269DB4CA20CA836E8F19E293905686D29563E5906A41504D9DDE4D3FBD7A4D9BD58DF01612912A138A05D8CB23202B1E20F7C543A501D760813BAE6A28A28A028AE16EA1BF89694FD4E293B97684D7C725A4FD5540AB02935CED912F56E95027C5666C194D2987E3486C38DBADA86148524F4A4904820F8E6932B52DAD1E33991FAAB91AA6D27C27B3FED4181F71F6A750"
    F_TXT$ = F_TXT$ & "7A106E0B3AC7484A93F76331FE01E397956271C50FD84804E5C88B5600513949E2094AC216AD9FB4DBBB6DDD1B425C6C261DD5B6D2B910BD6731C4F838D2BAF58D93E0AC020F4A095022A49719562D436C956E9EA8770812DA531222C84871A79B502148524F4A4904820F8E6B1ECFD9DD63E8FF00ACD887B776E9DABB4A4F789B1FB349024D85F578B2F3ABC8F66032438A0A05292DAC1210A586DCA292DA8CC36C89F68961570F528F693173EABD6F11CF872EF8E738CF78C668A0E24DA634AF8D27F234D52B435BE56791747EAA28A06A91B4B68904F25BDDFF0075782366ACADAB216F67FCA8A281C236D9DAE2E38A9E3FAA9DA369683171C42CE3F15514503A34C2184E103028A28A0FFFD9"
    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 ClearCF()
    ' макрос удаляет условное форматирование на всём листе
    On Error Resume Next
    Cells.FormatConditions.Delete
End Sub


Sub RedNumbers()
    ' макрос запрашивает у пользователя число,
    ' после чего в текущем столбце красит все ячейки с числами,
    ' большими чем введенное, в красный цвет

    On Error Resume Next: col = ActiveCell.Column + sss
    If Err Then Exit Sub        ' выход, если не открыта ни одна книга

    Dim ra As Range: Set ra = Intersect(Columns(col), ActiveSheet.UsedRange)
    If ra Is Nothing Then Exit Sub        ' выход, если выделена ячейка в пустом столбце

    msg = "Введите число для сравнения с числами текущего столбца." & vbNewLine & _
          "Все числа в столбце " & col & ", которые больше введенного числа, будут выделены красным"

    ' запрашиваем число
    n = Application.InputBox(msg, "Выделение чисел цветом", Val(ActiveCell), , , , , 1)

    ' удаляем условное форматирвоание
    ra.FormatConditions.Delete

    If TypeName(n) = "Boolean" Then        ' отказ от ввода числа
        ' ничего не делаем

    Else        ' введено число

        ' назначаем условное форматирование - красим в красный цвет все ячейки
        ' со значением больше N
        ra.FormatConditions.Add(xlCellValue, xlGreater, n).Interior.Color = vbRed

    End If
End Sub

Sub DeleteResultsSheet()        ' удаление листа результатов
    On Error Resume Next
    Application.DisplayAlerts = False
    ActiveWorkbook.Worksheets(ShName).Delete
    Application.DisplayAlerts = True
End Sub

'Sub SetTextForSearch()
'    Dim AddinMenu As CommandBar
'    Set AddinMenu = GetCommandBar(PROJECT_NAME)
'    MsgBox AddinMenu.FindControl(ct_TEXTBOX).Text
'End Sub

Sub SearchText()
    On Error Resume Next
    ' проверка на наличие открырых книг Excel
    If ActiveWorkbook Is Nothing Then
        msg = "Нет открытых книг Excel" & vbNewLine & _
              "Сначала откройте книгу Excel, а потом уже запускайте поиск!"
        MsgBox msg, vbExclamation, "Поиск значения на листе"
        Exit Sub
    End If

    Dim sh As Worksheet: Set sh = ActiveSheet

    Dim AddinMenu As CommandBar
    Set AddinMenu = GetCommandBar(PROJECT_NAME)
    txt = AddinMenu.FindControl(ct_TEXTBOX).Text

    'txt = Application.CommandBars.ActionControl.Text    ' берем текст из поля поиска
    Application.ScreenUpdating = False

    If Len(Trim(txt)) = 0 Then Exit Sub        ' выход из макроса, если текст в поле ввода не задан

    Set pi = New ProgressIndicator
    pi.Show "Поиск текста «" & txt & "»"

    pi.StartNewAction , 10, "Подготовка листа для результатов поиска ..."

    DeleteResultsSheet        ' удаляем лист результатов, если он существует

    Dim shd As Worksheet        ' подготавливаем новый лист для результатов
    Set shd = ActiveWorkbook.Worksheets.Add(Worksheets(1))

    ' переименовываем лист, меняем цвет ярлычка, формируем  строку заголовка
    shd.Tab.Color = vbGreen: shd.Name = ShName
    shd.Range("a1:b1").Value = Array("Лист", "Результаты поиска")
    shd.Range("1:1").Interior.ColorIndex = 15 + sss: shd.Range("1:1").Font.Bold = True

    pi.StartNewAction 10, 100, "Поиск заданного текста ...", , , _
                      IIf(CurrentSheetOnly, 1, ActiveWorkbook.Worksheets.Count) * 2

    calc = Application.Calculation
    Application.Calculation = xlCalculationManual

    If CurrentSheetOnly Then
        ' ищем только на текущем листе
        ПоискНаЛисте sh, shd, txt
    Else
        ' перебираем все листы активной книги
        For Each sh In ActiveWorkbook.Worksheets
            ПоискНаЛисте sh, shd, txt
        Next sh
    End If

    shd.UsedRange.Value = shd.UsedRange.Value
    Application.Calculation = calc

    ' если ничего не нашли
    If shd.UsedRange.Rows.Count = 1 Then
        DeleteResultsSheet        ' удаляем лист результатов, если он существует
        msg2 = IIf(CurrentSheetOnly, "в одной строке листа «" & ActiveSheet.Name & "»", "на одном листе книги «" & ActiveWorkbook.Name & "»")
        msg = "Поиск завершён" & vbNewLine & _
              "Текст """ & txt & """ не был найден ни " & msg2
        pi.Hide: Application.ScreenUpdating = True
        MsgBox msg, vbInformation, "Поиск завершён"
        Exit Sub
    End If


    If CurrentSheetOnly Then        ' странный код, конечно ) но так проще
        ' удаляем зря добавленные строку заголовка и первый столбец
        shd.Rows(1).Delete
        shd.Columns(1).Delete

        ' копируем ширину столбцов
        sh.Range("1:1").Copy
        shd.Range("1:1").PasteSpecial xlPasteColumnWidths
        Application.CutCopyMode = False
    Else
        ' группируем строки, подбираем ширину столбцов
        shd.Outline.SummaryRow = xlAbove
        shd.UsedRange.EntireColumn.AutoFit

        ' закрепляем строку заголовка
        shd.Activate: shd.[A2].Select: DoEvents
        ActiveWindow.FreezePanes = True

    End If

    pi.Hide
    Application.ScreenUpdating = True
End Sub

Function ПоискНаЛисте(ByRef sh As Worksheet, ByRef shd As Worksheet, ByVal txt As String) As Long
    ' ищет на листе sh текст txt и копирует результат на лист shd
    ' функция возвращает количество найденных строк
    Dim coll As Collection, ra As Range

    pi.SubAction "Поиск на листе «" & sh.Name & "» ...", "Формирование списка подходящих строк ..."
    ' поиск подходящих строк
    Set coll = SearchResults(sh, txt)

    If coll.Count Then        ' если нашли хоть одну строку

        pi.SubAction "Поиск на листе «" & sh.Name & "» - найдено " & coll.Count & " строк", _
                     "Копирование найденных строк на лист результатов ...", "Выполнено: "
        ' копируем найденные строки блоками по 500 штук на лист результатов
        For Each Item In coll
            If ra Is Nothing Then Set ra = sh.Rows(Item) Else Set ra = Union(ra, sh.Rows(Item))
            n = n + 1: If n >= 500 Then CopyRows ra, shd: Set ra = Nothing: n = 0
        Next
        If Not ra Is Nothing Then CopyRows ra, shd
    Else
        pi.SubAction , "Строки не найдены ...", " "
    End If
    ПоискНаЛисте = coll.Count
End Function


Sub CopyRows(ByRef ro As Range, ByRef shd As Worksheet)
    On Error Resume Next: DoEvents
    ' pi.Line3 = "Подготовка диапазона ячеек для вставки данных ..."
    columnscount% = shd.Columns.Count - 1: rc = shd.UsedRange.Rows.Count
    Dim CopyRange As Range: Set CopyRange = Intersect(ro.EntireRow, ro.Worksheet.Columns.Resize(, columnscount%))
    Dim ra As Range: Set ra = shd.Cells(rc + 1, 1).Resize(Intersect(ro.EntireRow, ro.Worksheet.Columns(1)).Cells.Count)
    ra.Value = ro.Worksheet.Name
    ra.BorderAround xlContinuous
    ra.Interior.ColorIndex = 12 + Fix(Rnd() * 30)
    If ra.Cells.Count > 1 Then
        Intersect(ra.EntireRow, ra.EntireRow.Offset(1)).Group
    End If
    'pi.Line3 = pi.FP.L3.Caption & "**": DoEvents: pi.FP.Repaint
    pi.Line3 = "Добавлено строк: " & ra.Cells.Count & _
             "   Всего строк на листе результата: " & ra.Cells.Count + rc - 1
    pi.FP.Repaint: DoEvents
    CopyRange.Copy shd.Cells(rc + 1, 2)
End Sub

Function SearchResults(ByVal sh As Worksheet, ByVal txt As String) As Collection
    ' ищет все вхождения текста txt на листе sh
    ' возвращает коллекцию, содержащую номера подходящих строк
    On Error Resume Next
    Dim rFndRng As Range, sAddress As String, n As Long
    Set SearchResults = New Collection
    sAddress = "": Set rFndRng = Nothing
    Set rFndRng = sh.UsedRange.Find(What:=txt, LookIn:=xlValues, LookAt:=xlPart)
    If Not rFndRng Is Nothing Then
        sAddress = rFndRng.Address
        Do
            SearchResults.Add rFndRng.Row, CStr(rFndRng.Row): DoEvents
            n = n + 1: If n Mod 40 = 0 Then pi.Line3 = "Поиск в строке " & rFndRng.Row & _
                        "   Найдено подходящих строк: " & SearchResults.Count
            Set rFndRng = sh.UsedRange.FindNext(rFndRng)
        Loop While sAddress <> rFndRng.Address
    End If
    pi.Line3 = "Поиск завершён. " & "   Найдено подходящих строк: " & SearchResults.Count
End Function

Attribute VB_Name = "mod_MenuFunction"
'---------------------------------------------------------------------------------------
' Модуль    : CreateMenu
' Автор     : EducatedFool (Игорь)                    Дата: 08.03.2010
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' http://excelvba.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
' Номер счёта WebMoney для оплаты: R318574877619
'---------------------------------------------------------------------------------------

Public Const FieldCaption$ = "Поиск значения с выводом результатов на отдельный лист" & vbLf & " " & vbLf & _
       "Введите текст для поиска, и нажмите «Enter»"

Sub CreateProgramCommandBar()
    On Error Resume Next:
    Application.ScreenUpdating = False
    ' получаем ссылку на пользовательскую панель инструментов
    Set AddinMenu = GetCommandBar(PROJECT_NAME, True)

    ' добавление новых элементов управления на панель

    With Add_Control(AddinMenu, ct_TEXTBOX, 0, "SearchText", FieldCaption$, , True, "txt")
        .Width = 150
        .OnAction = "SearchText"
    End With
    Add_Control AddinMenu, ct_BUTTON, 342, "SearchText", "Найти    ", msoButtonCaption     ', True

    Set subMenu1 = Add_Control(AddinMenu, ct_POPUP, 0, "", " &Дополнительно", , True)
    Add_Control subMenu1, ct_BUTTON, 232, "DeleteResultsSheet", "Удалить лист с результатами поиска", msoButtonIconAndCaption

    If CurrentSheetOnly Then
        Add_Control(subMenu1, ct_BUTTON, 317, "SetOption_SearchAllSheets", _
                    "Режим поиска: текущий лист", msoButtonIconAndCaption, True).TooltipText = _
                    "123"
    Else
        Add_Control(subMenu1, ct_BUTTON, 53, "SetOption_SearchCurrentSheetOnly", _
                    "Режим поиска: все листы", msoButtonIconAndCaption, True).TooltipText = _
                    "123"
    End If

     Add_Control subMenu1, ct_BUTTON, 352, "RedNumbers", "Выделить красным ячейки с числами больше заданного", msoButtonIconAndCaption, True
    Add_Control subMenu1, ct_BUTTON, 342, "ClearCF", "Удалить условное форматирование", msoButtonIconAndCaption    ', True
   
   If Developer Then
        Add_Control subMenu1, ct_BUTTON, 271, "BackupThisFile", "Создать резервную копию программы", msoButtonIconAndCaption, True
    End If


    ' Add_Control AddinMenu, ct_BUTTON, 548, "ShowSettingsPage", "Настройки программы" & vbNewLine & PROJECT_NAME$, , True
    Add_Control AddinMenu, ct_BUTTON, 487, "ShowMainForm", "О программе ..."    ', , True
    Application.ScreenUpdating = True
End Sub


Function CurrentSheetOnly() As Boolean
    ' функция читает из реестра настройки поиска
    ' возвращает TRUE, если поиск производится только на текущем листе
    CurrentSheetOnly = CBool(GetSetting(Application.Name, PROJECT_NAME, "CurrentSheetOnly", False))
End Function


' для запуска с панели инструментов
Sub SetOption_SearchAllSheets()
    SaveSetting Application.Name, PROJECT_NAME, "CurrentSheetOnly", False

    ЗадержкаВСекундах = 0.3    ' в секундах
    НазваниеМакроса$ = "'" & ThisWorkbook.Name & "'!CreateProgramCommandBar"    ' этот макрос будет запущен через 0.3 сек.
    ЗадержкаВЧасах$ = Replace(Format(CDbl(TimeSerial(0, 0, 1)) * ЗадержкаВСекундах, "0.000000000"), ",", ".")
    Macro = "ON.TIME(NOW()+" & ЗадержкаВЧасах$ & ", """ & НазваниеМакроса$ & """)"    ' формируем команду запуска
    ExecuteExcel4Macro Macro
End Sub

Sub SetOption_SearchCurrentSheetOnly()
    SaveSetting Application.Name, PROJECT_NAME, "CurrentSheetOnly", True

    ЗадержкаВСекундах = 0.3    ' в секундах
    НазваниеМакроса$ = "'" & ThisWorkbook.Name & "'!CreateProgramCommandBar"      ' этот макрос будет запущен через 0.3 сек.
    ЗадержкаВЧасах$ = Replace(Format(CDbl(TimeSerial(0, 0, 1)) * ЗадержкаВСекундах, "0.000000000"), ",", ".")
    Macro = "ON.TIME(NOW()+" & ЗадержкаВЧасах$ & ", """ & НазваниеМакроса$ & """)"    ' формируем команду запуска
    ExecuteExcel4Macro Macro
End Sub



Attribute VB_Name = "FWF"
'---------------------------------------------------------------------------------------
' Module        : mod_CommonFunctions
' Автор     : EducatedFool  (Игорь)                    Дата: 26.07.2012
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
' Реквизиты для оплаты работы: http://ExcelVBA.ru/payments
'---------------------------------------------------------------------------------------

Const FWF_VERSION = 2

#If Win64 Then
    #If VBA7 Then    ' Windows x64, Office 2010
        Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
                (ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _
                 ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong
    #Else    ' Windows x64,Office 2003-2007
        Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
                                           (ByVal pCaller As LongLong, ByVal szURL As String, ByVal szFileName As String, _
                                            ByVal dwReserved As LongLong, ByVal lpfnCB As LongLong) As LongLong
    #End If
#Else
    #If VBA7 Then    ' Windows x86, Office 2010
        Declare PtrSafe 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
    #Else    ' Windows x86, Office 2003-2007
        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
#End If

Function DownLoadFileFromURL(ByVal URL$, ByVal LocalPath$) As Boolean
    On Error Resume Next: Kill LocalPath$

    shortFilename$ = Mid(LocalPath$, InStrRev(LocalPath$, "\") + 1)
    If shortFilename$ <> Replace_symbols(shortFilename$) Then
        Debug.Print "Wrong symbols in filename: " & shortFilename$
        Exit Function
    End If

    Randomize ' чтобы избежать кеширования
    URL$ = URL$ & "?HID=" & HID & "&rnd=" & Left(Rnd(Now) * 1E+15, 10)

    DownLoadFileFromURL = URLDownloadToFile(0, URL$, LocalPath$, 0, 0) = 0
End Function

Function GetURLstatus(ByVal URL$, Optional ByVal timeout& = 2) As Long
    ' функция проверяет наличие доступа к ресурсу URL$ (файлу или каталогу)
    ' возвращает код ответа сервера (число), либо 0, если ссылка ошибочная
    ' (200 - ресурс доступен, 404 - не найден, 403 - нет доступа, и т.д.)
    On Error Resume Next: URL$ = Replace(URL$, "\", "/")
    Dim xmlhttp As New WinHttpRequest
    xmlhttp.Open "GET", URL, True
    xmlhttp.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
    xmlhttp.send
    If xmlhttp.WaitForResponse(timeout) Then
        GetURLstatus = Val(xmlhttp.Status)
    Else
        GetURLstatus = 408 ' Request Timeout (истекло время ожидания)
    End If
End Function

Function Extension(ByVal Filename$) As String
    On Error Resume Next
    Extension = Split(Filename$, ".")(UBound(Split(Filename$, ".")))
End Function


Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
                       Optional ByVal InitialPath As String = "c:\") As String
    ' функция выводит диалоговое окно выбора папки с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
    Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show <> -1 Then Exit Function
        GetFolderPath = .SelectedItems(1)
        If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
                     Optional ByVal InitialPath As String = "c:\", _
                     Optional ByVal FilterDescription As String = "Книги Excel", _
                     Optional ByVal FilterExtension As String = "*.xls*") As String
    ' функция выводит диалоговое окно выбора файла с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
    ' для фильтра можно указать описание и расширение выбираемых файлов
    On Error Resume Next
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtension
        If .Show <> -1 Then Exit Function
        GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
    End With
End Function

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep    ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                                 ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        ' Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

Function ReadTXTfile(ByVal Filename As String) As String
    Set FSO = CreateObject("scripting.filesystemobject")
    Set ts = FSO.OpenTextFile(Filename, 1, True): ReadTXTfile = ts.ReadAll: ts.Close
    Set ts = Nothing: Set FSO = Nothing
End Function

Function SaveTXTfile(ByVal Filename As String, ByVal txt As String) As Boolean
    On Error Resume Next: Err.Clear
    Set FSO = CreateObject("scripting.filesystemobject")
    Set ts = FSO.CreateTextFile(Filename, True)
    ts.Write txt: ts.Close
    SaveTXTfile = Err = 0
    Set ts = Nothing: Set FSO = Nothing
End Function

Function AddIntoTXTfile(ByVal Filename As String, ByVal txt As String) As Boolean
    On Error Resume Next: Err.Clear
    Set FSO = CreateObject("scripting.filesystemobject")
    Set ts = FSO.OpenTextFile(Filename, 8, True): ts.Write txt: ts.Close
    Set ts = Nothing: Set FSO = Nothing
    AddIntoTXTfile = Err = 0
End Function

Function SubFoldersCollection(ByVal FolderPath$, Optional ByVal Mask$ = "*") As Collection
    Set SubFoldersCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    If Right(FolderPath$, 1) <> "\" Then FolderPath$ = FolderPath$ & "\"
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath$)
    For Each folder In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
        If folder.Path Like FolderPath$ & Mask$ Then SubFoldersCollection.Add folder.Path & "\"
    Next folder
    Set FSO = Nothing
End Function

Function GetFilenamesCollection(Optional ByVal Title As String = "Выберите файлы для обработки", _
                                Optional ByVal InitialPath As String = "c:\") As FileDialogSelectedItems
    ' функция выводит диалоговое окно выбора нескольких файлов с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает массив путей к выбранным файлам, или пустую строку в случае отказа от выбора
    With Application.FileDialog(3)    ' msoFileDialogFilePicker
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show <> -1 Then Exit Function
        Set GetFilenamesCollection = .SelectedItems
    End With
End Function

Function Replace_symbols(ByVal txt As String) As String
    st$ = "/\:?*|""<>"    ' а эти символы - разрешены: ~!@#$%^=`
    For i% = 1 To Len(st$)
        txt = Replace(txt, Mid(st$, i, 1), "_")
    Next
    Replace_symbols = txt
End Function

Function Replace_symbols2(ByVal txt As String) As String
    st$ = "/:?*|""<>"    ' а эти символы - разрешены: ~!@#$%^=`
    For i% = 1 To Len(st$)
        txt = Replace(txt, Mid(st$, i, 1), "_")
    Next
    Replace_symbols2 = txt
End Function

Sub OpenFolder(ByVal FolderPath$)
    ' открывает папку FolderPath$ в Проводнике Windows
    On Error Resume Next
    'CreateObject("wscript.shell").Run "explorer.exe /e,/root, """ & FolderPath$ & """"
    CreateObject("wscript.shell").Run "explorer.exe /e, """ & FolderPath$ & """"
End Sub

Sub ShowFile(ByVal FilePath$)
    ' открывает файл FilePath$ в Проводнике Windows
    On Error Resume Next
    CreateObject("wscript.shell").Run "explorer.exe /e,/select,""" & FilePath$ & """"
End Sub

Sub ShowText(ByVal txt As String, Optional ByVal Index As Long)
    ' макрос сохраняет текст из переменной txt в текстовый файл
    ' (файл создаётся в папке для временных файлов, получает имя типа text####.txt,
    ' где #### - число, заданное через параметр index, или случайное 10-значное)
    ' После создания текстового файла он открывается в программе по-умолчанию (например, в Блокноте)

    On Error Resume Next: Err.Clear
    ' формируем имя для временного файла
    Filename$ = Environ("TEMP") & "\text" & IIf(Index, Index, Left(Rnd() * 1E+15, 10)) & ".txt"
    ' сохраняем текст в файл
    With CreateObject("scripting.filesystemobject").CreateTextFile(Filename, True)
        .Write txt: .Close
    End With
    ' открываем созданный файл
    CreateObject("wscript.shell").Run """" & Filename$ & """"
End Sub

Function ChangeFileCharset(ByVal Filename$, ByVal DestCharset$, _
                           Optional ByVal SourceCharset$) As Boolean
    ' функция перекодировки (смены кодировки) текстового файла
    ' В качестве параметров функция получает путь filename$ к текстовому файлу,
    ' и название кодировки DestCharset$ (в которую будет переведён файл)
    ' Функция возвращает TRUE, если перекодировка прошла успешно
    On Error Resume Next: Err.Clear
    With CreateObject("ADODB.Stream")
        .Type = 2
        If Len(SourceCharset$) Then .Charset = SourceCharset$    ' указываем исходную кодировку
        .Open
        .LoadFromFile Filename$    ' загружаем данные из файла
        FileContent$ = .ReadText   ' считываем текст файла в переменную FileContent$
        .Close
        .Charset = DestCharset$    ' назначаем новую кодировку
        .Open
        .WriteText FileContent$
        .SaveToFile Filename$, 2   ' сохраняем файл уже в новой кодировке
        .Close
    End With
    ChangeFileCharset = Err = 0
End Function

Function temp_folder$()
    On Error Resume Next
    temp_folder$ = Environ("TEMP") & "\ExcelTemporaryFiles\"
    If Dir(temp_folder$, vbDirectory) = "" Then MkDir temp_folder$
End Function

Function temp_filename$()
    On Error Resume Next: Dim iter&
get_rnd:     iter& = iter& + 1: txt$ = Left(Rnd(Now) * 1E+15, 10)
    temp_filename$ = temp_folder$ & "temp_file_" & Format(Now, "YYYY-MM-DD--HH-NN-SS") & "__" & txt$
    If Dir(temp_filename$, vbNormal) <> "" Then If iter& < 5 Then GoTo get_rnd
End Function





Attribute VB_Name = "ProgressIndicator"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
'---------------------------------------------------------------------------------------
' Class Module      : ProgressIndicator
' Автор     : EducatedFool  (Игорь)                    Дата: 07.10.2012
' Разработка макросов любой сложности для Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
' Реквизиты для оплаты работы: http://ExcelVBA.ru/payments
'---------------------------------------------------------------------------------------

Public FP As New F_Progress

Public SubActionIndex As Single, SubActionsCount As Single
Private FPVisible As Boolean, FPStartTime As Date, Position As Integer
Private PrS As Integer, PrE As Integer, Percent As Double, LogString As String

Public Parent As ProgressIndicator
Public ShowPercents As Boolean, ShowTime As Boolean, ShowTimeInLog As Boolean
Public Children As New Collection

Function AddChildIndicator(ByVal Caption As String, Optional ByVal FPPosition As Integer = 1) As ProgressIndicator
    ' создаёт дочерний индикатор, и отображает его
    On Error Resume Next
    Set AddChildIndicator = New ProgressIndicator
    Set AddChildIndicator.Parent = Me
    AddChildIndicator.Show Caption, FPPosition
    Children.Add AddChildIndicator
End Function

Private Sub Class_Initialize()
    ' параметры по умолчанию для вновь создаваемого индикатора
    Set FP = New F_Progress: ShowPercents = True: FPVisible = True
    PrS = 0: PrE = 100: Set_ProgressBar 0: FP.PrBar.Caption = ""
    FPStartTime = Now: ShowTime = True: ShowPercents = True
    Set FP.indicator = Me
End Sub

Sub Show(ByVal Caption As String, Optional ByVal FPPosition As Integer = 0, _
         Optional LogSize As Long = 0)
    ' отображает прогресс-бар
    On Error Resume Next
    SetProgressFormCaption Caption: On Error Resume Next:
    FP.PrBar.Width = ProgressBar_Default_Width
    Position = FPPosition
    FP.Tag = Caption: FP.Show:
    If Position <> 0 Then Move Position
    FP.Repaint: DoEvents
    SetLogSize LogSize
End Sub

Sub Hide(): Unload FP: FPVisible = False: End Sub    ' скрытие прогресс-бара

Sub Repaint()
    FP.Repaint: DoEvents
    If Application.ScreenUpdating = False Then
        Application.ScreenUpdating = True: Application.ScreenUpdating = False
    End If
End Sub

Sub Move(ByVal Position As Integer)    ' позиция прогресс-бара на экране по вертикали
    If Abs(Position) > 3 Then Exit Sub
    h = FP.Height
    If Not Me.Parent Is Nothing Then h = Me.Parent.FP.Height
    FP.Top = FP.Top + (h + 3) * Position
End Sub

Public Property Get Visible(): Visible = FPVisible: End Property

' установка заголовка формы и надписей на индикаторе
Public Property Let Line1(ByVal NewValue As String): FP.L1.Caption = ProcessLabel(NewValue): Me.FP.Repaint: DoEvents: End Property
Public Property Let Line2(ByVal NewValue As String): FP.L2.Caption = ProcessLabel(NewValue): Me.FP.Repaint: DoEvents: End Property
Public Property Let Line3(ByVal NewValue As String): FP.L3.Caption = ProcessLabel(NewValue): Me.FP.Repaint: DoEvents: End Property
Public Property Let Caption(ByVal NewValue As String): SetProgressFormCaption NewValue: End Property

Private Sub SetProgressFormCaption(Optional ByVal Caption As String = "")
    ' устанавливает заголовок формы прогресс-бара
    ' с учёток настроек (отображение таймера и процента выполнения)
    If Len(Caption) > 0 Then FP.Tag = Caption
    txt = Trim(FP.Tag): If ShowPercents Then txt = Fix(Percent) & " %   " & txt
    dt = Format(Now - FPStartTime, "HH:NN:SS")
    If ShowTime Then txt = "( " & dt & " )    " & txt
    FP.Caption = txt
End Sub

Private Function TimeToFinish() As String
    If Percent < 15 Then Exit Function    ' сложно предсказать время, когда всё только начинается...
    dt = (Now - FPStartTime) * (100 - Percent) / Percent
    TimeToFinish = IIf(Minute(dt) > 0, Minute(dt) & " мин. ", "") & Second(dt) & " сек."
    If dt < TimeSerial(0, 0, 1) Then TimeToFinish = "менее секунды"
    TimeToFinish = "Осталось до завершения: " & TimeToFinish
End Function

Sub SetFocus()    ' делает форму прогресс-бара активной
    FP.Show 0: If Position <> 0 Then Move Position
End Sub

Private Sub UpdateLabels(Optional ByVal L1_txt$, Optional ByVal L2_txt$, Optional ByVal L3_txt$)
    ' обновляем надписи на прогресс-баре (выводит только непустые строки)
    If L1_txt$ <> "" Then FP.L1.Caption = ProcessLabel(L1_txt$)
    If L2_txt$ <> "" Or L1_txt$ <> "" Then FP.L2.Caption = ProcessLabel(L2_txt$)
    If L3_txt$ <> "" Or L2_txt$ <> "" Or L1_txt$ <> "" Then FP.L3.Caption = ProcessLabel(L3_txt$)
End Sub

Private Function ProcessLabel(ByVal txt As String) As String
    ' заменяет ключевые слова в строке txt на значения параметров индикатора
    txt = Replace(txt, "$index", SubActionIndex)
    txt = Replace(txt, "$count", SubActionsCount)
    txt = Replace(txt, "$time", TimeToFinish)
    ProcessLabel = txt
End Function

Sub SubAction(Optional ByVal L1_txt$ = "", Optional ByVal L2_txt$ = "", Optional ByVal L3_txt$ = "")
    ' запуск операции внутри основного действия
    On Error Resume Next
    If SubActionsCount = 0 Then SubActionsCount = 1
    SubActionIndex = SubActionIndex + 1
    If SubActionIndex > SubActionsCount Then SubActionIndex = SubActionsCount
    Percent = PrS + (PrE - PrS) * ((SubActionIndex - 1) / SubActionsCount)
    UpdateLabels L1_txt$, L2_txt$, L3_txt$
    Set_ProgressBar Percent: DoEvents
End Sub

Sub StartNewAction(Optional ByVal Pr_Start As Integer = 0, Optional ByVal Pr_End As Integer = 100, _
                   Optional ByVal L1_txt$ = "", Optional ByVal L2_txt$ = " ", Optional ByVal L3_txt$ = " ", _
                   Optional ByVal Actions_Count As Long = 0)
    ' запуск нового действия - на шкале индикатора от Pr_Start % до Pr_End %
    ' в переменной Actions_Count получает количество операций внутри действия
    On Error Resume Next
    PrS = Pr_Start: PrE = Pr_End: SubActionIndex = 0: SubActionsCount = Actions_Count
    UpdateLabels L1_txt$, L2_txt$, L3_txt$
    Set_ProgressBar PrS
End Sub

Sub UpdateFromChild(ByVal ChildPercent As Double)
    ' отображение изменений на родительской форме при изменениях на дочерней
    If SubActionsCount = 0 Then
        Percent = PrS + (PrE - PrS) * (ChildPercent / 100)
    Else
        ' например, SubActionIndex = 3: SubActionsCount=10: PrS = 50: PrE = 100: ChildPercent=40
        ' результат д.б. в диапазоне от 60 до 65, а именно равен 62
        Percent = PrS + (PrE - PrS) / SubActionsCount * (SubActionIndex - 1) + _
                  (PrE - PrS) / SubActionsCount * (ChildPercent / 100)
    End If
    Set_ProgressBar Percent
End Sub

Private Sub Set_ProgressBar(ByVal NewPercent As Double)
    ' изменение ширины индикатора
    Percent = NewPercent
    If NewPercent > 100 Then Percent = 100
    If NewPercent < 0 Then Percent = 0
    FP.PrBar.Width = Int(Percent * ProgressBar_Default_Width / 100)
    SetProgressFormCaption
    FP.Repaint
    If Not Parent Is Nothing Then Parent.UpdateFromChild Percent
End Sub

'Private Function GetCurrentProgress() As Long    ' возвращает текущий процент выполнения
'    If FP.PrBar.Width = 0 Then Exit Function
'    GetCurrentProgress = FP.PrBar.Width / ProgressBar_Default_Width * 100
'End Function

Private Sub Class_Terminate()    ' уничтожение экземпляра класса
    On Error Resume Next
    Unload FP: FPVisible = False
End Sub

Private Function ProgressBar_Default_Width() As Double    ' установка размера полосы по размеру формы
    ProgressBar_Default_Width = FP.Width - 18
End Function

Function CancelButton() As MSForms.CommandButton
    Set CancelButton = FP.CommandButton_stop
End Function

' ============================== обновление от 23.02.2012 =========================================
Sub SetLogSize(ByVal n As Long)
    On Error Resume Next
    If n < 0 Then n = 0
    If n > 5 Then n = 5
    FP.SpinButton_log.Value = n
    FP.SpinButton_log.Visible = n > 0
End Sub

Sub Log(ByVal txt$)
    On Error Resume Next
    If ShowTimeInLog Then currtime$ = Time & vbTab
    LogString = LogString & vbNewLine & currtime$ & txt
    FP.TextBox_Log.Text = Mid(LogString, 3)
    If FP.SpinButton_log.Value = 0 Then FP.SpinButton_log.Value = 2: FP.SpinButton_log.Visible = True
    FP.CommandButton_stop.SetFocus: FP.TextBox_Log.SetFocus
End Sub

Sub ClearLog()
    LogString = "": FP.TextBox_Log.Text = ""
End Sub

Sub ShowLog()
    On Error Resume Next: Err.Clear
    Filename$ = Environ("TEMP") & "\macro_log.txt"    ' формируем имя для временного файла
    With CreateObject("scripting.filesystemobject").CreateTextFile(Filename, True)
        .Write Mid(LogString, 3): .Close    ' сохраняем текст в файл
    End With
    CreateObject("wscript.shell").Run """" & Filename$ & """"    ' открываем созданный файл
End Sub

Sub ShowText(ByVal txt As String, Optional ByVal Index As Long)
    ' макрос сохраняет текст из переменной txt в текстовый файл
    ' (файл создаётся в папке для временных файлов, получает имя типа text####.txt,
    ' где #### - число, заданное через параметр index, или случайное 10-значное)
    ' После создания текстового файла он открывается в программе по-умолчанию (например, в Блокноте)

    On Error Resume Next: Err.Clear
    ' формируем имя для временного файла
    Filename$ = Environ("TEMP") & "\text" & IIf(Index, Index, Left(Rnd() * 1E+15, 10)) & ".txt"
    ' сохраняем текст в файл
    With CreateObject("scripting.filesystemobject").CreateTextFile(Filename, True)
        .Write txt: .Close
    End With
    ' открываем созданный файл
    CreateObject("wscript.shell").Run """" & Filename$ & """"
End Sub

' ============================== обновление от 07.10.2012 =========================================

Sub AddButton(ByVal Caption$, ByVal Macro$)    ' добавление кнопки запуска макроса
    dd = 18
    If FP.SpinButton_log = 0 Then FP.SpinButton_log = 1
    With Me.FP.CommandButton_RunMacro
        .Caption = Caption$
        .Visible = True
        .Top = FP.Height - .Height - dd - 20
        .Left = FP.Width - .Width - dd - 15
    End With
    FP.ButtonMacro = Macro$
End Sub

Function MacroButton() As MSForms.CommandButton
    Set MacroButton = FP.CommandButton_RunMacro
End Function

Sub QueryClose()    ' вызывается из формы, при попытке её закрытия
    On Error Resume Next
    Dim pi As ProgressIndicator
    For Each pi In Children
        pi.QueryClose
        pi.Hide
    Next pi
End Sub

Attribute VB_Name = "mod_About"
'---------------------------------------------------------------------------------------
' Module        : mod_About
' Автор     : EducatedFool  (Игорь)                    Дата: 20.08.2012
' Разработка макросов любой сложности для Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
' Реквизиты для оплаты работы: http://ExcelVBA.ru/payments
'---------------------------------------------------------------------------------------


Option Compare Text
Public Const VERSIONS_XML_FILENAME$ = "info.xml", DEMO_ACTIVATION_CODE$ = "demo", MODULE_VERSION = 8
Public cnt As Long, 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

Private Sub auto_open()
    On Error Resume Next
    If IsFirstRun Then
        SetValuesOnFirstRun
        If IsObject(F_Greeting) Then
            ND "run test", "Знакомство с программой" & vbLf & CountersCurrentValues
            F_Greeting.Show
        End If
    Else
        ND "addin open", CountersCurrentValues
    End If
    a = vbCheck: Dim msg$
    If PL_(msg, True) Then Exit Sub
    If CBool(Val(RSP(5))) Then Application.OnTime Now + TimeSerial(0, 0, 5), "AutoInstallUpdate"
    CreateProgramCommandBar    ' создание панели инструментов
End Sub

Private Sub auto_close()
    On Error Resume Next
    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-serial.php"
End Function
Function BL_HYPERLINK$()
    BL_HYPERLINK$ = DEVELOPER_WEBSITE$ & "php/black-list.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$()
    PROJECT_NAME$ = GHV(ChrW(80) & ChrW(82) & ChrW(79) & ChrW(74) & ChrW(69) & ChrW(67) & ChrW(84) & ChrW(95) & ChrW(78) & ChrW(65) & ChrW(77) & ChrW(69))
    If PROJECT_NAME$ = "" Then
        appname$ = ThisWorkbook.BuiltinDocumentProperties("Application Name")
        If appname$ <> Application.Name Then PROJECT_NAME$ = appname$
    End If
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"    ' чтобы избежать кеширования
…