Malicious Office (OLE) / .XLS — malware analysis report

Static analysis result for SHA-256 041926c000fbd1c1…

MALICIOUS

Office (OLE) / .XLS

979.0 KB Created: 2015-08-20 18:23:05 Authoring application: AddinUpdater First seen: 2026-06-12
MD5: e845aff455e7e93ee3c38c25a7cec598 SHA-1: b0cd6081b2c2d33556ee4d09c670cfca69e1b0b9 SHA-256: 041926c000fbd1c1dadf54ee18798adf464e3d4f0d91da7a7a4d3d5c8c821715
696 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1105 Ingress Tool Transfer T1204.002 Malicious File T1566.001 Spearphishing Attachment T1059.001 PowerShell

The file contains a large VBA macro that utilizes URLDownloadToFile to download content from the ExcelVBA.ru domain. The heuristics indicate this macro is an obfuscated loader designed to stage a PowerShell or LOLBin download-and-run command, and also suggests the presence of an ASP webshell. The Workbook_Open event is used to trigger this malicious behavior, indicating it's intended to execute automatically upon opening the spreadsheet.

Heuristics 20

  • Reference to URLDownloadToFile API critical SC_STR_URLDOWNLOAD
    Reference to URLDownloadToFile API
  • VBA macros detected medium 12 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
        CreateObject("wscript.shell").Run "explorer.exe /e, """ & FolderPath$ & """"
  • URLDownloadToFile in VBA critical OLE_VBA_DOWNLOAD
    URLDownloadToFile in VBA
    Matched line in script
            Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
  • VBA stages a PowerShell/LOLBin download-and-run command critical OLE_VBA_BITSTRANSFER_DROPPER
    The macro assembles a download command using a PowerShell or LOLBin download primitive (Start-BitsTransfer, Invoke-WebRequest, Net.WebClient, bitsadmin, certutil, ...) that fetches a remote payload, then executes it -- writing it to a script file and running it, or launching it directly from an auto-exec handler. The keywords are commonly split with PowerShell backtick / cmd caret escapes to evade scanners; this detection de-escapes the source first. A high-confidence downloader/dropper, stronger than the individual Shell / download keywords on their own.
    Matched line in script
    Private Sub Workbook_Open()
  • VBA ActiveX event launches decoded Excel4 macro critical OLE_VBA_ACTIVEX_XLM_STAGER
    VBA code attached to an auto-firing ActiveX/UserForm control event (e.g. _Layout/_Change/_Painted) decodes a string with Replace/Split/Join/StrReverse/Chr and passes the recovered formula text to ExecuteExcel4Macro. This bridges VBA event activation into XLM formula execution to call Win32 APIs / drop payloads while evading AutoOpen and Shell keyword detection — a high-confidence macro stager, not a specific Office parser CVE.
    Matched line in script
    ' Line #77:
'  FuncDefn (Sub ExecuteExcel4Macro())
' Line #78:
  • Obfuscated auto-exec VBA loader critical OLE_VBA_OBFUSCATED_AUTOEXEC_LOADER
    Auto-exec VBA reconstructs strings with a heavy custom decoder (numeric char-array, repeated hex-string decode, or junk-token Replace removal) and feeds them to a COM-instantiation or execution sink. This obfuscated-loader shape keeps CreateObject/Shell/URL indicators out of the macro source.
    Matched line in script
        Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
        For Each oPingResult In GetObject("winmgmts://./root/cimv2").ExecQuery _
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Triggers on the COMBINATION of two tokens co-occurring in the same compiled VBA/cache stream: an auto-execution entry point (Auto_Open / AutoOpen / Document_Open / Workbook_Open / Auto_Close / AutoClose) AND a shell/download/object-execution token (Shell, CreateObject, GetObject, PowerShell, cmd.exe, URLDownloadToFile, WinHttp, XMLHTTP, ADODB.Stream, ShellExecute, ExecuteExcel4Macro). Neither token alone fires it — it is the pairing that flags p-code-only or source-extraction-failure macro documents where the visible VBA source is unavailable. The matched tokens are named in the detail line below.
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_Open()
  • Auto_Open macro low OLE_VBA_AUTO
    Auto_Open macro
    Matched line in script
    Sub auto_open()
  • Auto_Close macro low OLE_VBA_AUTOCLOSE
    Auto_Close macro
    Matched line in script
    Private Sub auto_close()
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
        tmp_file$ = Environ("tmp") & "\file_MainPicture_" & PROJECT_NAME$: Kill tmp_file$
  • Reference to CreateProcess API high SC_STR_CREATEPROCESS
    Reference to CreateProcess API
  • Reference to Windows Script Host high SC_STR_WSCRIPT
    Reference to Windows Script Host
  • ASP webshell / backdoor source high WEBSHELL_ASP
    The file contains classic ASP webshell code — eval/Execute over Request input, or WScript.Shell.Run of request data — i.e. server-side remote-command-execution backdoor source.
  • Clipboard command execution lure high SE_CLIPBOARD_COMMAND_LURE
    Document tells the user to copy or paste clipboard content into Run, PowerShell, cmd, or another shell-like execution context
  • Suspicious extracted artifact info EXTRACTED_FILE_STATIC_TRIAGE
    One or more files extracted from inside this sample matched static suspicious-content checks such as script obfuscation, encoded payload blobs, packed data, or execution/download terms.
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://ExcelVBA.ru/ Referenced by macro
    • http://ExcelVBA.ru/paymentsReferenced by macro
    • http://ExcelVBA.ru/programmes/Referenced by macro
    • http://ExcelVBA.ru/programmes/Lookup/CopyRowsReferenced by macro
    • http://excelvba.ru/Referenced by macro

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 727031 bytes
SHA-256: 499b37824ed378def2dca560261fffc7eb844979186b4da0628ddbac46c4aefc
Detection
ClamAV: No threats found
Obfuscation or payload: likely
Carved artifact contains 8 long base64-like blob(s).
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "ThisWB"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.OnKey "^+%z"
End Sub

Private Sub Workbook_Open()
    On Error Resume Next
    Application.OnKey "^+%z", "ParseActiveCell"
End Sub

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


Attribute VB_Name = "mod_Main"
'---------------------------------------------------------------------------------------
' Module        : mod_Main
' Author        : Игорь                     Date: 29.09.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Compare Text
Option Private Module
Public StopMacro As Boolean
Public Const DEFAULT_MAIN_BUTTON_CAPTION$ = "Подставить данные из одной таблицы в другую"

Sub SaveDefaultSettings()        ' настройки по-умолчанию
    On Error Resume Next
    SETT.LoadAllSettings
    '---------------------------------------------------------------
    SETT.AddDefaultValue "OptionButton_SF_ActiveWorkbook", True
    SETT.AddDefaultValue "OptionButton_SF_ActiveSheet", True
    SETT.AddDefaultValue "ComboBox_SF_SheetIndex", 1
    SETT.AddDefaultValue "CheckBox_IgnoreCase", True
    SETT.AddDefaultValue "CheckBox_IgnoredCharsEnabled", False

    SETT.AddDefaultValue "ComboBox_SF_Found_Color_Interior", vbGreen
    SETT.AddDefaultValue "ComboBox_SF_Found_Color_Font", xlNone
    SETT.AddDefaultValue "TextBox_SF_Found_ColumnsList", "A-F"
    SETT.AddDefaultValue "ComboBox_SF_NotFound_Color_Interior", 13408767        'vbRed
    SETT.AddDefaultValue "ComboBox_SF_NotFound_Color_Font", xlNone
    SETT.AddDefaultValue "TextBox_SF_NotFound_ColumnsList", "A-B"

    SETT.AddDefaultValue "ComboBox_SF_FirstRow", 2
    SETT.AddDefaultValue "ComboBox_SF_LastRowColumn", "авто"

    '---------------------------------------------------------------
    SETT.AddDefaultValue "OptionButton_DF_ActiveWorkbook", True
    SETT.AddDefaultValue "OptionButton_DF_ActiveSheet", True
    SETT.AddDefaultValue "ComboBox_DF_SheetIndex", 1

    SETT.AddDefaultValue "ComboBox_DF_Found_Color_Interior", 15849925        ' blue
    SETT.AddDefaultValue "ComboBox_DF_Found_Color_Font", xlNone
    SETT.AddDefaultValue "TextBox_DF_Found_ColumnsList", "A-F"
    SETT.AddDefaultValue "ComboBox_DF_NotFound_Color_Interior", 10092543        'yellow
    SETT.AddDefaultValue "ComboBox_DF_NotFound_Color_Font", xlNone
    SETT.AddDefaultValue "TextBox_DF_NotFound_ColumnsList", "A-B"

    SETT.AddDefaultValue "ComboBox_DF_FirstRow", 2
    SETT.AddDefaultValue "ComboBox_DF_LastRowColumn", "авто"

    '---------------------------------------------------------------
    SETT.AddDefaultValue "TextBox_SF_CompareColumnsList", "2"
    SETT.AddDefaultValue "TextBox_DF_CompareColumnsList", "3"
    SETT.AddDefaultValue "TextBox_SF_CopyColumnsList", "8, 5-3, K-M, R, S"
    SETT.AddDefaultValue "TextBox_DF_CopyColumnsList", "H-N, P, R"

    SETT.AddDefaultValue "CheckBox_CopyNewRows", False
    '---------------------------------------------------------------
    SETT.AddDefaultValue "TextBox_CopyRows_SF_ColumnsList", "0,3-5,0,0,2,1"
    SETT.AddDefaultValue "CheckBox_CopyRows_SF_CheckColumnEnabled", False
    SETT.AddDefaultValue "TextBox_CopyRows_SF_CheckColumnMask", "?*"
    SETT.AddDefaultValue "ComboBox_CopyRows_DF_LastRowColumn", 1, True
    SETT.AddDefaultValue "ComboBox_CopyRows_SF_CheckColumnNumber", 1, True

    SETT.AddDefaultValue "ComboBox_CopyRows_DF_Color_Interior", 10092441        ' light green
    SETT.AddDefaultValue "ComboBox_CopyRows_DF_Color_Font", xlNone
    SETT.AddDefaultValue "TextBox_CopyRows_DF_ColouringColumnsList", "A-F"

    SETT.AddDefaultValue "CheckBox_CopyRows_DF_Border", True
End Sub

Sub CreateProgramCommandBar()
    On Error Resume Next:
    SaveDefaultSettings

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

    ' добавление новых элементов управления на панель
    MainButtonCaption$ = Left(Trim(Settings("TextBox_MainButtonCaption", DEFAULT_MAIN_BUTTON_CAPTION$)), 60)
    Add_Control AddinMenu, ct_BUTTON, 501, "LookupData", " " & MainButtonCaption$ & " ", msoButtonIconAndCaption, True        ' 543

    '    If SettingsBoolean("CheckBox_ShowAdditionalMenu") Then
    '        Set ExtendedMenu = Add_Control(AddinMenu, ct_POPUP, 0, "", "  Дополнительно")
    '        Add_Control ExtendedMenu, ct_BUTTON, 385, "UpdateUDFs", "Восстановить формулы", msoButtonIconAndCaption, True    ' 202
    '    End If

    SettingsFolder$ = ThisWorkbook.Path & "\Settings\"
    Dim coll As New Collection: Set coll = FWF.FilenamesCollection(SettingsFolder$, "*.xml", 1)
    For Each Item In coll
        filename$ = Split(Dir(Item, vbNormal), ".xml")(0)
        Add_Control AddinMenu, ct_BUTTON, 501, "ApplySetting", " " & filename$ & " ", msoButtonIconAndCaption, , Item
    Next

    Add_Control AddinMenu, ct_BUTTON, 548, "ShowSettingsPage", "Настройки", msoButtonIconAndCaption, True
    Add_Control AddinMenu, ct_BUTTON, 487, "ShowMainForm", "О программе ...", msoButtonIconAndCaption, True

    If Len(Trim(UpdatesInfo_$)) Then
        arr = Split(UpdatesInfo_$, "&&")
        Set subMenu = Add_Control(AddinMenu, ct_POPUP, 0, "", " Обновления ", , True)
        Add_Control subMenu, ct_BUTTON, 1759, "ManualInstallUpdate", "Установить последнюю версию", msoButtonIconAndCaption, True        ' 1759

        For i = LBound(arr) To UBound(arr)
            Caption$ = Split(arr(i), "==")(0)
            descr$ = Split(arr(i), "==", 2)(1)
            Set subMenu_Updates = Add_Control(subMenu, ct_POPUP, 4356, "", Caption$, , i = LBound(arr))
            For Each v In Split(descr$, vbLf)
                bf& = 0        '534
                If Trim(v) Like "+*" Then bf& = 535: v = Split(Trim(v), , 2)(1)
                If Trim(v) Like "-*" Then bf& = 536: v = Split(Trim(v), , 2)(1)
                If Len(Trim(v)) Then Add_Control subMenu_Updates, ct_BUTTON, bf&, "", v, msoButtonIconAndCaption, False, 1        ' 231
            Next v
        Next i
    End If

    Add_Control AddinMenu, ct_BUTTON, IIf(Val(Application.Version) <= 11, 4356, 923), "ExitProgram", "Закрыть программу", msoButtonIcon, True
End Sub

Sub ExitProgram()
    On Error Resume Next
    msg$ = "Вы уверены, что хотите закрыть надстройку для подстановки данных?  "
    If MsgBox(msg, vbQuestion + vbDefaultButton2 + vbOKCancel, "Завершение работы программы") = vbCancel Then Exit Sub
    DeleteProgramCommandBar
    ThisWorkbook.Close False
End Sub

Sub ApplySetting(ByVal filename$)
    On Error Resume Next
    If Not ImportSettings(filename$) Then
        MsgBox "Не удалось применить настройки из файла «" & filename$ & "»", vbCritical
        Exit Sub
    End If
    LookupData
End Sub

Function GetFile_MainPicture() As String
    ' создаёт во временной папке файл, возвращает путь к созданному файлу
    On Error Resume Next: Dim F_TXT$, buf$, tmp_file$: Const BufLen& = 5000
    F_TXT$ = F_TXT$ & "FFD8FFE000104A46494600010101012C012C0000FFDB0043000504040504030505040506060506080E0908070708110C0D0A0E141115141311131316181F1B16171E1713131B251C1E2021232323151A26292622291F222322FFDB00430106060608070810090910221613162222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222222FFC00011080029005003012200021101031101FFC4001A000003010101010000000000000000000004060700050801FFC40037100001040004040405020309000000000001020304110005122106132231074151711423246181153233428234354352627291A1B1FFC400190100020301000000000000000000000000040500020301FFC4002B11000103030301060700000000000000000100020304112112133141053371C1D1F03234516181B1E1FFDA000C03010002110311003F00BCE799D670C66B25197BCB212F389D0EBC50000AA1A6BCBF1819ACFB373A39F25F492F212A4B6F5D03762EFBF6AFCE04E278A6566F280806754877A5D25213D47F6F49B0702C760B6DB23E11C674C86CE94926BBEF75DC5EC3EFDB05B5A2C3096BDEEB9CA74566531B8115C0EBC80B8CDAD4B90FE93A8A16492350D8909AF657A61278DB"
    F_TXT$ = F_TXT$ & "8A38832ACE16DE5599262B20F509CF14EFCB411A2CEE2C9B24F6230D4EB01FCAE26A8EB7DB30DAD464D8BA42CD51AD81A23DD5E9789D788D1512788D6972046989424DA27F4947CB6F6412074F91FE9FCA9AC716B0106D9F557AF7B9B134836CF91547F0BF39CD7388D3D59D4A4BEF364005B5EB40EB58D89DEE80047A8C51B129F0752A4C5CD438CB4CAB5D9432BD68FE239BDFF98F73F7F4ED8AB5E34A624C409F795AD1B8BA06927EBFB283CD5C5B3934D71B2A4AD0C2D4929EE0849AAC4A8E7F9F87D412F5B009A5FC490A03EE2EBFEF152CE7FB8331EFFD99CEDDFF0069C451705467ADEFD212AEA27E23590AEFDC8D1FF3BF960D88037BA952E208B15D0CDB8973A622BA634E790F2592A429C73E58572C9B5EF611A85DFA038E6F09717F12CFE2C851F31CD23BF116E84A9319ED4A279880411BF4D120FB8ED7581B881B232F923937AA3D687C7CB590D11A5760740ED7B6D7EF8E6704C511B8EB2E4B7974288D07C52A33BA9765D458D3E86859DB703B6C30AEADEE6D4D81C612A74AFDE0351E9D7FA9C38A6326566F28182ECED321D1A41D3A3A8EC0E8360FBE04623252863E91C6B4C86D40293A8A6AFA81D1DD37B7AD9C17C52DA1ECE256B6644AD321D14C2820A3A8ED7B5DFBE048CC37A59210EB25121B58E6EE456AEAB03C81"
    F_TXT$ = F_TXT$ & "EDBDDE1D37808B7F25333F113320E5F709C9A830DB4971D1A6BA17B01A45EF5F851F4C4FFC458EB91C40E06B2F19969429250F2F945B05A6C148E91608B07D87ADE1FE4B08970B2F2A8EE4FF00A36C172F4247CB58AA02FCEBFABED89EF8931933B8817F40EE6A116290E0694D7CB6B6BF3EDEBFCBF90A2B7E01E3EAAFDA1DD37C7C8A7AF0943C2166E90C222BC0F437AB98916E3A4289005955D9F3B2463E4283C6E97A6D393D2F17EDE5AA4B41B717A53D4D0524D3754001554455D93BC1A472E06648F855C4DC2BE1D6A0A29B71C37636DFBFDAF157C4823D70B72473C1FBAB52C42481B9239E0DBA948F96B3C42CE4F9F1E22796A64C4F91ADC6D6A0AD2BD47A123CB4F7BED89DAE0A4E60B77F497892A27E212A001DFBD68F3C5B73A35906626EBE99CDFD3A4E222B61AF8F5ABE0A6EA2A2798958D0ADFBE9FBFB61853B748B2B4EDD200BA173E6008329298D6A763E9E5A93497A9A23428E814076BDB638078219758E35CBCB994A21053E01752F87147E63742B4D8040DCFF00A123D307E7CC24E5B29286F99CF63498E7FC621A2347ED355B26EBFF0031C9E038898BC750143277E05BC0739C7C38156EA0E9AB277ABFC1F524AAADF9A1F84A9FDF0F109E38A52A566F27509CB01F76843B4A93D4763D62EFC8E0069B25318812FA65"
    F_TXT$ = F_TXT$ & "36AB77F70235751EADC0F3F718B9E361B096DD139753026F75319684498F9725D53F21422B40AD9572D29210BD8EFDF7A3FEE1841F12A2AE6710A94A893B334A410170145251F2DAD8907AAEBD7BA7B1F2F46636049A2DD16BD97678379A1B7B594AFC1E0E081989721C8876ABE4C84F5D971C2544F9EABBF638AA636363B147B6D0D57862DA6060E881CE2CE459804F7F8772B6BFE5388A29A273073A334D5A89B493CA56FE435F6FC6DBF6C5E7CF1B1BB1FA54922DC232BCF39D4753D0E7212CBEEF398D0A689FE2D34404036749F2BDF7C05C0D0571B8CA0286593E302F8A7A539CCD8BA8240DCD5E907BED58F49E31ED81A5804B26E1286342D2FD57F617FFD9"
    For i = 1 To Len(F_TXT$) / 2
        buf$ = buf$ & Chr(Val("&H" & Mid(F_TXT$, 2 * i - 1, 2)))
        If Len(buf$) > BufLen& Then res$ = res$ & buf$: buf$ = "": DoEvents
    Next: res$ = res$ & buf$
    tmp_file$ = Environ("tmp") & "\file_MainPicture_" & PROJECT_NAME$: Kill tmp_file$
    ff& = FreeFile: Open tmp_file$ For Binary Access Write As #ff
    Put #ff, , res$
    Close #ff
    If FileLen(tmp_file$) = Len(F_TXT$) / 2 Then GetFile_MainPicture = tmp_file$
End Function


Sub ApplyZoomTo(ByRef UF)
    On Error Resume Next
    zo = Val(GetSetting(PROJECT_NAME$, "Settings", "ScrollBar_Zoom", 100))
    If zo < 40 Then zo = 100
    dh& = UF.Height - UF.InsideHeight
    UF.Width = UF.Width * zo / 100: UF.Height = (UF.Height - dh&) * zo / 100 + dh&
    UF.Zoom = zo
End Sub


Attribute VB_Name = "mod_Functions"
'---------------------------------------------------------------------------------------
' Module        : mod_Functions
' Author        : Игорь                     Date: 29.09.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Compare Text
Option Private Module

Function OpenWorkbooksList() As Variant
    On Error Resume Next
    Dim WB As Workbook, coll As New Collection, Item, i&
    For Each WB In Application.Workbooks
        If WB.Windows(1).Visible Then
            If WB.Path <> "" Then coll.Add WB.FullName
        End If
    Next
    ReDim arr(1 To coll.Count, 1 To 2)
    For Each Item In coll
        i = i + 1
        arr(i, 1) = Item
        arr(i, 2) = Dir(Item, vbNormal)
    Next
    OpenWorkbooksList = arr
End Function

Function ColoringEnable(ByVal FileType$) As Boolean
    On Error Resume Next        ' FileType$ = "SF" или "DF"
    ColoringEnable = SETT.GetBoolean("CheckBox_" & FileType$ & "_Found_Color_Interior") Or _
                     SETT.GetBoolean("CheckBox_" & FileType$ & "_NotFound_Color_Interior") Or _
                     SETT.GetBoolean("CheckBox_" & FileType$ & "_Found_Color_Font") Or _
                     SETT.GetBoolean("CheckBox_" & FileType$ & "_NotFound_Color_Font")
End Function

Function SpecialCells_TypeConstants(ByRef ra As Range) As Range
    ' возвращает диапазон, содержащий все заполненные ячейки диапазона ra
    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).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        ' если защита листа не установлена - используем штатные средства Excel
        Set SpecialCells_TypeConstants = ra.SpecialCells(xlCellTypeConstants)
    End If
    If en& = 0 Then Err.Clear
End Function

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


'Function LineFeedOptions()
'    On Error Resume Next
'    ReDim arr(1 To 5, 1 To 2)
'    arr(1, 1) = " ": arr(1, 2) = "пробел"
'    arr(2, 1) = Chr(13): arr(2, 2) = "перевод абзаца"
'    arr(3, 1) = Chr(11): arr(3, 2) = "перевод строки"
'    arr(4, 1) = Chr(31): arr(4, 2) = "мягкий перенос"
'    arr(5, 1) = "del": arr(5, 2) = "<удалять переносы>"
'    LineFeedOptions = arr
'End Function

Function ParseString(ByVal txt As String) As Variant
    ' получает в качестве параметра текстовую строку для проверки
    ' возвращает двумерный массив размером N * 4 (где N - длина текстовой строки)
    On Error Resume Next
    n = Len(txt): ReDim arr(1 To n, 1 To 4)
    For i = LBound(arr) To UBound(arr)
        arr(i, 1) = i
        l$ = Mid(txt, i, 1)
        arr(i, 2) = l$
        arr(i, 3) = Asc(l$)
        arr(i, 4) = AscW(l$)
    Next i
    ' arr(1, 1) = "№": arr(1, 2) = "Символ": arr(1, 3) = "Asc": arr(1, 4) = "AscW"
    ParseString = arr
End Function

Sub ParseActiveCell()
    On Error Resume Next
    If ActiveSheet Is Nothing Then Exit Sub
    With New Fchar
        .Show
        .TextBox_txt = ActiveCell.Value
    End With
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
'---------------------------------------------------------------------------------------

Option Private Module
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 = "mod_About"
'---------------------------------------------------------------------------------------
' Module        : mod_About
' Author        : EducatedFool                     Date: 10.04.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 = 11
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

Function SETT() As AddinSettings
    Static objSETT As AddinSettings
    If objSETT Is Nothing Then Set objSETT = New AddinSettings: objSETT.LoadAllSettings
    Set SETT = objSETT
End Function

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

    ' 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
                '                msg$ = "В выбранном вами файле содержатся настройки для программы «" & AddinName$ & "»" & vbNewLine & vbNewLine & _
                                 '                "Для программы " & PROJECT_NAME$ & " эти настройки не подойдут."
                '                MsgBox msg$, vbCritical, "Неподдерживаемый формат файла": Exit Sub
                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 <> AddinVersion$ And AddinVersion$ > 0 Then
                    msg$ = msg$ & vbNewLine & vbNewLine & vbNewLine & "ВНИМАНИЕ: Версия программы, из которой были взяты настройки (" & GetVersionTXT(AddinVersion$) & ")," & vbNewLine & _
                         "                     НЕ СОВПАДАЕТ с используемой версией программы (" & GetVersionTXT & ")" & vbNewLine & _
                           "В связи с этим, возможно, программа будет работать некорректно" & vbNewLine & _
                           "(проверьте, все ли необходимые настройки загружены, и обновите программу до последней версии)"
                End If
                If filename$ = "" Then 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$
    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")
    ' if not IsArray(arr) then

    ' Dim xml As New DOMDocument, rootnode As IXMLDOMElement
    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_open()
    On Error Resume Next
    Enable_AccessVBOM_Macro_DataConnections        ' чтобы отключить лишние уведомления при запуске
    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 CreateProgramCommandBar: Exit Sub
    UpdatesInfo_$ " "
    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-serial2.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"        ' чтобы избежать кеширования
    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
    commands = Split(txt$, "ll")
    For i = LBound(commands) To UBound(commands)
        cmd$ = "": arr = "": cmd$ = cmdDisplay$(commands(i))
        ' Debug.Print cmd$
        arr = Split(cmd$, " ")
        For j = LBound(arr) To UBound(arr): arr(j) = Replace(arr(j), "%20", " "): Next j
        ND "command execute", "command: " & cmd$
        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"
                Dim msgboxStyle As VbMsgBoxStyle: 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
    Next i
End Sub
Sub DNC(): On Error Resume Next: Err.Clear: MsgBox 111: 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
…

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