Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ThisWB"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
'---------------------------------------------------------------------------------------
' Module        : ThisWB                    Version:
' Author        : Igor Vakhnenko                   Date: 18.05.2016
' 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
    DeleteProgramCommandBar

    Application.OnKey "^."
    Application.OnKey "^,"
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

    Dim X
    X = SETTINGS_FOLDER$
    X = OUTPUT_FOLDER$
    X = PRICE_FOLDER$

    Application.OnKey "^.", "ShowNextWorkbook"
    Application.OnKey "^,", "ShowPrevWorkbook"
End Sub


Attribute VB_Name = "shsett"
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
'---------------------------------------------------------------------------------------
' VBA Document      : shsett
' Автор     : EducatedFool  (Игорь)                    Дата: 17.08.2012
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
' Реквизиты для оплаты работы: http://ExcelVBA.ru/payments
'---------------------------------------------------------------------------------------

Dim CBR_RATES_LastUpdateTime As Date

Sub HideSheets_And_SaveAddin()
    On Error Resume Next: Err.Clear
    msg$ = "После нажатия ОК, листы файла программы будут скрыты," & vbNewLine & _
           "и файл программы будет сохранён." & vbNewLine & vbNewLine & _
           "Сохранение изменений может занять несколько секунд..."
    If MsgBox(msg, vbQuestion + vbOKCancel, "Сохранение настроек на листах программы") = vbCancel Then Exit Sub
    ThisWorkbook.IsAddin = True
    ThisWorkbook.Save
    Application.ScreenUpdating = True
    MsgBox "Изменения сохранены", vbInformation
End Sub

Sub UpdateAllRatesFromButton()
    If UpdateAllRates(True) Then
        MsgBox "Курсы валют успешно обновлены в " & Now, vbInformation, "Готово"
    Else
        MsgBox "При обновлении курсов валют с сайта ЦБ РФ произошла ошибка", vbExclamation, _
               "Невозможно обновить курсы валют"
    End If
End Sub

Function UpdateAllRates(Optional ByVal ForceUpdate As Boolean = False) As Boolean
    ' функция загружает курсы валют
    On Error Resume Next:    ' RateDate = Now
    If Not ForceUpdate Then If Now - CBR_RATES_LastUpdateTime < TimeSerial(5, 0, 0) Then Exit Function
    ' загружаем данные с ЦБ РФ
    Dim xml As DOMDocument, node As IXMLDOMElement
    Set xml = CreateObject("MSXML.DOMDocument"): xml.async = False
    url_request = "http://www.cbr.ru/scripts/XML_daily.asp"    '?date_req=" + Format(RateDate, "dd\/mm\/yyyy")
    If xml.Load(url_request) <> True Then Exit Function    ' Запрос к серверу ЦБР

    Dim ra As Range: Set ra = Me.Range(Me.[A2], Me.Range("A" & Me.Rows.Count).End(xlUp))

    For Each node In xml.SelectNodes("*/Valute")
        CurrencyName$ = node.SelectSingleNode("CharCode").Text
        CurrencyRate = CDbl(node.SelectSingleNode("Value").Text)
        divisor = Val(node.SelectSingleNode("Nominal").Text)
        'Debug.Print CurrencyName, CurrencyRate, divisor
        ra.Find(CurrencyName$, , xlValues, xlWhole).Next.Next = CurrencyRate / divisor
    Next

    UpdateAllRates = True: Err.Clear
    CBR_RATES_LastUpdateTime = Now
    ThisWorkbook.Saved = True
End Function

Attribute VB_Name = "Module_SplitCSV"
'---------------------------------------------------------------------------------------
' Module        : Module_SplitCSV
' Author        : EducatedFool                     Date: 11.08.2014
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Sub test_split_csv()
    On Error Resume Next
    filename$ = "D:\ПРОЕКТЫ\- Мои проекты - Excel\Unification\split CSV - test files\prays-69483.csv"
    filename$ = "D:\ПРОЕКТЫ\- Мои проекты - Excel\Unification\split CSV - test files\TOYOTA.txt"

    MaxRowsCount& = 50000

    Dim СписокИмёнФайлов As Collection
    Set СписокИмёнФайлов = SplitTextFile(filename$, "", MaxRowsCount&, vbNewLine, False)

    For Each Файл In СписокИмёнФайлов
        Debug.Print "Создан файл: " & Файл
    Next
End Sub


Function SplitTextFile(ByVal filename$, Optional ByVal DestFolder$, Optional ByVal MaxRowsCount& = 10000, _
                       Optional ByVal Delimiter$ = vbNewLine, Optional ByVal DeleteSourceFile As Boolean = True) As Collection
    ' Функция предназначена для разбивки текстового файла filename$ на несколько файлов
    ' меньшего размера - в каждом из которых будет не более MaxRowsCount& строк
    ' Разделение строк выполняется с использованием разделителя Delimiter$
    ' Создаваемые в папке DestFolder$ файлы получают имена вида part000001.filename.txt, part000002.filename.txt и т.д.
    ' если путь к папке DestFolder$ не задан - файлы создаются в папке с исходным файлом
    ' Возвращает коллекцию имён созданных файлов

    Dim source_filename$, source_folder$, InputFN As Integer, OutputFN As Integer, txt$, rc&, FilePart&
    Set SplitTextFile = New Collection

    source_filename$ = Dir(filename$, vbNormal)
    If source_filename$ = "" Then Exit Function

    source_folder$ = Left(filename$, Len(filename$) - Len(source_filename$))
    If DestFolder$ = "" Then DestFolder$ = source_folder$

    '    Debug.Print source_filename$
    '    Debug.Print source_folder$

    InputFN = FreeFile
    Open filename$ For Input As #InputFN

    FilePart& = FilePart& + 1: OutputFN = FreeFile
    PartFilename$ = DestFolder$ & "part" & Format(FilePart&, "000000") & "." & source_filename$
    SplitTextFile.Add PartFilename$
    Open PartFilename$ For Output As #OutputFN

    Do Until EOF(InputFN)
        DoEvents
        rc& = rc& + 1: Line Input #InputFN, txt$
        If rc& > MaxRowsCount& Then
            Close #OutputFN
            FilePart& = FilePart& + 1: OutputFN = FreeFile
            PartFilename$ = DestFolder$ & "part" & Format(FilePart&, "000000") & "." & source_filename$
            SplitTextFile.Add PartFilename$
            Open PartFilename$ For Output As #OutputFN
        End If
        Print #OutputFN, txt$
    Loop

    Close #InputFN
    Close #OutputFN




    Exit Function
    ext$ = "." & Split(filename$, ".")(UBound(Split(filename$, ".")))
    Set FSO = CreateObject("scripting.filesystemobject")
    Set ts = FSO.OpenTextFile(filename, 1, True): txt = ts.ReadAll: ts.Close

    HeaderRow$ = Split(txt, Delimiter$, 2)(0) & Delimiter$        ' берем первую строку из файла как заголовок
    txt = Split(txt, Delimiter$, 2)(1)        ' остаток текста - без строки заголовка

    ' удаляем разделители строк в конце текстовой строки (если таковые присутствуют)
    While txt Like "*" & Delimiter$: txt = Left(txt, Len(txt) - Len(Delimiter$)): Wend

    ' RowsCount = UBound(Split(txt, Delimiter$)) + 1    ' количество текстовых строк в файле
    FileIndex& = 1        ' индекс очередного создаваемого файла

    arr = Split(txt, Delimiter$): rc = 0: Set SplitTextFile = New Collection
    For i = LBound(arr) To UBound(arr)
        rc = rc + 1
        newtxt$ = newtxt$ & arr(i) & Delimiter$
        If rc >= MaxRowsCount& Or i = UBound(arr) Then        ' набрали достаточно строк для записи в файл
            NewFilename$ = Mid(filename$, 1, Len(filename$) - Len(ext$)) & "(" & FileIndex & ")" & ext$
            Set ts = FSO.CreateTextFile(NewFilename$, True)
            ts.Write HeaderRow$ & newtxt$: ts.Close
            SplitTextFile.Add NewFilename$
            FileIndex& = FileIndex& + 1
            rc = 0: newtxt$ = ""
        End If
    Next i
    Set ts = Nothing: Set FSO = Nothing
    If DeleteSourceFile Then Kill filename$        ' удаляем исходный файл, если DeleteSourceFile = TRUE
End Function


Attribute VB_Name = "F_Progress"
Attribute VB_Base = "0{B7642387-E441-4625-828D-83A2BC2EC703}{8493CFAA-0D50-40F9-9915-0BB6C7AB2D0E}"
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_Progress                       Version: 2.2 (кроме программы Parser!)
' Author        : Igor Vakhnenko                   Date: 21.07.2015
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/        info@excelvba.ru      Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Explicit
Public Indicator As ProgressIndicator, ButtonMacro$
Dim MSG_StopMacro$, MSG_StopMacroTitle$

Private Sub UserForm_Initialize()
    On Error Resume Next
    MSG_StopMacro$ = Run(TWN & "tt", "PI_MSG_StopMacro")
    If MSG_StopMacro$ = "" Then MSG_StopMacro$ = "Do you really want to stop the macro?"
    MSG_StopMacroTitle$ = Run(TWN & "tt", "PI_MSG_StopMacroTitle")
    If MSG_StopMacroTitle$ = "" Then MSG_StopMacroTitle$ = "Processing is not complete yet"
    Err.Clear
End Sub

Private Sub CommandButton_RunMacro_Click()
    On Error Resume Next
    If Len(ButtonMacro$) Then Run TWN & ButtonMacro$
End Sub

Private Sub CommandButton_stop_Click()
    On Error Resume Next
    If StopMacro Then        ' macro finished
        End
    Else        ' macro is running
        If MsgBox(MSG_StopMacro$, vbQuestion + vbDefaultButton2 + vbYesNo, MSG_StopMacroTitle$) = vbYes Then
            StopMacro = True
        End If
    End If
End Sub

Private Sub SpinButton_log_Change()
    On Error Resume Next: Dim n&
    n = Me.SpinButton_log.value
    Me.Height = IIf(n = 0, 82, 92 + n * 40)
    Me.TextBox_Log.Height = 40 * n
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    On Error Resume Next
    If Not Indicator Is Nothing Then Indicator.QueryClose
End Sub

Attribute VB_Name = "FieldCurrencyConverter"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
'---------------------------------------------------------------------------------------
' Class Module      : FieldCurrencyConverter
' Author        : EducatedFool                     Date: 01.03.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Public Enabled As Boolean

Public CurrencyFrom As String    ' из какой валюты конвертировать
Public CurrencyTo As String    ' в какую валюту конвертировать

Public CurrencyDefault As String    ' валюта прайса по-умолчанию
'Public RateSource As String    ' источник котировки (сайт, настройки программы, поле прайса, и т.д.)


Public DetectCurrency As Boolean      ' распознавать тип валюты
Public DetectAs As String    ' распознавать валюту как
Public DetectConditions As FieldConditions    ' условия формата ячейки для распознавания валюты как DetectAs

Private Sub Class_Initialize()
    'RateSource = "Настройки"
End Sub

Function ExportToXML(Optional ByVal SaveDisabledConditions As Boolean = False) As IXMLDOMElement
    On Error Resume Next
    Dim xml As DOMDocument, node As IXMLDOMElement
    Set xml = CreateObject("Microsoft.XMLDOM")

    With xml
        .preserveWhiteSpace = True
        Set node = .appendChild(.createElement("CurrencyConverter"))
        node.Attributes.setNamedItem(.createAttribute("Enabled")).Text = Abs(CInt(Me.Enabled))

        node.appendChild(.createElement("CurrencyFrom")).Text = Me.CurrencyFrom
        node.appendChild(.createElement("CurrencyTo")).Text = Me.CurrencyTo
        node.appendChild(.createElement("CurrencyDefault")).Text = Me.CurrencyDefault
        'node.appendChild(.createElement("RateSource")).Text = Me.RateSource

        node.appendChild(.createElement("DetectCurrency")).Text = Abs(CInt(Me.DetectCurrency))
        node.appendChild(.createElement("DetectAs")).Text = Me.DetectAs
        node.appendChild Me.DetectConditions.ExportToXML
    End With

    Set ExportToXML = node
End Function

Sub LoadFromXML(ByVal node As IXMLDOMElement)
    On Error Resume Next
    Me.Enabled = False

    If Not node Is Nothing Then
        If node.BaseName <> "CurrencyConverter" Then
            MsgBox "Не удаётся загрузить настройки обработки стоимости", vbCritical, _
                   "node.baseName <> ""CurrencyConverter"""
            End
        End If

        Me.Enabled = CBool(Val(node.Attributes.getNamedItem("Enabled").Text))

        Me.CurrencyFrom = node.SelectSingleNode("CurrencyFrom").Text
        Me.CurrencyTo = node.SelectSingleNode("CurrencyTo").Text
        Me.CurrencyDefault = node.SelectSingleNode("CurrencyDefault").Text
        'Me.RateSource = node.SelectSingleNode("RateSource").Text

        Me.DetectCurrency = CBool(Val(node.SelectSingleNode("DetectCurrency").Text))
        Me.DetectAs = node.SelectSingleNode("DetectAs").Text

        Set Me.DetectConditions = New FieldConditions
        Me.DetectConditions.LoadFromXML node.SelectSingleNode("DetectConditions")
    End If
End Sub




Attribute VB_Name = "PriceList"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Public config As PriceConfig
Public SheetConfig As PriceSheetConfig
Public filename As String
Public Values As Variant

Public IsSummaryPrice As Boolean

Function RowsCount() As Long
    On Error Resume Next
    RowsCount = UBound(Values)
End Function

Function Output(Optional ByRef OC As OutputConfig, Optional ByRef piOUT As ProgressIndicator)
    On Error Resume Next
    DoEvents
    Application.ScreenUpdating = True
    Dim pi As ProgressIndicator
    Set pi = piOUT.AddChildIndicator("Вывод прайс-листа в заданном формате ...", sss)
    pi.CancelButton.Visible = False
    Application.ScreenUpdating = False

    If OC Is Nothing Then Set OC = config.CreateDefaultOutputConfig
    pi.Line3 = "Конфигурация вывода: " & OC.Name
    If Me.IsSummaryPrice Then filename$ = "test.xls"
    'Stop
    'MsgBox "Количество записей в создаваемом прайс-листе: " & UBound(Values), vbInformation, Dir(filename)
    ' Debug.Print 0, "размер масcива", UBound(Me.Values)

    'arr = ProcessPriceArray(Me, OC, piOUT)
    ProcessPriceArray Me, OC, piOUT
    ' Debug.Print 1, "размер масcива", UBound(Me.Values)

    ' форматирование значений массива (числа, текст, даты), применение таблиц замены (RTable)
    arr = Me.Values
    FormatOutputArray arr, OC, piOUT
    ' Debug.Print 2, "размер масcива", UBound(Me.Values)
    Me.Values = arr

    OC.GroupAndSort Me

    DoEvents
    Select Case OC.Destination
        Case "CSV"
            pi.Parent.Line2 = "Идёт экспорт загруженных данных в файл формата CSV ..."
            filename$ = ExportPrice2CSV(Me, OC, pi)
        Case "XLS"
            pi.Parent.Line2 = "Идёт экспорт загруженных данных в файл Excel ..."
            filename$ = ExportPrice2XLS(Me, OC, pi)
        Case "Sheet"
    End Select
    If filename$ = "" Then GoTo ExitLabel

    pi.Parent.Line2 = "Создание итогового прайс-листа завершено"
    pi.Parent.Line3 = "Выполнение дополнительных операций с созданным файлом ..."


    Set OC.Actions.Parent = OC
    OC.Actions.ExecuteAll filename$, Me, pi    ' выполняем дополнительные действия с файлом
ExitLabel:
    pi.Hide
    Application.ScreenUpdating = True
End Function



'Function OutputFilename() As String
'    On Error Resume Next
'    'OutputFilename = SheetConfig.Codename
'    'If OutputFilename = "" Then OutputFilename = config.Codename
'    shortFilename$ = Split(Me.filename, "\")(UBound(Split(Me.filename, "\")))
'    If OutputFilename$ = "" Then OutputFilename$ = shortFilename$
'
'    OutputFilename = OutputFilename & " - sheet" & SheetConfig.Index
'End Function

Attribute VB_Name = "PriceField"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Public Parent As PriceFields

Public Name As String
Public Index As Long
Public Description As String
Public Enabled As Boolean        ' FALSE - отключено, TRUE - задействовано
Public Required As Long        ' 0 - не обязательное, 1 - обязательное

Public SheetColumn As Long
Public DefaultValue As Variant
Public ValueMode As Long        ' 0 - значение, 1 - формула
Public Formula As String
Public CharsToRemove As String
'public Format as String

Public ReplaceTableName As String
Public MarginSetName As String

Public Functions As New FieldFunctions
Public Conditions As New FieldConditions
Public CostOptions As New FieldCostOptions
Public CurrencyConverter As New FieldCurrencyConverter

Public KeepValue As Long        ' 0 - отключено, 1 - задействовано
Public KeepLevel As Long        ' уровень категории (от 1 до 9). если 0, то не используется
Public ExcelFormulaR1C1 As String

Public UseCellText As Long ' 0 - берется значение ячейки (по-умолчанию так), 1 - берется отображаемый текст


Function IsStaticFormula() As Boolean
    On Error Resume Next: Err.Clear
    IsStaticFormula = (Me.ValueMode = 1) And (InStr(1, Me.Formula, "{") = 0)
End Function

Function RTable(Optional ByVal Reload As Boolean = False) As ReplaceTable
    On Error Resume Next
    Static RT As ReplaceTable
    If ReplaceTableName = "" Then Set RTable = New ReplaceTable: Exit Function

    If (Not RT Is Nothing) And Not Reload Then Set RTable = RT: Exit Function
    Set RTable = All_RT.GetItemByName(ReplaceTableName)
    Set RT = RTable
End Function

Private Sub Class_Initialize()
    Me.SheetColumn = 1
    Me.ValueMode = 0
End Sub

' ================== для работы со списком полей конфигурации ===============

Function MoveUp() As PriceField
    On Error Resume Next
    If Parent Is Nothing Then MsgBox "Ошибка перемещения полей", vbCritical, "Функция MoveUp": Exit Function
    If Me.Index <= 1 Then Exit Function

    Set MoveUp = Me
    Err.Clear: Parent.Items.Add MoveUp, , Me.Index - 1
    If Err = 0 Then res = Parent.DeleteField(Me.Index + 1)
End Function

Function MoveDown() As PriceField
    On Error Resume Next
    If Parent Is Nothing Then MsgBox "Ошибка перемещения полей", vbCritical, "Функция MoveDown": Exit Function
    If Parent.Items.Count <= Me.Index Then Exit Function

    Parent.GetFieldByIndex(Me.Index + 1).MoveUp        ' странный код, но работает. по-другому сделать не получилось
    Set MoveDown = Parent.GetFieldByIndex(Me.Index)
End Function



' ===========================================================================


Function ExportToXML(Optional ByVal FullExport As Boolean = True) As IXMLDOMElement
    Dim xml As DOMDocument, fieldnode As IXMLDOMElement, FF As IXMLDOMElement
    Set xml = CreateObject("Microsoft.XMLDOM")

    With xml
        .preserveWhiteSpace = True
        Set fieldnode = .appendChild(.createElement("Field"))
        fieldnode.Attributes.setNamedItem(.createAttribute("index")).Text = Me.Index
        If FullExport Then
            If Me.Enabled Then fieldnode.Attributes.setNamedItem(.createAttribute("Enable")).Text = Abs(CInt(Me.Enabled))
        End If

        fieldnode.appendChild(.createElement("Name")).Text = Me.Name
        If Len(Me.Description) Then _
           fieldnode.appendChild(.createElement("Description")).Text = Me.Description

        If FullExport Then
            fieldnode.appendChild(.createElement("SheetColumn")).Text = Me.SheetColumn
            If Me.UseCellText Then _
               fieldnode.appendChild(.createElement("UseCellText")).Text = Me.UseCellText
            If Me.Required Then _
               fieldnode.appendChild(.createElement("Required")).Text = Me.Required
            If Me.DefaultValue <> "" Then _
               fieldnode.appendChild(.createElement("DefaultValue")).Text = Me.DefaultValue
            fieldnode.appendChild(.createElement("ValueMode")).Text = Me.ValueMode
            If Len(Me.Formula) Then _
               fieldnode.appendChild(.createElement("Formula")).Text = Me.Formula
            If Len(Me.ExcelFormulaR1C1) Then _
               fieldnode.appendChild(.createElement("ExcelFormulaR1C1")).Text = Me.ExcelFormulaR1C1
            If Len(Me.CharsToRemove) Then _
               fieldnode.appendChild(.createElement("CharsToRemove")).Text = Me.CharsToRemove
            fieldnode.appendChild(.createElement("KeepValue")).Text = Me.KeepValue
            fieldnode.appendChild(.createElement("KeepLevel")).Text = Me.KeepLevel

            fieldnode.appendChild Me.Functions.ExportToXML
            fieldnode.appendChild Me.Conditions.ExportToXML
            If Me.CostOptions.Enabled Then
                With fieldnode.appendChild(Me.CostOptions.ExportToXML)
                    If Me.CurrencyConverter.Enabled Then
                        .appendChild Me.CurrencyConverter.ExportToXML
                    End If
                End With
            End If

            If Len(Me.ReplaceTableName) Then fieldnode.appendChild(.createElement("ReplaceTableName")).Text = Me.ReplaceTableName
            If Len(Me.MarginSetName) Then fieldnode.appendChild(.createElement("MarginSetName")).Text = Me.MarginSetName
        End If
    End With
    Set ExportToXML = fieldnode
End Function

Sub LoadFromXML(ByVal fieldnode As IXMLDOMElement)
    On Error Resume Next
    If fieldnode.BaseName <> "Field" Then
        MsgBox "Не удаётся загрузить настройки полей", vbCritical, _
               "fieldnode.baseName <> ""Field"""
        End
    End If


    Me.Name = fieldnode.SelectSingleNode("Name").Text
    Me.Index = Val(fieldnode.Attributes.getNamedItem("index").Text)
    Me.Enabled = CBool(Val(fieldnode.Attributes.getNamedItem("Enable").Text))

    Me.Description = fieldnode.SelectSingleNode("Description").Text

    Me.SheetColumn = Val(fieldnode.SelectSingleNode("SheetColumn").Text)
    If Me.SheetColumn < 1 Then Me.SheetColumn = 1

    Me.UseCellText = Val(fieldnode.SelectSingleNode("UseCellText").Text)
    Me.Required = Val(fieldnode.SelectSingleNode("Required").Text)

    Me.DefaultValue = fieldnode.SelectSingleNode("DefaultValue").Text
    Me.ValueMode = Val(fieldnode.SelectSingleNode("ValueMode").Text)

    Me.Formula = fieldnode.SelectSingleNode("Formula").Text
    Me.ExcelFormulaR1C1 = fieldnode.SelectSingleNode("ExcelFormulaR1C1").Text
    Me.CharsToRemove = fieldnode.SelectSingleNode("CharsToRemove").Text

    Me.KeepValue = Val(fieldnode.SelectSingleNode("KeepValue").Text)
    Me.KeepLevel = Val(fieldnode.SelectSingleNode("KeepLevel").Text)

    Me.ReplaceTableName = fieldnode.SelectSingleNode("ReplaceTable").Attributes.getNamedItem("Name").Text
    Me.ReplaceTableName = fieldnode.SelectSingleNode("ReplaceTableName").Text
    Me.MarginSetName = fieldnode.SelectSingleNode("MarginSetName").Text


    Set Me.Conditions = New FieldConditions
    Me.Conditions.LoadFromXML fieldnode.SelectSingleNode("FieldConditions")

    Set Me.Functions = New FieldFunctions
    Me.Functions.LoadFromXML fieldnode.SelectSingleNode("FieldFunctions")

    Set Me.CostOptions = New FieldCostOptions
    Me.CostOptions.LoadFromXML fieldnode.SelectSingleNode("FieldCostOptions")

    Set Me.CurrencyConverter = New FieldCurrencyConverter
    Me.CurrencyConverter.LoadFromXML fieldnode.SelectSingleNode("FieldCostOptions").SelectSingleNode("CurrencyConverter")
End Sub



Attribute VB_Name = "OutputField"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
'---------------------------------------------------------------------------------------
' Module        : OutputField
' Author        : Игорь                     Date: 22.06.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Public Parent As OutputFields

Public Index As Long
'Public Enabled As Long    ' 0 - отключено, 1 - задействовано

Public Name As String
Public Description As String
Public Required As Long        ' 0 - не обязательное, 1 - обязательное

Public Caption As String
Public Format As String
Public DefaultValue As Variant

Public ValueMode As Long        ' 0 - значение, 1 - формула
Public Formula As String

Public ReplaceTableName As String

Public Color1 As Long, Color2 As Long        ' цвет заливки (Color1) и цвет текста (Color2) при группировке строк
Public ExcelFormulaR1C1 As String

' параметры объединения строк при выводе
Public MergeType As MERGE_FIELD_TYPES
Public MergeJoinSeparator As String
Public MergeRoundEnabled As Boolean        ' включен ли режим округления
Public MergeRoundDigitsAfterDecimal As Long        ' кол-во цифр после запятой
Public MergeRoundMode As Long        ' 0 - обычное округление, 1 - вверх, 2 - вниз


Function RTable(Optional ByVal Reload As Boolean = False) As ReplaceTable
    On Error Resume Next
    Static RT As ReplaceTable
    If ReplaceTableName = "" Then Set RTable = New ReplaceTable: Exit Function

    If (Not RT Is Nothing) And Not Reload Then Set RTable = RT: Exit Function
    Set RTable = All_RT.GetItemByName(ReplaceTableName)
    Set RT = RTable
End Function

Function MoveUp() As OutputField
    On Error Resume Next
    If Parent Is Nothing Then MsgBox "Ошибка перемещения полей", vbCritical, "Функция MoveUp": Exit Function
    If Me.Index <= 1 Then Exit Function

    Set MoveUp = Me
    Err.Clear: Parent.Items.Add MoveUp, , Me.Index - 1
    If Err = 0 Then res = Parent.DeleteField(Me.Index + 1)
End Function

Function MoveDown() As OutputField
    On Error Resume Next
    If Parent Is Nothing Then MsgBox "Ошибка перемещения полей", vbCritical, "Функция MoveDown": Exit Function
    If Parent.Items.Count <= Me.Index Then Exit Function

    Parent.GetFieldByIndex(Me.Index + 1).MoveUp        ' странный код, но работает. по-другому сделать не получилось
    Set MoveDown = Parent.GetFieldByIndex(Me.Index)
End Function

Private Sub Class_Initialize()
    Me.ValueMode = 0
    Me.Format = OutputFieldsFormats(0) & "&"
    Me.MergeJoinSeparator = ", "
    Me.MergeRoundDigitsAfterDecimal = 0
End Sub

Function ExportToXML() As IXMLDOMElement
    Dim xml As DOMDocument, fieldnode As IXMLDOMElement, ValueNode As IXMLDOMElement, FormatNode As IXMLDOMElement
    Set xml = CreateObject("Microsoft.XMLDOM")

    With xml
        .preserveWhiteSpace = True
        Set fieldnode = .appendChild(.createElement("OutputField"))
        fieldnode.Attributes.setNamedItem(.createAttribute("index")).Text = Me.Index
        fieldnode.Attributes.setNamedItem(.createAttribute("Name")).Text = Me.Name

        If Len(Me.Description) Then fieldnode.appendChild(.createElement("Description")).Text = Me.Description
        fieldnode.appendChild(.createElement("Caption")).Text = Me.Caption
        fieldnode.appendChild(.createElement("Required")).Text = Me.Required
        If Len(Me.ExcelFormulaR1C1) Then fieldnode.appendChild(.createElement("ExcelFormulaR1C1")).Text = Me.ExcelFormulaR1C1

        Set ValueNode = fieldnode.appendChild(.createElement("Value"))
        If Len(Me.DefaultValue) Then ValueNode.Attributes.setNamedItem(.createAttribute("Default")).Text = Me.DefaultValue
        ValueNode.Attributes.setNamedItem(.createAttribute("Format")).Text = Me.Format
        ValueNode.Attributes.setNamedItem(.createAttribute("ValueMode")).Text = Me.ValueMode
        If Len(Me.Formula) Then ValueNode.Attributes.setNamedItem(.createAttribute("Formula")).Text = Me.Formula

        If Len(Me.ReplaceTableName) Then fieldnode.appendChild(.createElement("ReplaceTableName")).Text = Me.ReplaceTableName

        With fieldnode.appendChild(xml.createElement("Merge"))
            .Attributes.setNamedItem(xml.createAttribute("Type")).Text = Me.MergeType
            .Attributes.setNamedItem(xml.createAttribute("JoinSeparator")).Text = Me.MergeJoinSeparator
            With .appendChild(xml.createElement("Round"))
                .Attributes.setNamedItem(xml.createAttribute("Enabled")).Text = Abs(CInt(Me.MergeRoundEnabled))
                .Attributes.setNamedItem(xml.createAttribute("DigitsAfterDecimal")).Text = Me.MergeRoundDigitsAfterDecimal
                .Attributes.setNamedItem(xml.createAttribute("Mode")).Text = Me.MergeRoundMode
            End With
        End With

    End With
    Set ExportToXML = fieldnode
End Function

Sub LoadFromXML(ByVal fieldnode As IXMLDOMElement)
    On Error Resume Next
    If fieldnode.BaseName <> "OutputField" Then
        MsgBox "Не удаётся загрузить настройки полей", vbCritical, "fieldnode.baseName <> «OutputField»"
        End
    End If

    Me.Index = Val(fieldnode.Attributes.getNamedItem("index").Text)
    Me.Name = fieldnode.Attributes.getNamedItem("Name").Text

    Me.Description = fieldnode.SelectSingleNode("Description").Text
    Me.Caption = fieldnode.SelectSingleNode("Caption").Text
    Me.ExcelFormulaR1C1 = fieldnode.SelectSingleNode("ExcelFormulaR1C1").Text

    Dim ValueNode As IXMLDOMElement
    Set ValueNode = fieldnode.SelectSingleNode("Value")

    Me.Required = Val(fieldnode.SelectSingleNode("Required").Text)
    Me.DefaultValue = ValueNode.Attributes.getNamedItem("Default").Text
    Me.Format = ValueNode.Attributes.getNamedItem("Format").Text
    Me.ValueMode = Val(ValueNode.Attributes.getNamedItem("ValueMode").Text)
    Me.Formula = ValueNode.Attributes.getNamedItem("Formula").Text

    With fieldnode.SelectSingleNode("Merge")
        Me.MergeType = Val(.Attributes.getNamedItem("Type").Text)
        Me.MergeJoinSeparator = .Attributes.getNamedItem("JoinSeparator").Text
        With .SelectSingleNode("Round")
            Me.MergeRoundEnabled = CBool(Val(.Attributes.getNamedItem("Enabled").Text))
            Me.MergeRoundDigitsAfterDecimal = Val(.Attributes.getNamedItem("DigitsAfterDecimal").Text)
            Me.MergeRoundMode = Val(.Attributes.getNamedItem("Mode").Text)
        End With
    End With

    Me.ReplaceTableName = fieldnode.SelectSingleNode("ReplaceTable").Attributes.getNamedItem("Name").Text
    Me.ReplaceTableName = fieldnode.SelectSingleNode("ReplaceTableName").Text
End Sub





Attribute VB_Name = "mod_OUTPUT_CONFIG_functions"
'---------------------------------------------------------------------------------------
' Module        : mod_OUTPUT_CONFIG_functions
' Author        : EducatedFool                     Date: 20.01.2013
' Professional application development for Microsoft Excel
' http://ExcelVBA.ru/          ICQ: 5836318           Skype: ExcelVBA.ru
'---------------------------------------------------------------------------------------

Option Compare Text
Option Private Module

Function GetDefaultOutputWorksheet() As Worksheet
    Application.ScreenUpdating = False: On Error Resume Next: Err.Clear
    Dim sh_template As Worksheet: Set sh_template = sht
    shtv = sh_template.Visible: sh_template.Visible = xlSheetVisible
    If Err Then MsgBox "Не удалось отобразить лист шаблона", vbCritical, "Ошибка в функции NewWorksheet ": End
    sh_template.Copy: DoEvents
    sh_template.Visible = shtv
    If Err Then MsgBox "Не удалось скопировать лист шаблона", vbCritical, "Ошибка в функции NewWorksheet ": End

    If ActiveWorkbook.Worksheets.Count > 1 Then MsgBox "2: Не удалось скопировать лист шаблона", vbCritical, "Ошибка в функции NewWorksheet ": End
    If ActiveWorkbook.Name = ThisWorkbook.Name Then MsgBox "3: Не удалось скопировать лист шаблона", vbCritical, "Ошибка в функции NewWorksheet ": End

    Set GetDefaultOutputWorksheet = ActiveWorkbook.Worksheets(1)
    If GetDefaultOutputWorksheet.Name <> sh_template.Name Then MsgBox "4: Не удалось скопировать лист шаблона", vbCritical, "Ошибка в функции NewWorksheet ": End
End Function

Function ExportPrice2CSV(ByRef price As PriceList, ByRef OC As OutputConfig, _
                         Optional ByRef piOUT As ProgressIndicator) As String
    ' формирует CSV файл из прайса price согласно конфигурации OC (OutputConfig)
    On Error Resume Next
    filename$ = OC.GetOutputFilename(price)

    piOUT.StartNewAction 5, 60, "Экспорт прайс-листа в CSV файл", "Обработка массива": piOUT.FP.Repaint
    DoEvents

    ' arr = ProcessPriceArray(price, OC, piOUT)
    arr = price.Values

    ' форматирование значений массива (числа, текст, даты), применение таблиц замены (RTable)
    ' FormatOutputArray arr, OC, piOUT

    piOUT.StartNewAction 60, 70, "Экспорт прайс-листа в CSV файл", "Удаление разделителей столбцов в значениях ...": piOUT.FP.Repaint
    DoEvents
    sepOld$ = OC.CSV_options.ColumnsSeparator
    sepNew$ = SeparatorReplacement(sepOld$)
    chr34$ = Chr(34): chr2_34$ = Chr(34) & Chr(34)

    Dim NeedBrakets As Boolean
    If OC.CSV_options.UseBrackets Then
        For i = LBound(arr) To UBound(arr)
            For j = LBound(arr, 2) To UBound(arr, 2)
                NeedBrakets = False
                If InStr(1, arr(i, j), chr34$) Then NeedBrakets = True: arr(i, j) = Replace(arr(i, j), chr34$, chr2_34$)
                If InStr(1, arr(i, j), " ") + InStr(1, arr(i, j), sepOld$) Then NeedBrakets = True
                If NeedBrakets Then
                    arr(i, j) = chr34$ & arr(i, j) & chr34$
                End If
                'arr(i, j) = Replace(arr(i, j), sepOld$, sepNew$)
            Next j
            If i Mod 500 = 0 Then DoEvents
        Next i
    End If

    piOUT.StartNewAction 70, 83, "Преобразование массива в CSV формат ...": piOUT.FP.Repaint

    txt$ = Arr2CSV(arr, OC.CSV_options.ColumnsSeparator, OC.CSV_options.RowsSeparator, piOUT)
    If OC.CSV_options.AddHeaderRow Then txt$ = OC.GetCSVHeader & txt$

    piOUT.StartNewAction 83, 85, "Запись в CSV файл ...": piOUT.FP.Repaint

    Application.DisplayAlerts = False
    If Not Workbooks(filename$) Is Nothing Then
        Workbooks(filename$).Close False
        SetAttr OUTPUT_FOLDER$ & filename, vbNormal
        Kill OUTPUT_FOLDER$ & filename
    End If
    Application.DisplayAlerts = True


    piOUT.StartNewAction 85, 100, "Перекодировка и сохранение CSV файла ...", "Подождите, это может занять много времени...": piOUT.FP.Repaint

    If Not SaveTextToFile(txt$, OUTPUT_FOLDER$ & filename, OC.CSV_options.encoding) Then
        Debug.Print Err.Description, Err.Number
        Debug.Print "Ошибка сохранения текста в файл " & vbNewLine & OUTPUT_FOLDER$ & filename
    End If

    '    With CreateObject("scripting.filesystemobject").CreateTextFile(OUTPUT_FOLDER$ & filename, True, True)
    '        .Write txt$: .Close
    '    End With
    '
    '    ChangeFileCharset OUTPUT_FOLDER$ & filename, OC.CSV_options.encoding

    ExportPrice2CSV = OUTPUT_FOLDER$ & filename$
End Function

Function FormatOutputArray(ByRef arr As Variant, ByRef OC As OutputConfig, Optional ByRef piOUT As ProgressIndicator)
    On Error Resume Next: Err.Clear
    ' форматирование значений массива (числа, текст, даты)
    Dim OF As OutputField, col&, RowsForDelete_Count&
    For Each OF In OC.Fields.Items
        piOUT.Line2 = "Форматирование и применение таблиц замены: поле «" & OF.Name & "»"
        col& = OF.Index
        DefValue = OF.DefaultValue

        If Not OF.RTable(True).IsEmpty Then
            With OF.RTable
                .PrepareRT_forQuickReplace
                For i = LBound(arr) To UBound(arr)
                    .ApplyTo arr(i, col&)
                Next i
            End With
        End If


        If OF.Required = 1 Then
            ErrValue$ = "%ErrValue%"
            lastCol& = UBound(arr, 2)
            RowsForDelete_Count& = 0

            piOUT.Line2 = "Поиск пустых и нулевых строк: поле «" & OF.Name & "»"
            For i = LBound(arr) To UBound(arr)
                If (arr(i, col&) = "") Or (arr(i, col&) = "0") Then
                    RowsForDelete_Count& = RowsForDelete_Count& + 1
                    arr(i, lastCol&) = ErrValue$
                End If
            Next i
            DoEvents

            piOUT.Line2 = "Формируем новый массив (без лишних строк): поле «" & OF.Name & "»"
            'Debug.Print "Строк до удаления неподходящих: " & UBound(arr)
            'Debug.Print "Строк после удаления неподходящих: " & UBound(arr) - RowsForDelete_Count&

            If UBound(arr) = RowsForDelete_Count& Then
                ReDim newarr(1 To 1, LBound(arr, 2) To UBound(arr, 2))
                newarr(1, 1) = "Все строки удалены, т.к. в «обязательном поле» «" & OF.Name & "» находились только пустые или нулевые значения"
                arr = newarr
                Exit Function
            End If

            If RowsForDelete_Count& Then
                ' формируем новый массив
                ReDim newarr(1 To UBound(arr) - RowsForDelete_Count&, LBound(arr, 2) To UBound(arr, 2))
                Dim newrow As Long
                For i = LBound(arr) To UBound(arr)
                    If arr(i, lastCol&) <> ErrValue$ Then
                        newrow = newrow + 1
                        For j = LBound(arr, 2) To UBound(arr, 2): newarr(newrow, j) = arr(i, j): Next j
                    End If
                    If i Mod 1000 = 0 Then DoEvents
                Next i

                arr = newarr
                Erase newarr
            End If
        End If


        FieldFormat$ = Split(OF.Format, "&", 2)(0)
        FieldFormatCustom$ = Split(OF.Format, "&", 2)(1)
        Select Case FieldFormat$

            Case "", "Текст"

                For i = LBound(arr) To UBound(arr)
                    If arr(i, col&) = "" Then arr(i, col&) = DefValue
                Next i
                If OC.Destination = "XLS" And FieldFormat$ = "Текст" Then        ' только для XLS
                    For i = LBound(arr) To UBound(arr)
                        If Left$(arr(i, col&), 1) <> "'" Then arr(i, col&) = "'" & arr(i, col&)
                    Next i
                End If


            Case "Число"

                For i = LBound(arr) To UBound(arr)
                    If Len(arr(i, col&)) > 0 Then
                        arr(i, col&) = Val(Replace(arr(i, col&), ",", "."))
                        If arr(i, col&) = 0 Then arr(i, col&) = Val(DefValue)
                        If Len(FieldFormatCustom$) Then arr(i, col&) = Replace(Format(arr(i, col&), FieldFormatCustom$), ",", ".")
                    Else
                        If Len(DefValue) Then arr(i, col&) = Val(DefValue)
                    End If
                Next i

            Case "Индекс"

                For i = LBound(arr) To UBound(arr): arr(i, col&) = i: Next i

            Case "Формула"

                For i = LBound(arr) To UBound(arr)
                    If arr(i, col&) = "" Then arr(i, col&) = DefValue
                Next i

                If OC.Destination = "XLS" Then        ' только для XLS
                    If ExcelFormulaIsCorrect(OF.ExcelFormulaR1C1) Then
                        ExcelFormula$ = OF.ExcelFormulaR1C1
                        For i = LBound(arr) To UBound(arr)
                            RenderExcelFormulaR1C1 ExcelFormula$, arr(i, col&)
                        Next i
                    End If
                End If

            Case "Дата"
                defaultDate = "": Err.Clear: If Len(Trim(DefValue)) Then defaultDate = CDate(DefValue)
                If Err Then defaultDate = ""

                For i = LBound(arr) To UBound(arr)
                    If IsDate(arr(i, col&)) Then
                        arr(i, col&) = CDate(arr(i, col&))
                    Else
…