Malicious Office (OLE) — malware analysis report

Static analysis result for SHA-256 722109efad9501de…

MALICIOUS

Office (OLE)

310.5 KB Created: 2008-08-06 13:08:28 Authoring application: Microsoft Excel First seen: 2021-07-02
MD5: 6465a2701d2c1e331182408b7d795ceb SHA-1: eb08ddbccc85b10763b83b2a76e4b0b7a9fa432d SHA-256: 722109efad9501de2bf1d130c95ac3c1a29256068ea0e2088d5bfd4b889210fa
368 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1566.001 Spearphishing Attachment

The sample is an Excel document containing VBA macros that utilize WScript.Shell and the Shell() function, indicating an attempt to execute arbitrary commands. The document body, though in Russian and appearing as a form, contains lures related to MFA and instructions to copy/paste into a shell, strongly suggesting a phishing or credential harvesting attempt. The ClamAV detection as 'Xls.Dropper.Agent' further supports its malicious nature.

Heuristics 9

  • ClamAV: Xls.Dropper.Agent-8951737-0 critical CLAMAV_DETECTION
    ClamAV detected this file as malware: Xls.Dropper.Agent-8951737-0
  • VBA macros detected medium 4 related findings OLE_VBA_MACROS
    Document contains VBA macro code
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
    Public Function SelectFolder(Optional Title As String = "Выберите каталог...", Optional TopFolder As String) As String
    Dim objShell As Object ' New Shell32.Shell
    Dim objFolder As Object  'Shell32.Folder
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
        Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    tmpNumSend = WshShell.RegRead("HKEY_CURRENT_USER\SOFTWARE\EOS\Delo\NumSend")
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, Title, 1, TopFolder)
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
        ' Проверяем наличие %APPDATA%, а то вдруг ...
    appdata = StringRemoveAtEnds(Environ$("appdata"), "\")
    If Not FSO.FolderExists(appdata) Then
  • Reference to Windows Script Host high SC_STR_WSCRIPT
    Reference to Windows Script Host
  • 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
  • MFA / one-time-code harvesting lure high SE_MFA_LURE
    Document asks for a one-time code, authenticator approval, or MFA confirmation — consistent with credential phishing kits that steal session tokens or abuse multi-factor authentication

Extracted artifacts 1

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source) 73834 bytes
SHA-256: be3fdf71055dad33ff54c8e93c44ed34c1acd9a729d0190ac106fe5c08f951d0
Preview script
First 1,000 lines of the extracted script
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
    
    ' проверяем, есть ли названный диапазон export_data
    For Each n In ActiveWorkbook.ActiveSheet.Names
        If Right(n.Name, Len("export_data")) = "export_data" Then
            ' если есть - предлагаем сделать экспорт
            If Not bExportDone Then
                If MsgBox("Экспорт данных не был произведен. Желаете экспортировать сейчас?", vbYesNo Or vbQuestion) = vbYes Then
                    Call export
                End If
            End If
        End If
    Next n
    Set o_Head = Nothing
End Sub


Attribute VB_Name = "Sheet1"
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 sTmp As String
    Dim oCell As Range
    
    For Each oCell In Target.Cells
        If Not (Intersect(oCell, Target.Worksheet.Names("col_mass").RefersToRange) Is Nothing) Then
            sTmp = oCell.value
            If InStr(1, sTmp, ",") > 0 Then
                oCell.value = Left(sTmp, InStr(1, sTmp, ",") - 1)
            End If
            If InStr(1, sTmp, ".") > 0 Then
                oCell.value = Left(sTmp, InStr(1, sTmp, ".") - 1)
            End If
        End If
    Next oCell
End Sub

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 = "frmConnect"
Attribute VB_Base = "0{130531BB-A135-4F3E-B67F-063C4C7236CD}{7AD3E04A-E7E7-4C5E-AFD3-A57F75552272}"
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 = "frmParams"
Attribute VB_Base = "0{F23CAD33-F038-4CEE-A39B-E416C91698E0}{13AB6A4C-D68E-4B44-AE16-4318CC992076}"
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, PostMark As Long
    Dim tmp As String   'Для вставляемого в поле текста
    
    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(cbOtpravitel) Then Exit Sub
    
    If cbOtpravitel = "2 - Бюджетная организация" Then
        sSendCtg = "2"
    Else
        sSendCtg = "3"
    End If
    sNumContract = Contact
    
    tmp = ""
    For Each chk In frmParams.frPostMark.Controls
        If CBool(chk.value) Then
            PostMark = PostMark + CLng(chk.Tag)
            If chk.Tag = 0 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "0 - Без отметки"
            ElseIf chk.Tag = 1 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "1 - С простым уведомлением"
            ElseIf chk.Tag = 2 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "2 - С заказным уведомлением"
            ElseIf chk.Tag = 4 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "4 - С описью"
            ElseIf chk.Tag = 8 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "8 - Осторожно (Хрупкая)"
            ElseIf chk.Tag = 16 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "16 - Тяжеловесная"
            ElseIf chk.Tag = 32 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "32 - Крупногабаритная (Громоздкая)"
            ElseIf chk.Tag = 64 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "64 - С доставкой (Доставка нарочным)"
            ElseIf chk.Tag = 128 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "128 - Вручить в собственные руки"
            ElseIf chk.Tag = 256 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "256 - С документами"
            ElseIf chk.Tag = 512 Then
                tmp = tmp & IIf(tmp <> "", ", ", "") & "512 - С товарами"
            End If
        End If
    Next chk
    Call INI.WriteKeyValue("Params", "PostMark", CStr(PostMark))
    
    With ActiveWorkbook.ActiveSheet
        .Names("MailType").RefersToRange.Cells(1, 1).value = "Вид отправлений: " & cbMailType & " (" & cbMailCtg & ")"
        .Names("MailMark").RefersToRange.Cells(1, 1).value = "Отметки: " & tmp
        .Names("MailRank").RefersToRange.Cells(1, 1).value = "Разряд: " & cbMailRank
    End With
    
    bExport = True
    Set chk = Nothing
    Call Unload(Me)
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
'1 - Почтовый перевод
'2 - Письмо
'3 - Бандероль
'4 - Посылка
'5 - Мелкий пакет
'6 - Почтовая карточка
'7 - Отправление экспресс-почты
'8 - Секограмма
'9 - Мешок "М"
'10 - Прямой контейнер
'11 - Отправление электронной почты
'12 - Бланк уведомления
'13 - Газетная пачка
'14 - Сгруппированные отправления "Консигнация"

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

'PostMark
'0 - Без отметки
'1 - С простым уведомлением
'2 - С заказным уведомлением
'4 - С описью
'8 - Осторожно (Хрупкая)
'16 - Тяжеловесная
'32 - Крупногабаритная (Громоздкая)
'64 - С доставкой (Доставка нарочным)
'128 - Вручить в собственные руки
'256 - С документами
'512 - С товарами

'MailRank
'0 - Без разряда
'1 - Правительственное
'2 - Воинское
'3 - Служебное

    cbMailType.AddItem "1 - Почтовый перевод"
    cbMailType.AddItem "2 - Письмо"
    cbMailType.AddItem "3 - Бандероль"
    cbMailType.AddItem "4 - Посылка"
    cbMailType.AddItem "5 - Мелкий пакет"
    cbMailType.AddItem "6 - Почтовая карточка"
    cbMailType.AddItem "7 - Отправление экспресс-почты"
    cbMailType.AddItem "8 - Секограмма"
    cbMailType.AddItem "9 - Мешок " & Chr(34) & "М" & Chr(34)
    cbMailType.AddItem "10 - Прямой контейнер"
    cbMailType.AddItem "11 - Отправление электронной почты"
    cbMailType.AddItem "12 - Бланк уведомления"
    cbMailType.AddItem "13 - Газетная пачка"
    'cbMailType.AddItem " - Сгруппированные отправления " & Chr(34) & "Консигнация" & Chr(34)
    cbMailType.AddItem "14 - Сгруппированные отпр. " & Chr(34) & "Консигнация" & Chr(34)
    
    cbMailCtg.AddItem "0 - Простое"
    cbMailCtg.AddItem "1 - Заказное"
    cbMailCtg.AddItem "2 - С объявленной ценностью"
    cbMailCtg.AddItem "3 - Обыкновенное"
    cbMailCtg.AddItem "4 - С объявл. ценностью и налож. платежом"
    
    cbMailRank.AddItem "0 - Без разряда"
    cbMailRank.AddItem "1 - Правительственное"
    cbMailRank.AddItem "2 - Воинское"
    cbMailRank.AddItem "3 - Служебное"
    
    cbOtpravitel.AddItem "2 - Бюджетная организация"
    cbOtpravitel.AddItem "3 - Хозрасчетная организация"
    
    INI.SetINIPath = SettingsIniFile
    Call cbReadValueFromIni(cbMailType)
    Call cbReadValueFromIni(cbMailCtg)
    Call cbReadValueFromIni(cbMailRank)
    Call chkReadValueFromIni(CLng(INI.ReadKeyValue("Params", "PostMark", "0")))
    Call cbReadValueFromIni(cbOtpravitel)
End Sub

Private Sub cbReadValueFromIni(cb As ComboBox)
    cb.ListIndex = CLng(INI.ReadKeyValue("Params", Right(cb.Name, Len(cb.Name) - 2), "-1"))
End Sub

Private Sub chkReadValueFromIni(val As Long)
    Dim duo As Long
    Dim chk As Object
    
    If val > 0 Then
        For duo = 9 To 0 Step -1
            If val <> val Mod (2 ^ duo) Then
                val = val Mod (2 ^ duo)
                For Each chk In frmParams.frPostMark.Controls
                    If CStr(chk.Tag) = CStr(2 ^ duo) Then
                        chk.value = 1
                        Exit For
                    End If
                Next chk
            End If
        Next duo
    End If
    Set chk = Nothing
End Sub

Attribute VB_Name = "modBarcode"
Option Explicit

'Строка штрих-кода в кодировке Interleaved 2 of 5
Public Function GETBarCodeInterleaved_2of5(code As String) As String
    Dim i As Integer
    Dim D As String
    Dim s As String
    Dim Ch As Integer
    Dim K As Integer
    'Преобразование к строке цифр
    D = ""
    For i = 1 To Len(code)
        Ch = Asc(Mid(code, i, 1))
        If (48 <= Ch) And (Ch <= 57) Then
            D = D & Chr(Ch)
        End If
    Next i
    'Составление строки кода по парам цифр
    s = ""
    For i = 0 To Len(D) / 2 - 1
        s = s & Code_Char(Interleaved_2of5_Pair(Mid(D, i * 2 + 1, 2)))
    Next i
    'Добавить старт/стоп символы
    GETBarCodeInterleaved_2of5 = Code_Char("1111") & s & Code_Char("3111")
End Function

'Определение ширины полос Interleaved 2 of 5 для одного символа
Private Function Code_2of5_Ch(Ch As String) As String
    Dim s As String
    Select Case Ch
        Case "0": s = "11331"
        Case "1": s = "31113"
        Case "2": s = "13113"
        Case "3": s = "33111"
        Case "4": s = "11313"
        Case "5": s = "31311"
        Case "6": s = "13311"
        Case "7": s = "11133"
        Case "8": s = "31131"
        Case "9": s = "13131"
    End Select
    Code_2of5_Ch = s
End Function

'Определение набора полос Interleaved 2 of 5 по двум символам
Private Function Interleaved_2of5_Pair(Pair As String) As String
    Dim S1 As String
    Dim S2 As String
    Dim s As String
    Dim i As Integer
    S1 = Code_2of5_Ch(Mid(Pair, 1, 1))
    S2 = Code_2of5_Ch(Mid(Pair, 2, 1))
    s = ""
    For i = 1 To Len(S1)
        s = s & Mid(S1, i, 1) & Mid(S2, i, 1)
    Next i
    Interleaved_2of5_Pair = s
End Function

'Штриховые символы
Private Function Code_Char(a As String) As String
    Dim s As String
    Dim i As Integer
    s = ""
    For i = 0 To Len(a) / 2 - 1
        Select Case Mid(a, 2 * i + 1, 2)
            Case "11": s = s & "0"
            Case "31": s = s & "2"
            Case "13": s = s & "8"
            Case "33": s = s & ":"
        End Select
    Next i
    Code_Char = s
End Function


Attribute VB_Name = "modSelectFolder"
Option Explicit

'диалоговое окно выбора каталога
Public Function SelectFolder(Optional Title As String = "Выберите каталог...", Optional TopFolder As String) As String
    Dim objShell As Object ' New Shell32.Shell
    Dim objFolder As Object  'Shell32.Folder
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, Title, 1, TopFolder)

    If Not objFolder Is Nothing Then
        SelectFolder = objFolder.Self.path
    End If
End Function


Attribute VB_Name = "modSettings"
Option Explicit
' 23.09.2019
Private locSettingsIniFile As String

Public Function SettingsIniFile() As String
    If locSettingsIniFile = "" Then
        MsgBox "Не определен файл для сохранения настроек", vbExclamation, "Отчёты"
    End If
    SettingsIniFile = locSettingsIniFile
End Function

Public Sub SettingIniFileDefine(isn_user As String, templateName As String)
    locSettingsIniFile = CreateDataFolder & "\" & isn_user & "_" & templateName & ".ini"
End Sub

Private Function CreateDataFolder() As String
    Const subfolders As String = "EOS\Delo\Shablons"
    
    Dim FSO As Object
    Dim appdata As String
    Dim path As String
    Dim m() As String
    Dim i As Long
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' Проверяем наличие %APPDATA%, а то вдруг ...
    appdata = StringRemoveAtEnds(Environ$("appdata"), "\")
    If Not FSO.FolderExists(appdata) Then
        MsgBox "Не найден каталог %APPDATA%", vbCritical, "Отчет"
        End
    End If
    
    path = appdata
    m = Split(subfolders, "\")
    For i = 0 To UBound(m)
        path = path & "\" & m(i)
        If Not FSO.FolderExists(path) Then
            Call FSO.CreateFolder(path)
        End If
    Next i
    
    CreateDataFolder = path
End Function

Private Function StringEndsWith(str As String, searchStr As String, Optional ignoreCase As Boolean = True) As Boolean
    ' Проверить, что переданная строка заканчивается символами searchStr
    If ignoreCase Then
        StringEndsWith = UCase(Right(str, Len(searchStr))) = UCase(searchStr)
    Else
        StringEndsWith = Right(str, Len(searchStr)) = searchStr
    End If
End Function

Private Function StringRemoveAtEnds(str As String, removeEnd As String, Optional ignoreCase As Boolean = True) As String
    ' если в конце строки есть строка removeEnd, то удалить её там
    StringRemoveAtEnds = str
    If StringEndsWith(str, removeEnd, ignoreCase) Then
        StringRemoveAtEnds = Left(str, Len(str) - Len(removeEnd))
    End If
End Function

Attribute VB_Name = "UserForm1"
Attribute VB_Base = "0{29DB8289-117F-4C88-B544-DB69E6B0571A}{B06DF331-9E8F-4BDB-8555-FEFDB68CD07E}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False









Private Sub CommandButton1_Click()
If ListBox1.ListIndex <> -1 Then
    NumSendPub = ListBox1.list(ListBox1.ListIndex, 2)
    FIO_eksp_str = ListBox1.list(ListBox1.ListIndex, 0)
    If Len(NumSendPub) = 0 Then
       'Если совпадений нет, то выводим окно с информацией, что ФИО пользователя и ФОИ должностного лица не совпадают, и предложением ввести индекс должностного лица. Этот введенный пользователем индекс вставляем в номер отправки.
       'MsgBox "ФИО пользователя и ФИО должностного лица не совпадают", 48, "Внимание!"
       NumSendPub = InputBox("У выбранного должностного лица отсутствует индекс." & Chr(10) & Chr(13) & Chr(10) & Chr(13) & "Введите индекс должностного лица:", "Внимание!", "1")
    End If
    Unload Me
Else
    MsgBox "Вы не выбрали должностное лицо.", 48, "Внимание!"
    Exit Sub
End If
End Sub

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

Attribute VB_Name = "Модуль1"
Option Explicit
Private Const B_BARCODE As Boolean = True ' выводить штрих-код (True) или его числовое значение (False)

#If VBA7 Then
    Public Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Public Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
#Else
    Public Declare Function GetActiveWindow Lib "user32" () As Long
    Public Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
#End If
Public Const HWND_TOPMOST = -1&
Public Const HWND_NOTOPMOST = -2&
Public Const SWP_NOACTIVATE = &H10&
Public Const SWP_SHOWWINDOW = &H40&
Public Const SWP_NOMOVE = &H2&
Public Const SWP_NOSIZE = &H1&

Public Const DOT_NAME As String = "reesmail2_partion.xlt"

Public o_Head As Object     ' Головной объект API
Private objEnvir As Object  ' Объекты связи с системой дело. См. приложение
Private objParm As Object   ' Объекты связи с системой дело. См. приложение
Private objNotify As Object ' Объекты связи с системой дело. См. приложение
Private sh As Worksheet     ' текущий лист excel

Public INI As New clINI     ' для работы с ини файлами

Private OfficeIni As String ' путь к office.ini
Public ShablonsPath As String ' путь к шаблонам системы
Public bExport As Boolean       ' флаг - нужно ли экспортировать
Public bExportDone As Boolean   ' флаг - был ли экспорт

Private li_version As Long      'Номер версии

Private Type t_export_ini
    Inn As String
    SendCtg As String
    SendDate As String
    SendTime As String
    ListNum As String
    MailType As String
    MailCtg As String
    PostMark As String
    MailRank As String
    NumContract As String
    Otpravitel As String

    MailCount As String
    ValueSum As String
    PaymentSum As String
    MassSum As String
    MassRateSum As String
    InsrRateSum As String
    AirRateSum As String
End Type
Private ExportIni As t_export_ini


Public NumSendPub As String
Public FIO_eksp_str As String 'ФИО экспедитора
Public tmpNumSend As String
Public sSendCtg As String
Public sNumContract As String


'  Главный модуль
Sub start()
    Set sh = ActiveWorkbook.ActiveSheet
        
    bExportDone = False
    On Error Resume Next

    'Делаем шаблон видимым
    Application.Visible = True
    Application.WindowState = xlMinimized
    
    'Присоединение к БД, создание головного объекта API и объектов связи с системой
    Call OpenDB
    Call SettingIniFileDefine(nvl(o_Head.userinfo.isn), DOT_NAME)
    OfficeIni = objParm.GetCell("INI_FILE", 0)
    
    'Определяем версию
    li_version = CLng(Left(Application.Version, InStr(Application.Version, ".") - 1))
    
    Dim WshShell As Object
    Set WshShell = CreateObject("WScript.Shell")
    tmpNumSend = WshShell.RegRead("HKEY_CURRENT_USER\SOFTWARE\EOS\Delo\NumSend")
    FIO_eksp_str = WshShell.RegRead("HKEY_CURRENT_USER\SOFTWARE\EOS\Delo\FIOeksp")
    If Err.Number <> 0 Then
        Err.Clear
    End If
    
    'Вставляем данные о реестре в таблицу
    Call insert_reestr
    
    If tmpNumSend <> 0 Then
        WshShell.RegDelete "HKEY_CURRENT_USER\SOFTWARE\EOS\Delo\NumSend"
    End If
    
    'Сообщаем вызвавшему окну о завершении печати
    objNotify.Notify "w_wait_oper"
    
    'Отсоединяемся от БД и удаляем объекты
    Call closeDB
    
    Range("A1").Select
    Application.Visible = True
    'Делаем отчет во весь экран
    Application.WindowState = xlMaximized
End Sub

'Присоединение к БД, создание головного объекта API и объектов связи с системой
Private Sub OpenDB()
    'Создание объектов связи с ситемой
    Set objEnvir = CreateObject("EOSENVIRONMENT.EAPIFactory")
    Set objParm = CreateObject("EOSENVIRONMENT.RawData")
    Set objNotify = CreateObject("EOSENVIRONMENT.Notifications")
    
    Set o_Head = objEnvir.CreateHead

    If Err.Number <> 0 Then
        MsgBox ("Не удалось присоединиться к базе данных")
        
        Set objEnvir = Nothing
        'Сообщаем вызвавшему окну о завершении
        objNotify.Notify "w_wait_oper"
        Set objNotify = Nothing
        
        If objParm.keyexists("@@WordReuse@@") Then
            Set objParm = Nothing
            ActiveWorkbook.Close False
        Else
            Set objParm = Nothing
            ActiveWorkbook.Close False
            Application.Quit
        End If
    End If
End Sub

'повторное Присоединение к БД
Private Function OpenDB2() As Boolean
Dim srv As String, own As String
Dim usr As String, pas As String

OpenDB2 = False
    'берем из ини ServerName и Owner
    INI.SetINIPath = OfficeIni
    srv = INI.ReadKeyValue("Database", "ServerName")
    own = INI.ReadKeyValue("Database", "Owner")
    If srv = vbNullString Or own = vbNullString Then
        MsgBox "В office.ini не прописаны параметры ServerName или Owner" & vbCr & "Обратитесь к системному технологу", _
                vbCritical, "Ошибка подключения"
        Exit Function
    End If
    'Запрашиваем логин/пароль
    Do While Not OpenDB2
        frmConnect.Show
        If frmConnect.bCancelConnection Then Exit Do
        usr = frmConnect.usr.Text
        pas = frmConnect.pas.Text: frmConnect.pas.Text = vbNullString
        
        If Err.Number <> 0 Then
            Err.Clear
        End If
        'подключаемся к БД
        Set o_Head = CreateObject("Eapi.Head")
        o_Head.OpenWithParamsEx srv, own, usr, pas
        If Err.Number <> 0 Then
            MsgBox ("Не удалось присоединиться к базе данных")
            Set o_Head = Nothing
        Else
            If o_Head.ErrCode <> 0 Then
                MsgBox "Неверный идентификатор или пароль!", vbCritical, "Ошибка подключения"
                Set o_Head = Nothing
            Else
                OpenDB2 = True
            End If
        End If
    Loop
End Function

'Вставляет данные в поля
Private Sub insert_reestr()
    Dim tbl As Object ' объект RecordSet
    
    Dim cnt As Long     ' кол-во пакетов
    Dim isn As Long     ' код пакета
    Dim pack As Object  ' объект пакета
    Dim r As Long       ' номер строки
    Dim start_row As Long ' первая строка
    
    Dim sBarCode As String  ' числовой штрих-код
    Dim items_cnt As Long   ' кол-во вложений
    
    Dim tmp As String
    Dim c As Long
    
    
    isn = objParm.GetCell("isn_package", 0)
    Set pack = o_Head.GetRow("Package", isn)
    
    ' номер реестра, дата и время
    tmp = nvl(pack.roll.Number) & " от " & Format(nvl(pack.roll.SendDate), "dd.mm.yyyy")
    sh.Names("list_num").RefersToRange.Cells(1, 1).value = "СПИСОК № " & tmp
    ExportIni.SendDate = Format$(nvl(pack.roll.SendDate), "yyyymmdd")
    
    ' Отправитель
    If GetMultiplyFields("select delo_owner.name from delo_owner", tbl) Then
        tmp = nvl(tbl.Fields("name").value)
        sh.Names("sender").RefersToRange.Cells(1, 1).value = "Отправитель: " & tmp
    End If
    
    ' наименование отделения связи из справочника "Настройки партионной почты"
    If GetMultiplyFields("select post_office from bar_code_support", tbl) Then
        sh.Names("filed_with").RefersToRange.Cells(1, 1).value = "поданных в " & nvl(tbl.Fields("post_office").value)
    End If
    
    ' данные в цикле по всем переданным пакетам
    items_cnt = 0
    cnt = objParm.GetRowsCount("isn_package")
    start_row = sh.Names("start_row").RefersToRange.Row
    For r = 0 To cnt - 1
        ' Создаём объект с информацией о пакете
        isn = objParm.GetCell("isn_package", r)
        Set pack = o_Head.GetRow("Package", isn)
        
        items_cnt = items_cnt + nvl(pack.ItemCnt, "0")
        
        ' вытаскиваем из базы числовое значение штрих-кода по isn пакета
        sBarCode = vbNullString
        If GetMultiplyFields("select bar_code from send_package where isn_package = " & isn, tbl) Then
            sBarCode = nvl(tbl.Fields("bar_code").value)
        End If
        
        ' добавляем строку
        sh.Rows(r + start_row + 1).Insert Shift:=xlShiftDown
        
…

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