Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
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
Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim n As Name
    
    ' проверяем, есть ли названный диапазон start_row - при формировании отчет мы удаляем закладку
    For Each n In shReestr.Names
        If Right(n.Name, Len("start_row")) = "start_row" Then
            Exit Sub
        End If
    Next n
    
    ' если нет закладки - отчет сформирован
    ' предлагаем сделать экспорт, если еще не был произведен
    If Not bExportDone Then
        If MsgBox("Экспорт данных не был произведен." & vbCrLf & "Желаете вернуться, чтобы провести его?", vbYesNo Or vbQuestion) = vbYes Then
            Cancel = True
        End If
    End If
End Sub

Attribute VB_Name = "shReestr"
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
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rng As Range
    Dim oCell As Range
'    Dim sTmp As String
'
'    Dim cDelivery As Long
'    Dim cDeliveryTotal As Long
'
'    Dim modCell As Range
'
'    cDelivery = Target.Worksheet.Names("col_delivery").RefersToRange.Column
'    cDeliveryTotal = Target.Worksheet.Names("col_deliveryTotal").RefersToRange.Column
'
'    ' если заполнили без НДС, то заполняем с НДС
'    Set rng = Intersect(Target, Target.Worksheet.Names("col_delivery").RefersToRange)
'    If Not rng Is Nothing Then
'        For Each oCell In rng.Cells
'            Set modCell = Target.Worksheet.Cells(oCell.Row, cDeliveryTotal)
'
'            If CellValueNull(oCell) And CellValueNull(modCell) Then
'                ' ничего не делать
'            ElseIf CellValueNull(oCell) Then
'                ' если значение = 0 или стерли
'                modCell.value = ""
'            ElseIf IsNumeric(oCell.value) Then
'                If CellValueNull(modCell) Then
'                    modCell.value = Round(oCell.value * 1.18, 2)
'                End If
'            End If
'        Next oCell
'    End If
'
'    ' и наоборот
'    Set rng = Intersect(Target, Target.Worksheet.Names("col_deliveryTotal").RefersToRange)
'    If Not rng Is Nothing Then
'        For Each oCell In rng.Cells
'            Set modCell = Target.Worksheet.Cells(oCell.Row, cDelivery)
'
'            If CellValueNull(oCell) And CellValueNull(modCell) Then
'                ' ничего не делать
'            ElseIf CellValueNull(oCell) Then
'                ' если значение = 0 или стерли
'                modCell.value = ""
'            ElseIf IsNumeric(oCell.value) Then
'                If CellValueNull(modCell) Then
'                    modCell.value = Round(oCell.value / 1.18, 2)
'                End If
'            End If
'        Next oCell
'    End If
    
    ' убрать минус
    Set rng = Intersect(Target, Target.Worksheet.Names("anti_minus").RefersToRange)
    If Not rng Is Nothing Then
        For Each oCell In rng.Cells
            If IsNumeric(oCell.value) Then
                If oCell.value < 0 Then
                    oCell.value = Abs(oCell.value)
                End If
            End If
        Next oCell
    End If
    
    Set rng = Intersect(Target, Target.Worksheet.Names("anti_minus2").RefersToRange)
    If Not rng Is Nothing Then
        For Each oCell In rng.Cells
            If IsNumeric(oCell.value) Then
                If oCell.value < 0 Then
                    oCell.value = Abs(oCell.value)
                End If
            End If
        Next oCell
    End If
    
    Call ShowHidden(Target, "I1")
End Sub

Private Function CellValueNull(oCell As Range) As Boolean
    CellValueNull = oCell.value = "" Or _
                    IsEmpty(oCell.value) Or _
                    oCell.value = 0
End Function

Private Sub ShowHidden(ByVal Target As Range, f103 As String)
    Dim rng As Range
    Dim i As Long
    Dim b As Boolean
    ' пасхалка - показать скрытые листы
    On Error Resume Next
    Set rng = Intersect(Target, shReestr.Range(f103))
    If Not rng Is Nothing Then
        b = rng.Cells(1, 1).value = "!"
        For i = 3 To ActiveWorkbook.Sheets.Count
            ActiveWorkbook.Sheets(i).Visible = IIf(b, xlSheetVisible, xlSheetHidden)
        Next i
    End If
    On Error GoTo 0
    Err.Clear
End Sub

Attribute VB_Name = "shRate"
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
Option Explicit


Attribute VB_Name = "shControlFile"
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
Option Explicit


Attribute VB_Name = "shDataFile"
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
Option Explicit


Attribute VB_Name = "clINI"
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
Option Explicit
' 21.01.2013

#If VBA7 Then
    Private Declare PtrSafe Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
    Private Declare PtrSafe Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
#Else
    Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
    Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
#End If

Private PathToINI As String

Public Property Let SetINIPath(argPath As String)
    PathToINI = argPath
End Property

Public Property Get GetINIPath() As String
    GetINIPath = PathToINI
End Property

Public Property Get ReadKeyValue(argSection As String, argKey As String, Optional valueIfBlank As String = vbNullString) As String
    Dim KeyValue As String
        KeyValue = String(65535, Chr(32))
        GetPrivateProfileString argSection, ByVal argKey, vbNullString, KeyValue, Len(KeyValue), PathToINI
        
        KeyValue = Trim(KeyValue)
        If Right(KeyValue, 1) = vbNullChar Then
            KeyValue = Left(KeyValue, Len(KeyValue) - 1)
        End If
        ReadKeyValue = Trim(KeyValue)
        If ReadKeyValue = vbNullString Then ReadKeyValue = valueIfBlank
End Property

Public Sub WriteKeyValue(ByVal argSection As String, ByVal argKey As String, ByVal KeyValue As String)
    Dim Checker As Long
        Checker = WritePrivateProfileString(argSection, ByVal argKey, KeyValue, PathToINI)
        If Checker = 0 Then
            MsgBox ("Cannot write into " & PathToINI)
        End If
End Sub


'' ЧТЕНИЕ/ЗАПИСЬ ЗНАЧЕНИЙ КОНТРОЛОВ
'
'' CHECKBOX
'Public Sub WriteCheckBox(section As String, ByRef chk As CheckBox)
'    ' True/False - 1/0
'    If CBool(chk.value) Then
'        WriteKeyValue section, chk.Name & TryGetIndex(chk), 1
'    Else
'        WriteKeyValue section, chk.Name & TryGetIndex(chk), 0
'    End If
'End Sub
'
'Public Sub ReadCheckBox(section As String, ByRef chk As CheckBox, Optional DefaultValue As Boolean = False)
'    Dim val As String
'    val = ReadKeyValue(section, chk.Name & TryGetIndex(chk))
'    If val = vbNullString Then
'        ' если в ini пусто
'        If DefaultValue Then
'            chk.value = 1
'        Else
'            chk.value = 0
'        End If
'    Else
'        ' если 1 - True, в остальных случаях False
'        If val = 1 Then
'            chk.value = 1
'        Else
'            chk.value = 0
'        End If
'    End If
'End Sub
'
'' OPTIONBUTTON
'Public Sub WriteOptionButton(section As String, ByRef opt As OptionButton)
'    ' True/False - 1/0
'    If opt.value Then
'        WriteKeyValue section, opt.Name & TryGetIndex(opt), 1
'    Else
'        WriteKeyValue section, opt.Name & TryGetIndex(opt), 0
'    End If
'End Sub
'
'Public Sub ReadOptionButton(section As String, ByRef opt As OptionButton, Optional DefaultValue As Boolean = False)
'    Dim val As String
'    val = ReadKeyValue(section, opt.Name & TryGetIndex(opt))
'
'    If val = vbNullString Then
'        ' если в ini пусто
'        opt.value = DefaultValue
'    Else
'        ' если 1 - True, в остальных случаях False
'        opt.value = (val = 1)
'    End If
'End Sub
'
'' COMBOBOX index
'Public Sub WriteComboBoxIndex(section As String, ByRef cmb As ComboBox)
'    WriteKeyValue section, cmb.Name & TryGetIndex(cmb), cmb.ListIndex
'End Sub
'
'Public Sub ReadComboBoxIndex(section As String, ByRef cmb As ComboBox, Optional DefaultIndex As Long = -1)
'    Dim val As String
'    val = ReadKeyValue(section, cmb.Name & TryGetIndex(cmb))
'
'    Dim bReadSucceed As Boolean
'    bReadSucceed = False
'    If val <> vbNullString Then                 ' что-то считали из ini
'        If IsNumeric(val) Then                  ' это "что-то" является числом
'            If cmb.ListCount > CLng(val) Then   ' кол-во элементов в контроле больше этого числа
'                cmb.ListIndex = CLng(val)
'                bReadSucceed = True
'            End If
'        End If
'    End If
'
'    If Not bReadSucceed Then ' если хоть по одной причине не удалось считать значение из ini
'        If cmb.ListCount > DefaultIndex Then    ' проверяем, что кол-во элементов в контроле больше переданного значения "по умолчанию"
'            cmb.ListIndex = DefaultIndex
'        Else
'            cmb.ListIndex = -1
'        End If
'    End If
'End Sub
'
'' DTPICKER
'Public Sub WriteDTPicker(section As String, ByRef dtp As DTPicker)
'    ' всегда дату записываем в формате dd/mm/yyyy (например, 30/12/2010)
'    WriteKeyValue section, dtp.Name & TryGetIndex(dtp), Format$(dtp.value, "dd\/mm\/yyyy")
'End Sub
'
'Public Sub ReadDTPicker(section As String, ByRef dtp As DTPicker, DefaultDate As Date)
'    Dim val As String
'    val = ReadKeyValue(section, dtp.Name & TryGetIndex(dtp))
'
'    Dim bReadSucceed As Boolean
'    If val <> vbNullString Then         ' что-то считали из ini
'        val = Replace(val, ".", "/")
'        val = Replace(val, "-", "/")
'        If IsDate(val) Then             ' это "что-то" является датой
'            dtp.value = CDate(val)
'            bReadSucceed = True
'        End If
'    End If
'
'    If Not bReadSucceed Then ' подставляем значение "по-умолчанию"
'        dtp.value = DefaultDate
'    End If
'End Sub
'
'' LISTVIEW
'Public Sub WriteListView(section As String, ByRef lv As ListView)
'    Dim ColumnIndexToSave As Long ' индекс из ListSubItems, значения из которого будем сохранять
'    Dim val As String, i As Long
'
'    ' найти поле DCODE или ISN
'    ColumnIndexToSave = -1
'    ' DCODE
'    If ColumnIndexToSave = -1 Then
'        For i = 1 To lv.ColumnHeaders.Count
'            If UCase(lv.ColumnHeaders(i).Text) = "DCODE" Then
'                ColumnIndexToSave = i
'                Exit For
'            End If
'        Next i
'    End If
'    ' ISN
'    If ColumnIndexToSave = -1 Then
'        For i = 1 To lv.ColumnHeaders.Count
'            If UCase(lv.ColumnHeaders(i).Text) = "ISN" Then
'                ColumnIndexToSave = i
'                Exit For
'            End If
'        Next i
'    End If
'    ' если не нашли
'    If ColumnIndexToSave = -1 Then
'        MsgBox "В контроле '" & lv.Name & "' не найдено поле для сохранения", vbExclamation
'    End If
'
'    ' формируем строку с перечнем (due/isn) из найденной колонки
'    val = vbNullString
'    For i = 1 To lv.ListItems.Count
'        If Len(val) > 0 Then val = val & "$"
'
'        If ColumnIndexToSave > 1 Then
'            val = val & lv.ListItems(i).ListSubItems(ColumnIndexToSave - 1).Text
'        Else
'            val = val & lv.ListItems(i).Text
'        End If
'    Next i
'    val = Replace(val, "%", vbNullString) ' убрать % из сохраняемых due
'    WriteKeyValue section, lv.Name & TryGetIndex(lv), val
'End Sub
'
'Public Sub ReadListView(section As String, ByRef lv As ListView, ByRef head As Object, classif As String)
'' classif (Справочники):
'    ' "Addr"            "Department"      "Nomencl"         "RcPrj"           "Security"
'    ' "Cabinet"         "DocGroup"        "Organiz"         "Regions"         "Signkind"
'    ' "CardIndex"       "EDS"             "Package"         "Resol_Category"  "Status"
'    ' "Category"        "ExecStationI"    "PrjAddr"         "Resolution"      "User"
'    ' "Certificate"     "ExecStationK"    "RcIn"            "Roll"            "UserList"
'    ' "Citizen"         "Journal"         "RcLet"           "RollType"        "VisaKind"
'    ' "Delivery"        "Link"            "RcOut"           "Rubric"
'
'    Dim val As String, mas() As String
'    Dim i As Long, j As Long
'    Dim oClassif As Object
'    Dim itm As ListItem
'    Dim NUMERIC_ONLY As Boolean
'
'    val = ReadKeyValue(section, lv.Name & TryGetIndex(lv))
'    If val <> vbNullString Then
'        mas = Split(val, "$")
'
'        ' проверяем, что все загруженные значения из ini являются числовыми
'        NUMERIC_ONLY = True
'        For i = 0 To UBound(mas)
'            If Not IsNumeric(mas(i)) Then
'                NUMERIC_ONLY = False
'                Exit For
'            End If
'        Next i
'
'        For i = 0 To UBound(mas)
'            ' получить объект справочника по коду (DUE или ISN)
'            If NUMERIC_ONLY Then
'                Set oClassif = head.GetRow(classif, CLng(mas(i))) ' isn надо в GetRow передавать числом
'            Else
'                Set oClassif = head.GetRow(classif, mas(i))
'            End If
'            If Not IsNull(oClassif.Name) Then
'                With lv.ListItems.add(, , oClassif.Name)
'                    Err.Clear
'                    On Error GoTo l_error
'                    For j = 2 To lv.ColumnHeaders.Count ' перебираем поля и добавляем соответствующие значения из объекта справочник
'                        Select Case UCase(lv.ColumnHeaders(j).Text)
'                        Case "DCODE"
'                            .SubItems(j - 1) = oClassif.DCode
'                        Case "ISN"
'                            .SubItems(j - 1) = oClassif.isn
'                        Case "ISNODE"
'                            .SubItems(j - 1) = oClassif.isNode
'                        Case "LAYER"
'                            .SubItems(j - 1) = oClassif.Layer
'                        Case "KIND"
'                            .SubItems(j - 1) = oClassif.RcKind
'                        Case "DELETED"
'                            .SubItems(j - 1) = oClassif.Deleted
'                            If oClassif.Deleted Then .ForeColor = ColorConstants.vbRed
'                        Case "PRJNUMFLAG"
'                            .SubItems(j - 1) = oClassif.PrjNumFlag
'                        Case "INDEX"
'                            .SubItems(j - 1) = nvl(oClassif.Index)
'                        Case "NOTE"
'                            .SubItems(j - 1) = nvl(oClassif.Note)
'                        Case Else
'                            MsgBox "В контроле '" & lv.Name & "' обнаружено не известное поле '" & lv.ColumnHeaders(j).Text & "'", vbExclamation
'                        End Select
'                    Next j
'                    On Error GoTo 0
'                End With
'            End If
'        Next i
'    End If
'    Exit Sub
'l_error:
'    MsgBox "В справочнике '" & classif & "' отсутствует поле '" & lv.ColumnHeaders(j).Text & "'", vbExclamation
'End Sub
'
'Private Function TryGetIndex(control As Object) As String
'    TryGetIndex = vbNullString
'    Err.Clear
'    On Error Resume Next
'    TryGetIndex = "(" & control.Index & ")"
'    On Error GoTo 0
'End Function

Attribute VB_Name = "clRecordSet_limited"
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
Option Explicit

' HISTORY:
' 29.04.2010 - добавлена процедура Filter
'            - добавлена функиция table для доступа ко всем свойствам recordSet'а
'            - функции SubReplace_*** теперь процедуры
' 04.05.2010 - добавлено свойство DBMS
' 05.05.2010 - добавлен параметр extDebug и улучшена функция FGetValue
' 06.05.2010 - добавлена функция HeadDBMS, для определения DBMS головы (head)
' 17.05.2010 - исправлена ошибка в функиции table
' 04.06.2010 - Query теперь можно изменять
'            - в функции SubReplace_InLike если переданный due пуст, то подставляем всегда верное выражение
' 09.06.2010 - в процедуре Init добавил забытое "extDebug = bdebug"
' 17.08.2010 - в функции GetValue добавил On Error GoTo l_err при выключенном дебаге
'            - исправил обработку этой ошибки
' 24.01.2011 - добавил в ф-цию GetValue Debug.Print при ошибке
' 25.01.2011 - функция HeadDBMS возвращает long
' 16.02.2011 - добавил функцию GetScalar
' 19.10.2011 - изменил процедуру GetSQL - теперь, в XMl-файл один и в нем должны быть разделы MSS и ORA
' 08.11.2011 - в функции GetElement исправил на регистронезависимое сравнение
' 15.02.2012 - добавил err.Clear перед обработчиками ошибок
' 21.02.2012 - для mss-функции convert datedate добавил принудительный формат 120
' 21.09.2012 - рабочая функция GetScalar
' 30.10.2012 - усеченная версия. Без XML файла

Private head As Object      '
Private DBMSType As Long    ' 1 - mss, 2 - ora

Private objTable As Object  ' объект recordSet
Private extDebug As Boolean  '
Private strQuery As String  ' строка-запрос

Public Property Get Query() As String
    ' получить текущий запрос
    Query = strQuery
End Property

Public Property Let Query(ByVal sQuery As String)
    ' получить текущий запрос
    strQuery = sQuery
End Property

Public Property Get Table() As Object
    ' получить таблицу-объект RecordSet
    Set Table = objTable
End Property

Public Property Get DBMS() As String
    ' 1 - mss, 2 - oracle
    DBMS = DBMSType
End Property


Public Sub Init(ByVal objHead As Object, Optional bdebug As Boolean = False)
    extDebug = bdebug
    SetHead objHead
End Sub

Private Sub SetHead(objHead As Object)
    ' передать голову в класс
    Set head = objHead
    
    DBMSType = HeadDBMS(head)
End Sub

Public Function HeadDBMS(ohead As Object) As Long
    ' определяем тип БД
    If ohead.extendedproperties("dbms") = "768" Then 'MSS
        HeadDBMS = 1
    ElseIf ohead.extendedproperties("dbms") = "512" Then 'oracle
        HeadDBMS = 2
    Else
        HeadDBMS = TestDBMS(ohead)
    End If
End Function

Private Function TestDBMS(ohead As Object) As Long
    ' определяем по правильности запроса
    Err.Clear
    On Error GoTo l
    Dim obj As Object
    
    Set obj = ohead.GetResultSet.GetRecordset("SELECT 1")
    TestDBMS = 1 ' mss - если запрос прошел успешно
    Set obj = Nothing
    Err.Clear
    Exit Function
l:
    ' ora - для оракла правильный запрос 'select 1 from dual'
    TestDBMS = 2
    Set obj = Nothing
    Err.Clear
End Function


Public Sub SubReplace(ByVal strFind As String, ByVal strReplace As String)
    ' заменить strFind на strReplace в текущем запросе
    strQuery = Replace(strQuery, strFind, strReplace, , , vbTextCompare)
End Sub

Public Sub SubReplace_InLike(ByVal strField As String, ByVal strDue As String)
    ' заменить @strField@ на строку 'strField in (a,b,c) or strField like(d) or strField like (e)'  в текущем запросе
    ' если перечень due пуст, то подставляем всегда верное выражение (1=1)
    Dim inLikeStr As String
    
    If Len(strDue) > 0 Then
        inLikeStr = Get_InLikeStrByDue(strDue, Replace(strField, "@", ""))
    Else
        inLikeStr = "1=1"
    End If
    inLikeStr = "(" & inLikeStr & ")"
    
    Call SubReplace(strField, inLikeStr)
End Sub

Public Sub SubReplace_Date(ByVal strFind As String, ByVal dtDate As Date, ByVal FromOrTo As Long)
    ' заменить strFind на дату в текущем запросе, с учетом типа БД (mss/ora)
    ' FromOrTo - 1 или 2
    ' 1 - время - начало суток
    ' 2 - время - конец  суток
    Dim strDate As String
    
    If DBMSType = 1 Then ' MSS
        If FromOrTo = 1 Then
            strDate = "convert (datetime, '" & Format$(dtDate, "yyyymmdd") & " 00:00', 120)"
        Else
            strDate = "convert (datetime, '" & Format$(dtDate, "yyyymmdd") & " 23:59', 120)"
        End If
    Else ' ORA
        If FromOrTo = 1 Then
            strDate = "to_date ('" & Format$(dtDate, "dd\/mm\/yyyy") & " 00 00',' dd/mm/yyyy hh24 mi')"
        Else
            strDate = "to_date ('" & Format$(dtDate, "dd\/mm\/yyyy") & " 23 59',' dd/mm/yyyy hh24 mi')"
        End If
    End If
    Call SubReplace(strFind, strDate)
End Sub

Public Function Execute() As Boolean
    'Запрос на получение массива данных
    Execute = False
    Set objTable = Nothing
        
    If head Is Nothing Then
        Call MsgBox("Не создан головной объект", vbCritical, "Ошибка")
        End
    End If
    
    If Query = vbNullString Then
        Error_Query_Message "Запрос пуст"
        End
    End If
    
Err.Clear
On Error GoTo l_sql_error
    DoEvents
    Set objTable = head.GetResultSet.GetRecordset(strQuery)
    DoEvents
On Error GoTo 0
Err.Clear

    If objTable.RecordCount > 0 Then
        If objTable.Fields.Count > 0 Then
            Execute = True
        End If
    End If
    
    Exit Function

l_sql_error:
    Error_Query_Message "В запросе обнаружена ошибка" & vbCrLf & _
                        "error '" & Err.Number & "' " & Err.Description
End Function


Public Function RecordCount() As Long
    RecordCount = objTable.RecordCount
End Function

Public Function EOF() As Boolean
    EOF = objTable.EOF
End Function

Public Sub MoveNext()
    objTable.MoveNext
End Sub

Public Sub MovePrevious()
    objTable.MovePrevious
End Sub

Public Sub MoveFirst()
    objTable.MoveFirst
End Sub

Public Sub MoveLast()
    objTable.MoveLast
End Sub

Public Sub Filter(strFilter As String)
    objTable.Filter = strFilter
End Sub

Public Function GetScalar(Optional ByVal ReturnIfNull As String = vbNullString) As String
    If Execute Then
        GetScalar = GetValue(0, ReturnIfNull)
    Else
        GetScalar = ReturnIfNull
    End If
End Function

Public Function GetValue(ByVal FieldAsNameOrIndex, Optional ByVal ReturnIfNull As String = vbNullString) As String
    Dim FieldName As String
    Dim FieldIndex As Long
    
    GetValue = ReturnIfNull
    
    If Not (objTable Is Nothing) Then
        If Not extDebug Then
            ' просто попытаться получить значение поля
            Err.Clear
            On Error GoTo l_err
            If Not IsNull(objTable(FieldAsNameOrIndex).value) Then
                If IsNumeric(FieldAsNameOrIndex) Then
                    FieldIndex = CLng(FieldAsNameOrIndex)
                    GetValue = objTable(FieldIndex).value
                Else
                    FieldName = Trim(FieldAsNameOrIndex)
                    GetValue = objTable(FieldName).value
                End If
            End If
            On Error GoTo 0
        Else
            ' предварительно проверить наличие поля в RecordSet'е
            If Not FieldIsExists(FieldAsNameOrIndex) Then
                Error_Query_Message "В запросе не найдено поле '" & FieldAsNameOrIndex & "'"
                Exit Function
            End If
            If Not IsNull(objTable(FieldAsNameOrIndex).value) Then
                If IsNumeric(FieldAsNameOrIndex) Then
                    FieldIndex = CLng(FieldAsNameOrIndex)
                    GetValue = objTable(FieldIndex).value
                Else
                    FieldName = Trim(FieldAsNameOrIndex)
                    GetValue = objTable(FieldName).value
                End If
            End If
        End If
    End If
    Exit Function
l_err:
    Error_Query_Message "Возможно, в запросе не найдено поле '" & FieldAsNameOrIndex & "'"
    Debug.Print "Возможно, в запросе не найдено поле '" & FieldAsNameOrIndex & "'"
End Function

Private Function FieldIsExists(ByVal FieldAsNameOrIndex) As Boolean
    Dim i As Long
    If IsNumeric(FieldAsNameOrIndex) Then
        ' если по индексу, то проверяем, что количество полей в запросе не меньше индекса
        If FieldAsNameOrIndex <= objTable.Fields.Count - 1 Then
            FieldIsExists = True
        Else
            FieldIsExists = False
        End If
    Else
        ' проверяем имена полей
        FieldAsNameOrIndex = Trim(FieldAsNameOrIndex)
        FieldIsExists = False
        For i = 0 To objTable.Fields.Count - 1
            If UCase(objTable.Fields(i).Name) = UCase(FieldAsNameOrIndex) Then
                FieldIsExists = True
                Exit For
            End If
        Next i
    End If
End Function




Private Function Get_InLikeStrByDue(ByVal due As String, ByVal FieldName As String) As String
' из переданной строки дкодов (например, "A.%|A.B.|C.D.E.%|F." ), формирует запрос в формате
' FieldName like 'A.%' OR FieldName like 'C.D.E.%' OR FieldName IN ('A.B.', 'F.')
' типа как в EAPI
    Dim i As Long
    Dim masDue() As String
    Dim sInStr As String
    Dim sLikeStr As String
    Dim bBothInAndLike As Boolean
    
    masDue = Split(due, "|")
    sInStr = vbNullString: sLikeStr = vbNullString
    For i = 0 To UBound(masDue)
        If Right(masDue(i), 1) = "%" Then
            If Len(sLikeStr) > 0 Then sLikeStr = sLikeStr & " or "
            sLikeStr = sLikeStr & FieldName & " like '" & masDue(i) & "'"
        Else
            If Len(sInStr) > 0 Then sInStr = sInStr & ", "
            sInStr = sInStr & "'" & masDue(i) & "'"
        End If
    Next i
    If Len(sInStr) > 0 Then sInStr = FieldName & " IN (" & sInStr & ")"
    
    bBothInAndLike = (Len(sLikeStr) > 0) And (Len(sInStr) > 0)
    Get_InLikeStrByDue = sLikeStr & IIf(bBothInAndLike, " or ", vbNullString) & sInStr
    If Len(Get_InLikeStrByDue) = 0 Then Get_InLikeStrByDue = FieldName & " like '%'"
End Function




Private Sub Error_Query_Message(ByVal Text As String, Optional ByVal bShowQuery As Boolean = True)
    MsgBox Text & _
           IIf(bShowQuery, vbCrLf & strQuery, vbNullString), _
           vbCritical, "Отчеты"
End Sub


Public Function DebugRecordSet() As String
' вернуть полученную таблицу данных
Err.Clear
On Error Resume Next
    
    If objTable Is Nothing Then Exit Function

    Dim res As String
    Dim i As Long
    Dim ColumnSeparator As String
    ColumnSeparator = Chr(127)

    ' названия столбцов
    res = vbNullString
    For i = 0 To objTable.Fields.Count
        If i > 0 Then res = res & ColumnSeparator
        res = res & objTable.Fields(i).Name
    Next i

    ' данные
    Do Until EOF
        res = res & vbCrLf
        For i = 0 To objTable.Fields.Count
            If i > 0 Then res = res & ColumnSeparator
            res = res & objTable.Fields(i).value
        Next i
        
        MoveNext
    Loop
    MoveFirst
    
    DebugRecordSet = res
On Error GoTo 0
Err.Clear
End Function

Attribute VB_Name = "frmConnect"
Attribute VB_Base = "0{7A5A3BCD-168C-48CF-BABD-BCABDA93CF5B}{4208F8B5-D735-4059-8F2F-F641C80B99D3}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Option Explicit
Public bCancelConnection As Boolean ' отказаться от подключения к БД

Private Sub cmdCancel_Click()
    bCancelConnection = True
    Me.Hide
End Sub

Private Sub cmdOk_Click()
    bCancelConnection = False
    If usr.Text = vbNullString Or pas.Text = vbNullString Then
        Exit Sub
    End If
    Me.Hide
End Sub

Private Sub UserForm_Initialize()
    bCancelConnection = True
End Sub

Attribute VB_Name = "frmDelivery"
Attribute VB_Base = "0{C727963E-F393-4D01-B59E-77D1511CDED5}{A77E7CD7-8A67-4F51-A403-4C10A67A639C}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Option Explicit
Public vidSend As Long
Public tariff As Long

Private Sub cmdOk_Click()
    ' вид отправки
    If optVidSend1.value Then
        vidSend = 1
    ElseIf optVidSend2.value Then
        vidSend = 2
    ElseIf optVidSend3.value Then
        vidSend = 3
    ElseIf optVidSend4.value Then
        vidSend = 4
    ElseIf optVidSend5.value Then
        vidSend = 5
    End If
    
    ' тариф
    If optTariff1.value Then
        tariff = 1
    ElseIf optTariff2.value Then
        tariff = 2
    ElseIf optTariff3.value Then
        tariff = 3
    End If
    
    Me.Hide
End Sub

Private Sub UserForm_Initialize()
    vidSend = 0
    tariff = 0
End Sub

Private Sub UserForm_Activate()
    Dim mlFormHWND
    mlFormHWND = GetActiveWindow
    Call SetWindowPosition(mlFormHWND, HWND_TOPMOST)
End Sub

Attribute VB_Name = "frmParams"
Attribute VB_Base = "0{5797268D-F3F3-463B-B736-2BAB6BB86FBA}{90B82E2B-ECD5-4267-9D8A-46C0511776E3}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Option Explicit

Private Sub cmdCancel_Click()
    bExport = False
    Call Unload(Me)
End Sub

Private Sub cmdOk_Click()
    Dim chk As Object
    Dim PostMark As Long
    Dim PayType As Long
    
    INI.SetINIPath = SettingsIniFile
    
    If Not CheckParam(cbMailType) Then Exit Sub
    
    If Not CheckParam(cbMailCtg) Then Exit Sub
    
    If Not CheckParam(cbMailRank) Then Exit Sub
    
    If Not CheckParam(cbTransType) Then Exit Sub
    
    If Not CheckParam(cbSendCtg) Then Exit Sub
    
    For Each chk In frPostMark.Controls
        If CBool(chk.value) Then
            PostMark = PostMark + CLng(chk.Tag)
        End If
    Next chk
    Call INI.WriteKeyValue("Params", "PostMark", CStr(PostMark))
    
    For Each chk In frPayType.Controls
        If CBool(chk.value) Then
            PayType = PayType + CLng(chk.Tag)
        End If
    Next chk
    Call INI.WriteKeyValue("Params", "PayType", CStr(PayType))
    
    Call INI.WriteKeyValue("Params", "NumContract", txtNumContract.Text)
    
    bExport = True
    Set chk = Nothing
    Me.Hide
End Sub

Private Function CheckParam(cb As ComboBox) As Boolean
    CheckParam = True
    If cb.ListIndex = -1 Then
        MsgBox "Не выбран '" & cb.Tag & "'", vbExclamation, "Выбор параметров"
        CheckParam = False
    End If
    Call INI.WriteKeyValue("Params", Right(cb.Name, Len(cb.Name) - 2), cb.ListIndex)
End Function

Private Sub UserForm_Initialize()
' MailType - Вид отправления
' 0 - Не определено
' 1 - Бланк почтового перевода
' 2 - Письмо
' 3 - Бандероль
' 4 - Посылка
' 5 - Мелкий пакет
' 6 - Почтовая карточка
' 7 - Отправление EMS
' 8 - Секограмма
' 9 - Мешок «М»
' 10 - Прямой контейнер
' 11 - Отправление электронной почты
' 12 - Бланк уведомления
' 13 - Газетная пачка
' 14 - Сгруппированные отправления «Консигнация»
' 15 - Письмо 1 класса
' 16 - Бандероль 1 класса
' 17 - Бланк уведомления 1 класса
' 18 - Сумка страховая
' 19 - ОВПО
' 20 - Мультиконверт
' 21 - МКПО

' MailCtg - Категория отправления
' 0 - Простое
' 1 - Заказное
' 2 - С объявленной ценностью
' 3 - Обыкновенное
' 4 - С объявленной ценностью и наложенным платежом
' 5 - Не определена
' 6 - С объявленной ценностью и обязательным платежом
…