Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ЭтаКнига"
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

Attribute VB_Name = "Лист1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Лист2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Лист3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Module1"

Public Type ItemI
    factualAddress As String
    postAddress As String
    lastName As String
    organizationName As String
    offer As Double
    INN As String
    kpp As String
    contactPhone As String
    legalAddress As String
    additionalInfo As String
    lotNumber As Integer
    lotObjectInfo As String
    maxPrice As Double
    customer As String
    purchaseNumber As String
    protocolDate As String
    href As String
    href_printForm As String
    Type_printForm As String
    Обеспечение As Double
    
End Type

Private Function Get_Col(a As Collection, S As String) As Boolean

    On Error Resume Next

    Get_C = a(S)

    Get_Col = Err.Number <> 0


End Function



Function Read_supplier(strFilePath, Fl As Boolean) As ItemI
    Fl = False
    Dim Item_ As ItemI
    Dim objNode As MSXML2.IXMLDOMNode
    Dim objRoot As MSXML2.IXMLDOMElement
    Dim objListOfNodes As IXMLDOMNodeList
    Dim objDoc As DOMDocument30
    Dim objElem As MSXML2.IXMLDOMElement, oElem As MSXML2.IXMLDOMElement
    Set objDoc = New DOMDocument30
    objDoc.resolveExternals = True

    objDoc.async = False
    objDoc.validateOnParse = False
    On Error Resume Next
    objDoc.Load (strFilePath)
    XPath = "//oos:suppliers/oos:supplier"

    Set objListOfNodes = objDoc.SelectNodes(XPath)

    If objListOfNodes.Length = 0 Then
        XPath = "//oos:suppliers/oos:supplier"

        '   Debug.Print objDoc.XML

        Set objListOfNodes = objDoc.SelectNodes(XPath)

    End If


    Fl = False

    'ns2:applicationRate

    For Each objRoot In objListOfNodes

        For Each objNode In objRoot.ChildNodes
            Fl = True
            Select Case objNode.baseName
            Case "organizationName"
                Item_.organizationName = objNode.Text
            'Case "inn"
            Case "idNumber"
                Item_.INN = objNode.Text
            Case "kpp"
                Item_.kpp = objNode.Text
            Case "postAddress"
                Item_.postAddress = objNode.Text
            Case "factualAddress"
                Item_.factualAddress = objNode.Text
            Case "contactInfo"
                Item_.lastName = objNode.Text
            Case "contactPhone"
                Item_.contactPhone = objNode.Text
            Case "additionalInfo"
                Item_.additionalInfo = objNode.Text

            End Select
        Next
    Next

    Read_supplier = Item_

End Function





Sub Start()
    Dim a As Collection, F As Boolean, FF As ItemI, Sh As Worksheet

    Dim col As Collection
    Set col = New Collection
    Dim folders As String
    folders = GetFolderPath
    If folders = "" Then Exit Sub
    Application.ScreenUpdating = False
    ThisWorkbook.Worksheets(2).Copy

    Set Sh = ActiveSheet
    lLastRowMY = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row
    Set a = Get_Item(folders)
    For n = 1 To a.Count
        F = False
        DoEvents
        FF = Read_supplier(a(n), F)
        If F = True Then

            If Get_Col(col, FF.INN) Then
                col.Add FF.INN, FF.INN
                lLastRowMY = lLastRowMY + 1
                With Sh
                    .Cells(lLastRowMY, 1) = FF.organizationName
                    .Cells(lLastRowMY, 2) = FF.postAddress
                    .Cells(lLastRowMY, 3) = FF.factualAddress
                    .Cells(lLastRowMY, 4) = FF.lastName
                    .Cells(lLastRowMY, 5) = FF.additionalInfo
                    .Cells(lLastRowMY, 6) = "'" & FF.INN
                    .Cells(lLastRowMY, 7) = "'" & FF.kpp
                    .Cells(lLastRowMY, 8) = FF.contactPhone


                End With
            End If

        End If

    Next
    Application.ScreenUpdating = True

End Sub

Function Get_Item(Path_Base) As Collection
    Dim Path As String
    Dim a As Collection
    Set a = New Collection
    On Error GoTo Get_Item_Error

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Dim strPath As String

    Dim strFile As String, strFile2 As String
    Set FSO = CreateObject("scripting.filesystemobject")
    Set curfold = FSO.GetFolder(Path_Base)
    If Not curfold Is Nothing Then
        For Each fil In curfold.Files

            If InStr(1, fil.Name, ".xml", vbTextCompare) > 0 Then

                a.Add fil.Path

            End If
        Next

    End If
    Set FSO = Nothing


    On Error GoTo 0
    Set Get_Item = a
    Exit Function

Get_Item_Error:

    Set Get_Item = a

End Function

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку ", Optional ByVal InitialPath As String) As String
    Dim PS

    GetFolderPath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath:
        If .Show = -1 Then GetFolderPath = .SelectedItems(1): If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath
    End With
End Function














Attribute VB_Name = "Module2"
Public Предел As Double
Sub За_Обеспечением()

    Предел = Val(ThisWorkbook.Worksheets(1).Range("K3"))

    If Предел = 0 Then Предел = 20000

    Dim a As Collection, Протокол As String
    Dim pr As ProgressIndicator
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Temp_path = ThisWorkbook.Path & "\Protokol"
    If Not FSO.FolderExists(Temp_path) Then
        FSO.CreateFolder Temp_path
    End If

    Set FSO = Nothing
    F$ = Temp_path & "\Сбор.csv"
    Dim col As Collection
    Set col = New Collection
    Dim folders As String
    folders = GetFolderPath
    If folders = "" Then Exit Sub
    Open F$ For Output As #1
    Print #1, "purchaseNumber;Обеспечение;Документ;Файл"

    Set pr = New ProgressIndicator

    pr.SetFocus
    Set a = Get_Item(folders)
    For n = 1 To a.Count
        pr.Set_ProgressBar 100 * n / a.Count
        Протокол = Read_Протокол(a(n))
        If Протокол <> "" Then
            Print #1, Протокол
        End If

    Next
    Set pr = Nothing

    Close #1
End Sub

Function Read_Протокол(strFilePath) As String
    Dim Обеспечение As Double
    Dim purchaseNumber As String, file_Name As String, URL As String
    Dim objNode As MSXML2.IXMLDOMNode
    Dim objRoot As MSXML2.IXMLDOMElement
    Dim objListOfNodes As IXMLDOMNodeList
    Dim objDoc As DOMDocument30
    Dim objElem As MSXML2.IXMLDOMElement, oElem As MSXML2.IXMLDOMElement
    Set objDoc = New DOMDocument30
    objDoc.resolveExternals = True
    objDoc.async = False
    objDoc.validateOnParse = False
    On Error Resume Next
    objDoc.Load (strFilePath)
    XPath = "//purchaseNumber"
    Set objListOfNodes = objDoc.SelectNodes(XPath)
    If objListOfNodes.Length > 0 Then
        purchaseNumber = objListOfNodes(0).Text
    Else
        Read_Протокол = ""
        Exit Function
    End If

    XPath = "//attachments/attachment"
    Set objListOfNodes = objDoc.SelectNodes(XPath)
    If objListOfNodes.Length > 0 Then
        For Each objNode In objListOfNodes(0).ChildNodes
            Fl = True
            Select Case objNode.baseName
            Case "fileName"
                file_Name = objNode.Text
            Case "url"
                URL = objNode.Text
            End Select
        Next
    End If
    Set objDoc = Nothing
    Наименованиеобъекта = ""


    Обеспечение = G_Обеспечение(purchaseNumber, Наименованиеобъекта)
    If Обеспечение < Предел Then
        Read_Протокол = ""
        Exit Function
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Temp_path = ThisWorkbook.Path & "\Protokol"
    If Not FSO.FolderExists(Temp_path) Then
        FSO.CreateFolder Temp_path
    End If
    Temp_path = Temp_path & "\" & purchaseNumber
    If Not FSO.FolderExists(Temp_path) Then
        FSO.CreateFolder Temp_path
    End If
    Наименованиеобъекта = Replace(Наименованиеобъекта, ";", "")


    If 1 = 2 Then

        If DownloadFile(URL, Temp_path & "\" & file_Name) Then
            Read_Протокол = "'" & purchaseNumber & ";" & Наименованиеобъекта & ";" & Обеспечение & ";" & file_Name & ";" & Temp_path & "\" & file_Name
        Else
            Read_Протокол = "'" & purchaseNumber & ";" & Наименованиеобъекта & ";" & Обеспечение & ";" & file_Name & ";" & "http://zakupki.gov.ru/epz/order/notice/zp44/view/documents.html?regNumber=" & purchaseNumber
            FSO.deleteFolder Temp_path

        End If

    Else


        Read_Протокол = "'" & purchaseNumber & ";" & Наименованиеобъекта & ";" & Обеспечение & ";" & file_Name & ";" & URL



    End If


    Set FSO = Nothing

End Function





Function G_Обеспечение(ByVal U, ByRef Наименованиеобъекта) As Double
'  http://zakupki.gov.ru/epz/order/notice/zp44/view/documents.html?regNumber=0190100001714000006
' On Error GoTo G_Обеспечение_Error

'' http://zakupki.gov.ru/epz/order/notice/zp44/view/common-info.html?regNumber=0148300041114000006"

    S = GET_Обеспечение("http://zakupki.gov.ru/epz/order/notice/zp44/view/common-info.html?regNumber=" & U)
    Dim X
    If S = "" Then Exit Function


    X = Split(S, "<tr>")
    For n = 1 To UBound(X)


        If InStr(1, X(n), "Наименование объекта закупки", vbTextCompare) > 0 Then
            X(n) = Replace(X(n), Chr(10), "")
            X(n) = Replace(X(n), Chr(13), "")
            Наименованиеобъекта = Trim(Split(X(n), "<td>")(1))

        End If


        If InStr(1, X(n), "Размер обеспечения исполнения контракта", vbTextCompare) > 0 Then
            X(n) = Replace(X(n), Chr(10), "")
            X(n) = Replace(X(n), Chr(13), "")
            G_Обеспечение = Val(Trim(Split(X(n), "<td>")(1)))
            Exit Function
        End If
    Next
    G_Обеспечение = 0
    On Error GoTo 0
    Exit Function
G_Обеспечение_Error:
    G_Обеспечение = 0
End Function
Function DownloadFile(ByVal URL$, ByVal LocalPath$) As Boolean
' Функция скачивает файл по ссылке URL$
' и сохраняет его под именем LocalPath$
    Dim XMLHTTP, ADOStream, FileName
    On Error Resume Next: Kill LocalPath$

    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "GET", Replace(URL$, "\", "/"), "False"
    'C мозилой понимает язык русский IE не катит

    XMLHTTP.setRequestHeader "user-agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.2; .NET CLR 1.0.3705;)"
    XMLHTTP.setRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.5,en;q=0.3"
    XMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    XMLHTTP.send

    ' responseText

    If XMLHTTP.statustext = "OK" Then
        Set ADOStream = CreateObject("ADODB.Stream")
        ADOStream.Type = 1: ADOStream.Open
        ADOStream.Write XMLHTTP.responseBody

        ADOStream.SaveToFile LocalPath$, 2
        ADOStream.Close: Set ADOStream = Nothing
        DownloadFile = True
    Else
        DownloadFile = False
    End If
    Set XMLHTTP = Nothing
End Function


Function GET_Обеспечение(ByVal URL$) As String
' Функция скачивает файл по ссылке URL$
' и сохраняет его под именем LocalPath$
    Dim XMLHTTP
    On Error Resume Next:

    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "GET", Replace(URL$, "\", "/"), "False"
    'C мозилой понимает язык русский IE не катит

    XMLHTTP.setRequestHeader "user-agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.2; .NET CLR 1.0.3705;)"
    XMLHTTP.setRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.5,en;q=0.3"
    XMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    XMLHTTP.send

    ' responseText

    If XMLHTTP.statustext = "OK" Then
        GET_Обеспечение = XMLHTTP.responseText
    Else
        GET_Обеспечение = ""
    End If
    Set XMLHTTP = Nothing
End Function

Attribute VB_Name = "ProgressIndicator"
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 FP As New M_Progress

Private SubActionIndex As Single, SubActionsCount As Single
Private FPVisible As Boolean, FPStartTime As Date, Position As Integer
Private PrS As Integer, PrE As Integer, Percent As Double, Percent1 As Double, Percent2 As Double
Public Parent As ProgressIndicator
Public Property Get Visible(): Visible = FPVisible: End Property

Public Property Let Text(S As String)
    FP.Caption = S
End Property

Public Property Let Color1(S As Integer)

    If S = 1 Then
        FP.shpUncmp1.BackColor = &HFF00&
    End If

End Property
Public Property Let Color2(S As Integer)

    If S = 2 Then
        FP.shpUncmp2.BackColor = &HFF&
    End If

End Property


Sub Move(ByVal Position As Integer)    ' позиция прогресс-бара на экране по вертикали
    If Abs(Position) > 3 Then Exit Sub
    FP.Top = FP.Top + (FP.Height + 3) * Position
End Sub
Sub SetFocus()    ' делает форму прогресс-бара активной
    FP.Show 0: If Position <> 0 Then Move Position
End Sub


Private Sub Class_Initialize()
' параметры по умолчанию для вновь создаваемого индикатора
    Set FP = New M_Progress
    FPVisible = True

End Sub
Sub Set_ProgressBar(ByVal NewPercent As Double)
' изменение ширины индикатора
    Percent = NewPercent
    If NewPercent > 100 Then Percent = 100
    If NewPercent < 0 Then Percent = 0
    DoEvents
    FP.shpUncmp.Width = FP.picProgress.Width * NewPercent / 100

    FP.Repaint
    DoEvents
End Sub

Sub Set_ProgressBar1(ByVal NewPercent As Double)
' изменение ширины индикатора
    Percent1 = NewPercent
    If NewPercent > 100 Then Percent1 = 100
    If NewPercent < 0 Then Percent1 = 0
    DoEvents
    FP.shpUncmp1.Width = FP.picProgress1.Width * NewPercent / 100

    FP.Repaint
    DoEvents
End Sub

Sub Set_ProgressBar2(ByVal NewPercent As Double)
' изменение ширины индикатора
    Percent2 = NewPercent
    If NewPercent > 100 Then Percent2 = 100
    If NewPercent < 0 Then Percent2 = 0
    DoEvents
    FP.shpUncmp2.Width = FP.picProgress2.Width * NewPercent / 100

    FP.Repaint
    DoEvents
End Sub
Sub Show(Optional ByVal FPPosition As Integer = 0)
' отображает прогресс-бар
' On Error Resume Next:

    Position = FPPosition
    FP.Show (0)
    If Position <> 0 Then Move Position
    FP.Repaint: DoEvents
End Sub
Private Sub Class_Terminate()        ' уничтожение экземпляра класса
    Unload FP: FPVisible = False
End Sub

Attribute VB_Name = "M_Progress"
Attribute VB_Base = "0{46E6635C-FA1D-419B-910C-6965EFA51D0C}{48B33E9C-73DB-4E33-8D8F-9CF1093BEA47}"
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 Const WS_BORDER As Long = &H800000
Private Const GWL_EXSTYLE = (-20)
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function 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) As Long


Private Const GWL_STYLE = (-16)
Private Const WS_THICKFRAME = &H40000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000


Private hWnd As Long
Private WndStyle As Long




Private Sub Image1_Click()

End Sub




Private Sub picProgress_Click()

End Sub

Private Sub picProgress1_Click()

End Sub

Private Sub shpUncmp_Click()

End Sub

Private Sub UserForm_Activate()
    Set_Progress 0

    Set_Progress1 0
    Set_Progress2 0


End Sub

Private Sub Set_Progress(ByVal Uncompr As Double)
    shpUncmp.Width = picProgress.Width * Uncompr

    DoEvents
End Sub
Private Sub Set_Progress1(ByVal Uncompr As Double)
    shpUncmp1.Width = picProgress1.Width * Uncompr

    DoEvents
End Sub

Private Sub Set_Progress2(ByVal Uncompr As Double)
    shpUncmp2.Width = picProgress2.Width * Uncompr

    DoEvents
End Sub



Attribute VB_Name = "Module11"

Const пароль As String = "gthdsqujc"
Const Логин As String = "gostendery"

Sub ТЕСТ()
Dim INN
'n = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
For i = 2 To 600
INN = Worksheets("Inet").Cells(i, 11)

 Worksheets("Inet").Cells(i, 16) = проверка_INN(INN)
Next
End Sub





Function проверка_INN(ByVal INN) As String

URL$ = "http://bg.vkb-bank.ru/extranet/demands/index.php?login=yes"

    Dim XMLHTTP
    On Error Resume Next
проверка_INN = "Что-то пошло не так"
    Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
    XMLHTTP.Open "POST", Replace(URL$, "\", "/"), "False"
    XMLHTTP.setRequestHeader "user-agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.2; .NET CLR 1.0.3705;)"
    XMLHTTP.setRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.5,en;q=0.3"
    XMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    XMLHTTP.send "AUTH_FORM=Y&TYPE=AUTH&backurl=%2Fextranet%2Fdemands%2Findex.php&USER_LOGIN=" & _
    Логин & "&USER_PASSWORD=" & пароль
    If XMLHTTP.statustext = "OK" Then
        XMLHTTP.abort
        URL$ = "http://bg.vkb-bank.ru/extranet/demands/edit.php?DEMAND_ID=0"
        XMLHTTP.Open "Get", Replace(URL$, "\", "/"), "False"
        XMLHTTP.send
        If XMLHTTP.statustext = "OK" Then
            href = Get_Href(XMLHTTP.responseText, INN)
            If href <> "" Then
                XMLHTTP.abort
                XMLHTTP.Open "Get", Replace(href, "\", "/"), "False"
                XMLHTTP.send
                If XMLHTTP.statustext = "OK" Then
                   проверка_INN = Dekoder(XMLHTTP.responseText)

                End If
            End If
            
    
        End If

    End If
    Set XMLHTTP = Nothing
End Function



Private Function Get_Href(S, ByVal INN) As String
    S = Replace(S, " ", "")
    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True

    RegExp.Pattern = "url:""/extranet/include/demands.php(.+?)"","

    bRes = RegExp.test(S)
    If bRes Then
        Set oMatches = RegExp.Execute(S)
        Get_Href = "http://bg.vkb-bank.ru/extranet/include/demands.php" & oMatches(0).subMatches(0) & _
                   "&ELEMENT_ID=0&VAL=" & INN & "&type=2"

    End If
End Function

Private Function Dekoder(S) As String

    bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True

    RegExp.Pattern = "u([0-9abcdef]+)"

    bRes = RegExp.test(S)
    If bRes Then
        Set oMatches = RegExp.Execute(S)
        
        For n = 0 To oMatches.Count - 1
        Key = oMatches(n).Value
        Key1 = CLng("&H" & oMatches(n).subMatches(0))
        S = Replace(S, Key, ChrW(Key1))
               
        Next
         S = Replace(S, "\", "")

    End If
    Dekoder = S
    
End Function



Attribute VB_Name = "Новый"
Const пароль As String = "gthdsqujc"
Const Логин As String = "gostendery"
Public Const sCnSql As String = "Provider=SQLOLEDB.1;Password=AABB345AA;Persist SecurityInfo=True;" & _
"User ID=Manager;Initial Catalog=Клиенты;Data Source=SERVER\SQLEXPRESS"

Public Sub auto_open()
МногоМакросов
End Sub

Sub МногоМакросов()
Call Вперед2
Call ЗАКРЕПЛЕНИЕ
Call Выход

End Sub



Public Function Начальнаямаксимальнаяценаконтракта(S) As Double

S = Replace(S, Chr(9), "")
S = Replace(S, Chr(10), "")
S = Replace(S, Chr(13), "")
S = Replace(S, Chr(160), "")
S = Replace(S, "&nbsp;", "")
S = Replace(S, " ", "")
S = Replace(S, " ", "")
S = Replace(S, " ", "")

Dim cn As Double
   bRes = False
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Global = True
    RegExp.IgnoreCase = True
     RegExp.Pattern = ">Начальная\(максимальная\)ценаконтракта</td><td>([0-9,]+)</td>"
    bRes = RegExp.test(S)
    If bRes Then
   Set oMatches = RegExp.Execute(S)
 Начальнаямаксимальнаяценаконтракта = oMatches(n).subMatches(0)
 End If
End Function


Sub Вперед()
Application.ScreenUpdating = False
    Dim Item() As ItemI, Sh As Worksheet, Shi As Worksheet, wb As Workbook
    Dim pr As ProgressIndicator, Rez()

    Dim sCon As String, sSql As String, t As Single

    Dim cn As Object
    Set cn = CreateObject("ADODB.Connection")    'Для позднего связывания
    sCon = sCnSql
     cn.Open sCon


    Set Sh = ThisWorkbook.Worksheets("ZK")
    Sh.UsedRange.ClearContents
    Set Shi = ThisWorkbook.Worksheets("Inet")
    Shi.UsedRange.ClearContents

    lLastRow = 2
    lLastRowMY = 2

    Dim a As Collection
    'Item(0).
    'Item(0).
    'Item(0).
    'Item(0).
    'Item(0).

    Sh.Cells(1, 1) = "purchaseNumber"
    Sh.Cells(1, 2) = "protocolDate"
    Sh.Cells(1, 3) = "customer"
    Sh.Cells(1, 4) = "lotNumber"
    Sh.Cells(1, 5) = "Предмет контракта"
    Sh.Cells(1, 6) = "maxPrice"
    Sh.Cells(1, 7) = "organizationName"
    Sh.Cells(1, 8) = "postAddress"
    Sh.Cells(1, 9) = "offer"
    Sh.Cells(1, 10) = "inn"
    Sh.Cells(1, 11) = "kpp"
    Sh.Cells(1, 12) = "Телефон"
    Sh.Cells(1, 13) = "email"
    Sh.Cells(1, 14) = "Обеспечение"

    Shi.Cells(1, 1) = "purchaseNumber"
    Shi.Cells(1, 2) = "protocolDate"
    Shi.Cells(1, 3) = "customer"
    Shi.Cells(1, 4) = "lotNumber"
    Shi.Cells(1, 5) = "Предмет контракта"
    Shi.Cells(1, 6) = "maxPrice"
    Shi.Cells(1, 7) = "organizationName"
    Shi.Cells(1, 8) = "postAddress"
    Shi.Cells(1, 9) = "offer"
    Shi.Cells(1, 10) = "inn"
    Shi.Cells(1, 11) = "kpp"
    Shi.Cells(1, 12) = "Телефон"
    Shi.Cells(1, 13) = "email"
    Shi.Cells(1, 14) = "Обеспечение"




    Dim col As Collection
    Set col = New Collection
    Dim folders As String
    ''folders = "F:\Documents and Settings\Сергей\Рабочий стол\Кличко\NEW_protokol"
    folders = "D:\Zakupki_new\TempFile\"
    
 

    Set pr = New ProgressIndicator
    pr.SetFocus

    Set a = Get_Item(folders)
    For n1 = 1 To a.Count
        pr.Set_ProgressBar 100 * n1 / a.Count
        Item = Read_Новый(a(n1))

        For n = 1 To UBound(Item)



' вставляет в лист ZK
'            If Item(n).href = "" And Item(n).maxPrice = 0 Then
        
            
            Обеспечение_контракта = 0
            PubFun = Get_konturruInfo(Item(n).purchaseNumber, Item(n).lotObjectInfo, Item(n).maxPrice, Обеспечение_контракта)
                                              
             Item(n).Обеспечение = Обеспечение_контракта
                Sh.Cells(lLastRowMY, 1) = "'" & Item(n).purchaseNumber
                Sh.Cells(lLastRowMY, 2) = Item(n).protocolDate
                Sh.Cells(lLastRowMY, 3) = Item(n).customer
                Sh.Cells(lLastRowMY, 4) = Item(n).lotNumber
                Sh.Cells(lLastRowMY, 5) = Item(n).Обеспечение
                Sh.Cells(lLastRowMY, 6) = Item(n).maxPrice
                Sh.Cells(lLastRowMY, 7) = Item(n).organizationName
                Sh.Cells(lLastRowMY, 8) = Item(n).postAddress
                Sh.Cells(lLastRowMY, 9) = Item(n).offer
                Sh.Cells(lLastRowMY, 10) = "'" & Item(n).INN
                Sh.Cells(lLastRowMY, 11) = "'" & Item(n).kpp
                Sh.Cells(lLastRowMY, 14) = Item(n).Обеспечение
                
                
                

                On Error Resume Next
                If Item(n).INN <> "" Then
                    sSql = "[dbo].Get_INN '" & Item(n).INN & "'"

                    If Get_Exec(sSql, cn, Rez) Then
                        Sh.Cells(lLastRowMY, 12) = Rez(0, 0)
                        Sh.Cells(lLastRowMY, 13) = Rez(1, 0)
                        Err.Clear
                    End If
                End If
                lLastRowMY = lLastRowMY + 1
        Next




    Next
    cn.Close
    Set cn = Nothing
    Set pr = Nothing
    Fpath = "D:\Zakupki_new\Вывод\Результат1_" & Format(Now, "dd_MM_HH_mm") & ".xlsx"

    Sh.Copy

    Set wb = ActiveWorkbook

    Форматирование wb.Worksheets(1)
    Application.DisplayAlerts = False
    wb.SaveAs FileName:=Fpath, FileFormat:=xlOpenXMLWorkbook
    wb.Close (False)
    Application.DisplayAlerts = True

    Get_Inet
End Sub
Sub Форматирование(ByRef Sh As Worksheet)
' Форматирование Макрос
'
Application.ScreenUpdating = False
'
Sh.Activate
Sh.Select
    Sh.Rows("1:1").Select
    Selection.AutoFilter
    Sh.AutoFilter.Sort.SortFields.Clear
    Sh.AutoFilter.Sort.SortFields.Add Key:=Range( _
        "N1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With Sh.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sh.Columns("B:B").ColumnWidth = 11.14
    Sh.Columns("D:D").ColumnWidth = 5
    Sh.Columns("E:E").ColumnWidth = 27
    Sh.Columns("F:F").ColumnWidth = 18
    Sh.Columns("F:F").Select
    Selection.NumberFormat = "#,##0.00_р_."
    Selection.Font.Bold = True
    Selection.Font.Italic = True
    Sh.Columns("G:G").ColumnWidth = 27
    Sh.Columns("K:K").ColumnWidth = 0.08
    Sh.Columns("H:H").ColumnWidth = 0.08
    Sh.Columns("I:I").ColumnWidth = 0.08
    Sh.Columns("J:J").ColumnWidth = 12.57
    Sh.Columns("N:N").ColumnWidth = 20
    Sh.Columns("N:N").Select
    Selection.NumberFormat = "#,##0.00_р_."
    Selection.Font.Bold = True
    Selection.Font.Italic = True
    Sh.Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
      Sh.Range("A1") = "ЮЗЕРС"
    lLastRowMY = Sh.Cells(Sh.Rows.Count, 2).End(xlUp).Row
    
    Смагина = Array("", "Смагина", "Карташова", "Герасимова")
    Шаг = UBound(Смагина)
    
    If lLastRowMY = 1 Then Exit Sub
    
   ReDim Карташова(1 To lLastRowMY - 1, 1 To 1)
   t = 0
   For n = 2 To lLastRowMY
t = t + 1
If t > Шаг Then t = 1
 Карташова(n - 1, 1) = Смагина(t)
   
   Next
   Sh.Range("A2").Resize(lLastRowMY - 1, 1) = Карташова
  Sh.Rows("1:1").Select
    Selection.AutoFilter
      Sh.Rows("1:1").Select
    Selection.AutoFilter
    Sh.Range("A1").Select
    Sh.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    
   
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
…