Malicious Office (OLE) — 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
Private Sub Workbook_Open()

End Sub

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 = "Module1"
Option Explicit
Public gpaNastrForm As Variant, gpRowNastr As Integer, gpColNastr As Integer
Const cVer = "2.0", colKodForm = "A", colLeftF = "C", colRightF = "D", colResultF = "E", colFormulaHum = "B", _
        xFORMA = 1, yFORMA = 1, xAtr = 4, xTable = 7, yTable = 1, xCol = 15, yCol = 1, xyFormatHead = "B29", xyFormatCell = "AM1", xForeColor = 38, xBackColor = 39
        
        
#If VBA7 And Win64 Then
    Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
    ByVal hInternetSession As Long, ByVal sServerName As String, _
    ByVal nServerPort As Integer, ByVal sUsername As String, _
    ByVal sPassword As String, ByVal lService As Long, _
    ByVal lFlags As Long, ByVal lContext As Long) As Long
    
    Declare PtrSafe Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
    ByVal sAgent As String, ByVal lAccessType As Long, _
    ByVal sProxyName As String, _
    ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
    
    Public Declare PtrSafe Function HttpOpenRequest Lib "wininet.dll" Alias _
          "HttpOpenRequestA" (ByVal hHttpSession As Long, ByVal sVerb As _
          String, ByVal sObjectName As String, ByVal sVersion As String, _
          ByVal sReferer As String, ByVal something As Long, ByVal lFlags _
          As Long, ByVal lContext As Long) As Long
    Public Const INTERNET_FLAG_RELOAD = &H80000000
    
    Public Declare PtrSafe Function HttpAddRequestHeaders Lib "wininet.dll" Alias _
          "HttpAddRequestHeadersA" (ByVal hHttpRequest As Long, _
          ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal _
          lModifiers As Long) As Integer
    Public Const HTTP_ADDREQ_FLAG_ADD_IF_NEW = &H10000000
    Public Const HTTP_ADDREQ_FLAG_ADD = &H20000000
    Public Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000
    
    Public Declare PtrSafe Function HttpSendRequest Lib "wininet.dll" Alias _
          "HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal sHeaders _
          As String, ByVal lHeadersLength As Long, sOptional As String, _
          ByVal lOptionalLength As Long) As Integer
          
    Public Declare PtrSafe Function HttpQueryInfo Lib "wininet.dll" _
       Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, _
       ByVal lInfoLevel As Long, ByRef sBuffer As Any, _
       ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
    Public Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000
    
    Public Declare PtrSafe Function InternetReadFile Lib "wininet.dll" _
          (ByVal hFile As Long, ByVal sBuffer As String, _
          ByVal lNumberOfBytesToRead As Long, lNumberOfBytesRead As Long) _
          As Integer
    
    Public Declare PtrSafe Function InternetCloseHandle Lib "wininet.dll" _
       (ByVal hInet As Long) As Integer
       
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
    ByVal hInternetSession As Long, ByVal sServerName As String, _
    ByVal nServerPort As Integer, ByVal sUsername As String, _
    ByVal sPassword As String, ByVal lService As Long, _
    ByVal lFlags As Long, ByVal lContext As Long) As Long
    
    Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
    ByVal sAgent As String, ByVal lAccessType As Long, _
    ByVal sProxyName As String, _
    ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
    
    Public Declare Function HttpOpenRequest Lib "wininet.dll" Alias _
          "HttpOpenRequestA" (ByVal hHttpSession As Long, ByVal sVerb As _
          String, ByVal sObjectName As String, ByVal sVersion As String, _
          ByVal sReferer As String, ByVal something As Long, ByVal lFlags _
          As Long, ByVal lContext As Long) As Long
    Public Const INTERNET_FLAG_RELOAD = &H80000000
    
    Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" Alias _
          "HttpAddRequestHeadersA" (ByVal hHttpRequest As Long, _
          ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal _
          lModifiers As Long) As Integer
    Public Const HTTP_ADDREQ_FLAG_ADD_IF_NEW = &H10000000
    Public Const HTTP_ADDREQ_FLAG_ADD = &H20000000
    Public Const HTTP_ADDREQ_FLAG_REPLACE = &H80000000
    
    Public Declare Function HttpSendRequest Lib "wininet.dll" Alias _
          "HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal sHeaders _
          As String, ByVal lHeadersLength As Long, sOptional As String, _
          ByVal lOptionalLength As Long) As Integer
          
    Public Declare Function HttpQueryInfo Lib "wininet.dll" _
       Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, _
       ByVal lInfoLevel As Long, ByRef sBuffer As Any, _
       ByRef lBufferLength As Long, ByRef lIndex As Long) As Integer
    Public Const HTTP_QUERY_FLAG_REQUEST_HEADERS = &H80000000
    
    Public Declare Function InternetReadFile Lib "wininet.dll" _
          (ByVal hFile As Long, ByVal sBuffer As String, _
          ByVal lNumberOfBytesToRead As Long, lNumberOfBytesRead As Long) _
          As Integer
    
    Public Declare Function InternetCloseHandle Lib "wininet.dll" _
       (ByVal hInet As Long) As Integer
       
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If


Private m_intDecTab(255) As Integer
Private Const m_strEncTabConst As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

Public Function EncodeStr64(ByRef strInput As String) As String
  Dim i As Long
  Dim j As Integer
  Dim lngLen As Long
  Dim lngQuants As Long
  Dim intIndex As Long
  Dim strOutput As String
  Dim strLast As String
  Dim b(2) As Byte
  
  lngLen = Len(strInput)
  lngQuants = lngLen \ 3
  strOutput = String(lngQuants * 4, " ")

  For i = 0 To lngQuants - vbNull
    For j = 0 To 2
        b(j) = VBA.Asc(VBA.Mid$(strInput, (i * 3) + j + vbNull, vbNull))
    Next

    Mid(strOutput, intIndex + vbNull, 4) = EncodeQuantum(b)
    intIndex = intIndex + 4
  Next

  Select Case lngLen Mod 3
    Case 0
      strLast = vbNullString

    Case 1
      b(0) = VBA.Asc(VBA.Mid$(strInput, lngLen, vbNull))
      b(1) = 0&
      b(2) = 0&
      strLast = EncodeQuantum(b)
      strLast = VBA.Left$(strLast, 2) & "=="

    Case 2
      b(0) = VBA.Asc(VBA.Mid$(strInput, lngLen - vbNull, vbNull))
      b(1) = VBA.Asc(VBA.Mid$(strInput, lngLen, vbNull))
      b(2) = 0&
      strLast = EncodeQuantum(b)
      strLast = VBA.Left(strLast, 3) & "="
      
  End Select

  EncodeStr64 = strOutput & strLast
  
End Function




Public Function DecodeStr64(ByRef strEncoded As String) As String
  Dim d(3)        As Byte
  Dim c           As Byte
  Dim di          As Integer
  Dim i           As Long
  Dim lngLen        As Long
  Dim intIndex      As Long
  
  lngLen = Len(strEncoded)
  DecodeStr64 = String((lngLen \ 4) * 3, " ")
  Call MakeDecTab
  
  For i = vbNull To Len(strEncoded)
    c = VBA.CByte(VBA.Asc(VBA.Mid$(strEncoded, i, vbNull)))
    c = m_intDecTab(c)
  
    If c >= 0& Then
      d(di) = c
      di = di + vbNull

      If di = 4 Then
        Mid$(DecodeStr64, intIndex + vbNull, 3) = DecodeQuantum(d)
        intIndex = intIndex + 3

        If d(3) = 64 Then
          DecodeStr64 = VBA.Left(DecodeStr64, VBA.Len(DecodeStr64) - vbNull)
          intIndex = intIndex - vbNull
            
        End If

        If d(2) = 64 Then
          DecodeStr64 = VBA.Left(DecodeStr64, VBA.Len(DecodeStr64) - vbNull)
          intIndex = intIndex - vbNull
            
        End If
        
        di = 0&
          
      End If
      
    End If
    
  Next
  
End Function




Private Function EncodeQuantum(ByRef b() As Byte) As String
  Dim c As Integer

  c = SHR2(b(0)) And &H3F
  EncodeQuantum = EncodeQuantum & VBA.Mid$(m_strEncTabConst, c + vbNull, vbNull)

  c = SHL4(b(0) And &H3) Or (SHR4(b(1)) And &HF)
  EncodeQuantum = EncodeQuantum & VBA.Mid$(m_strEncTabConst, c + vbNull, vbNull)

  c = SHL2(b(1) And &HF) Or (SHR6(b(2)) And &H3)
  EncodeQuantum = EncodeQuantum & VBA.Mid$(m_strEncTabConst, c + vbNull, vbNull)

  c = b(2) And &H3F
  EncodeQuantum = EncodeQuantum & VBA.Mid$(m_strEncTabConst, c + vbNull, vbNull)
  
End Function




Private Function DecodeQuantum(ByRef d() As Byte) As String
  Dim c As Long

  c = SHL2(d(0)) Or (SHR4(d(1)) And &H3)
  DecodeQuantum = DecodeQuantum & VBA.Chr$(c)

  c = SHL4(d(1) And &HF) Or (SHR2(d(2)) And &HF)
  DecodeQuantum = DecodeQuantum & VBA.Chr$(c)

  c = SHL6(d(2) And &H3) Or d(3)
  DecodeQuantum = DecodeQuantum & VBA.Chr$(c)
    
End Function




Private Function MakeDecTab()
  Dim t As Integer
  Dim c As Integer

  For c = 0 To 255
    m_intDecTab(c) = &HFFF
  Next
  
  For c = VBA.Asc("A") To VBA.Asc("Z")
    m_intDecTab(c) = t
    t = t + vbNull
  Next
  
  For c = VBA.Asc("a") To VBA.Asc("z")
    m_intDecTab(c) = t
    t = t + vbNull
  Next
  
  For c = VBA.Asc("0") To VBA.Asc("9")
    m_intDecTab(c) = t
    t = t + vbNull
  Next


  c = Asc("+")
  m_intDecTab(c) = t
  t = t + vbNull

  c = Asc("/")
  m_intDecTab(c) = t
  t = t + vbNull
  
  c = Asc("=")
  m_intDecTab(c) = t
  
End Function




Private Function SHL2(ByVal bytValue As Byte) As Byte
    SHL2 = (bytValue * &H4) And &HFF
End Function

Private Function SHL4(ByVal bytValue As Byte) As Byte
    SHL4 = (bytValue * &H10) And &HFF
End Function

Private Function SHL6(ByVal bytValue As Byte) As Byte
    SHL6 = (bytValue * &H40) And &HFF
End Function

Private Function SHR2(ByVal bytValue As Byte) As Byte
    SHR2 = bytValue \ &H4
End Function

Private Function SHR4(ByVal bytValue As Byte) As Byte
    SHR4 = bytValue \ &H10
End Function

Private Function SHR6(ByVal bytValue As Byte) As Byte
    SHR6 = bytValue \ &H40

End Function
   
   Function URLEncode(strData)
 Dim i, c, ln: ln = Len(strData)
 For i = 1 To ln
   c = Asc(Mid(strData, i, 1))
   If c = 32 Then
      URLEncode = URLEncode & "+"
   ElseIf (c >= 48 And c <= 57) Or (c >= 65 And c <= 90) Or (c >= 97 And c <= 122) Or c = 61 Or c = 38 Then
      URLEncode = URLEncode & Chr(c)
   Else
      c = Hex(c): If Len(c) < 2 Then c = "0" & c
      URLEncode = URLEncode & "%" & c
   End If
 Next
End Function

Private Sub Send_Report()
Dim hInternet As Long, hSession As Long, hINetSession As Long, req As String, hFile As Long, iRes As Long
Dim bDoLoop As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim sBuffer As String, postData As String, oServerXMLHTTP As Variant

    postData = "nii" + Chr(13) + "" + Chr(13) + "0" + Chr(13) + "строка1" + Chr(13) + "строка2"
    Set oServerXMLHTTP = CreateObject("Msxml2.ServerXMLHTTP")
    With oServerXMLHTTP
        '.Open "POST", "http://belov/sw/FormReciveData.aspx", False
        '.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        '.send URLEncode(postData)
        'send "" + (postData)
        .Open "POST", "http://belov/sw/FormReciveData.aspx", False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=windows-1251"
        .send postData + ""
    End With
    
'    hINetSession = InternetOpen("Excel - Client", 0, vbNullString, vbNullString, 0)
'    hSession = InternetConnect(hINetSession, "belov", 80, "", "", 3, 0, 0)
'    hFile = HttpOpenRequest(hSession, "POST", "/sw/FormReciveData.aspx", vbNullString, vbNullString, 0, INTERNET_FLAG_RELOAD, 0)
'    iRes = HttpAddRequestHeaders(hFile, req, Len(req), HTTP_ADDREQ_FLAG_ADD)
'    req = "Connection: Keep-Alive"
'    iRes = HttpAddRequestHeaders(hFile, req, Len(req), HTTP_ADDREQ_FLAG_ADD)

'    postData = "name=nii" + Chr(13) + "pass=" + Chr(13) + "DATA=строка1" + Chr(13) + "строка2"
'    iRes = HttpSendRequest(hFile, vbNullString, 0, (postData), Len(postData))
    
'    bDoLoop = True
'    While bDoLoop
'    sReadBuffer = vbNullString
'    bDoLoop = InternetReadFile(hFile, sReadBuffer, Len(sReadBuffer), lNumberOfBytesRead)
'    sBuffer = sBuffer & Left$(sReadBuffer, lNumberOfBytesRead)
    
'    If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
'    Wend
    
'    InternetCloseHandle (hFile)
'    InternetCloseHandle (hSession)
'    InternetCloseHandle (hINetSession)
    MsgBox (oServerXMLHTTP.Status)
    iRes = MsgBox(oServerXMLHTTP.ResponseText)
End Sub

        
Function LastCell(r As Range) As Range
Dim rLast As Range
    Set rLast = r.Cells.SpecialCells(xlLastCell)
    If rLast.Cells(1, 1).Value = "" Then
        On Error Resume Next
        Set LastCell = r.Parent.Cells(r.Parent.Cells.Find("*", rLast, , , xlByRows, xlPrevious).Row, r.Parent.Cells.Find("*", rLast, , , xlByColumns, xlPrevious).Column)
        If Err.Number <> 0 Then Set LastCell = r.Parent.Cells(1, 1)
        On Error GoTo 0
    Else
        Set LastCell = rLast
    End If
    Set rLast = Nothing
End Function


Function getLastRow(cSheet As String, cCol As Integer) As Integer
    Dim iRow As Integer
    Const iMaxRow = 65536
    'getLastRow = Columns(ccol).Rows(65536).End(xlUp).Row
      With Worksheets(cSheet).Cells(iMaxRow, cCol)
     If IsEmpty(.Value) = True Then
        iRow = .End(xlUp).Row
     Else
        iRow = iMaxRow
     End If
     getLastRow = iRow
End With
End Function

Function GetWordNum(st As String, index As Long, cdecim As String) As String
    Dim i As Long, cnt As Long, ipos As Long, ibegin As Long, iend As Long
    i = 1
    cnt = 0
    ibegin = 0
    iend = 0
    ipos = InStr(i, st, cdecim)
    While ipos > 0 And cnt <= index + 1
        ipos = InStr(i, st, cdecim)
        If ipos > 0 Then
        If ipos > 0 Then cnt = cnt + 1
        If cnt = index - 1 Then ibegin = ipos + Len(cdecim)
        If (index = 1 And cnt = 1) Then ibegin = 1
        If cnt = index Then iend = ipos
        End If
        i = ipos + 1
    Wend
    GetWordNum = ""
    If ipos = 0 And cnt = 0 And index = 1 Then GetWordNum = st
    If ibegin > 0 Then
       If iend = 0 Then iend = Len(st) + 1
       GetWordNum = Mid(st, ibegin, iend - ibegin)
    End If
End Function

Function GetWordCount(st As String, cdecim As String) As Long
    Dim i As Long, cnt As Long, ipos As Long, ibegin As Long, iend As Long
    i = 1
    cnt = 0
    ibegin = 0
    iend = 0
    ipos = InStr(i, st, cdecim)
    While ipos > 0
        ipos = InStr(i, st, cdecim)
        If ipos > 0 Then
        If ipos > 0 Then cnt = cnt + 1
        End If
        i = ipos + 1
     Wend
     GetWordCount = cnt + 1
End Function
Private Sub Make_Report_run(cPath As String, cWeb As String, cUser As String)
                
        Make_Report (cPath)
        
        Worksheets("System").Cells(22, 3).Value = GetWordNum(cUser, 2, "#")
        Worksheets("System").Cells(23, 3).Value = GetWordNum(cUser, 3, "#")
        Worksheets("System").Cells(16, 2).Value = GetWordNum(cUser, 1, "#")
        Worksheets("System").Cells(17, 2).Value = cWeb
        
        Form_SEND.MultiPage1.Value = 0
        
End Sub

Private Sub Make_Report_Svod_ks(cPath As String, cServer As String, cBase As String, cUser As String)
        Worksheets("System").Cells(16, 2).Value = cUser
        Worksheets("System").Cells(22, 2).Value = cServer
        Worksheets("System").Cells(23, 2).Value = cBase
        Make_Report (cPath)
        Form_SEND.MultiPage1.Value = 1
End Sub

Private Sub Make_Report_run1()
        Make_Report ("C:\Excel\test.txt")
End Sub


Private Sub get_weeks(iYear As Integer)
        Dim iMaxWeek As Integer, i As Integer
        iMaxWeek = Format(CDate("31.12." + Str(iYear)), "ww")
        'заполняем system
        For i = 1 To iMaxWeek
          Worksheets("System").Cells(49 + i, 1).Value = Trim(Str(i)) + " (" + Left(CStr(DateSerial(iYear, 1, 1) + (i - 1) * 7), 5) + "-" + Left(CStr(DateSerial(iYear, 1, 1) + i * 7 - 1), 5) + ")"
          Worksheets("System").Cells(49 + i, 2).Value = i
        Next
        Worksheets("Реквизиты").Cmb_W.ListFillRange = "System!A50:B" + Trim(Str(50 + iMaxWeek - 1))
        
End Sub



Private Sub Make_Report(FileName As String)

    Dim hFile As Long, cFileName As String, TextLine As String, _
     lHeader As Integer, cVersion As String, lcError As String, Response As Integer, _
     aHeader As Variant, cCode_Form As String, lcBegin As String, lcEnd As String, cDate_Form As String, _
     cDep_Code As String, cOrg_Name As String, cBUDG As String, cBUDG_NAME As String, _
     liCountTable As Integer, cCount_Table As String, liCountCol As Integer, i As Integer, liCol As Integer, _
     lcVal_Len As String, lcRow As String, iRow As Integer, li As Long, aCols As Variant, iCols As Integer, _
     lcExport_order As String, cNAME_Form As String, max_row As Integer, rgb_value As String, code_col As Integer, _
     code As String, find_range As Range, Property_col As String, liCountAtr As Integer, iSetting As Integer, _
     iForeColor As Double, iBackColor As Double, iTypeCol As Integer, iCodeCol As Integer, iISEdit As Integer
   
     
    Close #1
    On Error Resume Next
        Application.DisplayAlerts = False
    cFileName = FileName
        If Dir(cFileName) <> "" Then
            ' Открываем файл для последовательного доступа.
        Open cFileName For Input Access Read As #1
        lHeader = 0
        lcError = ""
        liCountTable = 0
        liCountCol = 0
        liCol = 1
        liCountAtr = 0
        Property_col = "0"
        Worksheets("System").Range("C2:Z1000").Value = ""
        Worksheets("System").Range("B2:B15").Value = ""
        Worksheets("System").Range("D2:D15").Value = ""
        Worksheets("Реквизиты").Unprotect
        For i = 3 To Sheets.Count
            Sheets(3).Delete
        Next
        
        'Worksheets("Реквизиты").cell(24, 1).EntireRow.Delete
        'Worksheets("Реквизиты").cell(24, 1).EntireRow.Delete
        
        
        Do While Not EOF(1)    ' Loop until end of file.
          Line Input #1, TextLine    ' Read line into variable.
          'проверяем версию файла
          'читаем заголовок
          If Trim(TextLine) = "PROGRAM=Excel_Client" Then
             lHeader = lHeader + 1
          End If
          If GetWordNum(TextLine, 1, "=") = "VERSION" Then
             cVersion = GetWordNum(TextLine, 2, "=")
             If cVersion = cVer Then
                lHeader = lHeader + 1
             Else
                lcError = "Неверная версия: " + cVersion + ". Ожидается версия: " + cVer
             End If
          End If
                      
          'если заголовок прочитан и он верный
          If lHeader = 2 Then
              
            'начало блока
              If Left(Trim(TextLine), 1) = "[" Then
                lcBegin = Trim(TextLine)
                lcEnd = ""
              End If
              
            'конец блока
              If Trim(TextLine) = "##" Then
                lcEnd = "END"
              End If
                                    
            Select Case lcBegin
              'блок описания формы
                Case "[FORM]"
                    Select Case GetWordNum(TextLine, 1, "=")
                        Case "CODE_FORM"
                          cCode_Form = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(2, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "NAME_FORM"
                          cNAME_Form = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(3, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "DATE_FORM"
                          cDate_Form = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(4, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "DEP_CODE"
                          cDep_Code = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(5, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "ORG_NAME"
                          cOrg_Name = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(6, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "BUDG"
                          cBUDG = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(7, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "BUDG_NAME"
                          cBUDG_NAME = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(8, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "BEGIN_DATE"
                          Worksheets("System").Cells(12, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "PERIOD_TYPE"
                          Worksheets("System").Cells(13, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "VERSION_FORM"
                          Worksheets("System").Cells(19, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "PERIOD_NUMBER"
                          Worksheets("System").Cells(14, 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                    
                    End Select
               'блок описания таблиц
                Case "[TABLE]"
                    Select Case GetWordNum(TextLine, 1, "=")
                        Case "#@"
                          liCountTable = liCountTable + 1
                          Sheets.Add After:=Worksheets(Sheets.Count)
                          Worksheets(Sheets.Count).name = "Таблица " + Str(liCountTable)
                        Case "COUNT_TABLE"
                          cCount_Table = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(yTable + 1, xTable).Value = "COUNT_TABLE"
                          Worksheets("System").Cells(yTable + 1, xTable + 1).Value = cCount_Table
                        Case "ORDER"
                          Worksheets("System").Cells(yTable + liCountTable, xTable + 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "NAME"
                          Worksheets("System").Cells(yTable + liCountTable, xTable + 3).Value = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets(liCountTable + 2).Cells(1, 1).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "COUNT_COL"
                          Worksheets("System").Cells(yTable + liCountTable, xTable + 4).Value = Trim(GetWordNum(TextLine, 2, "="))
                        'Case "VAL_TYPE"
                        '  Worksheets("System").Cells(yTable + liCountTable, xTable + 6).Value = Trim(GetWordNum(TextLine, 2, "="))
                        'Case "CODE_COL"
                        '  Worksheets("System").Cells(yTable + liCountTable, xTable + 5).Value = Trim(GetWordNum(TextLine, 2, "="))
                          
                          With Worksheets(Worksheets("System").Cells(yTable + liCountTable, xTable + 2).Value + 2)
                            .Range(Cells(5, 1), Cells(5, 1)).Select
                            .Activate
                            ActiveWindow.FreezePanes = True
                          End With
                    End Select
               'блок описания колонок
                Case "[COLS]"
                    Select Case GetWordNum(TextLine, 1, "=")
                        Case "##"
                          liCountCol = liCountCol + 1
                        Case "#@"
                          liCountCol = liCountCol + 1
                        Case "TABLE"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 2).Value = Trim(GetWordNum(TextLine, 2, "="))
                          liCountTable = Val(Trim(GetWordNum(TextLine, 2, "=")))
                        Case "ORDER"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 3).Value = Trim(GetWordNum(TextLine, 2, "="))
                          liCol = Trim(GetWordNum(TextLine, 2, "="))
                        Case "NAME"
                          'Worksheets("System").Range(xyFormatHead).Copy Worksheets(liCountTable + 2).Cells(3, liCol)
                          'Worksheets("System").Range(xyFormatHead).Copy Worksheets(liCountTable + 2).Cells(4, liCol)
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 4).Value = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets(liCountTable + 2).Cells(3, liCol).Value = Trim(GetWordNum(TextLine, 2, "="))
                          'установка ширины колонки
                        Case "INPUT_MASK"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 5).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "EDIT"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 6).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "LENGTH"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 7).Value = Trim(GetWordNum(TextLine, 2, "="))
                          lcVal_Len = Trim(GetWordNum(TextLine, 2, "="))
                        Case "TYPE_DATA"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 8).Value = Trim(GetWordNum(TextLine, 2, "="))
                          If Trim(GetWordNum(TextLine, 2, "=")) = "0" Then
                            Worksheets(liCountTable + 2).Columns(liCol).ColumnWidth = 20
                            Worksheets(liCountTable + 2).Columns(liCol).NumberFormat = "0.00"
                            If Val(lcVal_Len) > 0 Then
                                Worksheets(liCountTable + 2).Columns(liCol).NumberFormat = "0." + Application.WorksheetFunction.Rept("0", Val(lcVal_Len))
                            Else
                                Worksheets(liCountTable + 2).Columns(liCol).NumberFormat = "0"
                            End If
                          End If
                          'If Trim(GetWordNum(TextLine, 2, "=")) = "1" Then
                          '  Worksheets(liCountTable + 2).Columns(liCol).HorizontalAlignment = xlGeneral
                          'End If
                           'проставим ширину колонок
                          If Trim(GetWordNum(TextLine, 2, "=")) = "1" Then
                            If Val(lcVal_Len) > 250 Then
                                    Worksheets(liCountTable + 2).Columns(liCol).NumberFormat = "General"
                            Else
                                    Worksheets(liCountTable + 2).Columns(liCol).NumberFormat = "@"
                            End If
                            If lcVal_Len <> "0" And lcVal_Len <> "" Then
                                If Val(lcVal_Len) > 50 Then
                                    lcVal_Len = "50"
                                End If
                                If Val(lcVal_Len) < 6 Then
                                    lcVal_Len = "6"
                                End If
                                Worksheets(liCountTable + 2).Columns(liCol).ColumnWidth = Val(lcVal_Len)
                            Else
                                Worksheets(liCountTable + 2).Columns(liCol).ColumnWidth = 20
                            End If
                          End If
                                Worksheets(liCountTable + 2).Rows(3).AutoFit
                          Worksheets(liCountTable + 2).Rows(4).NumberFormat = "@"
                             
                        Case "ORDER_VISIBLE"
                          lcExport_order = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 9).Value = lcExport_order
                          If lcExport_order <> "0" Then
                            Worksheets(liCountTable + 2).Cells(4, liCol).Value = lcExport_order
                            Worksheets(liCountTable + 2).Cells(4, liCol).HorizontalAlignment = xlCenter
                          End If
                        Case "HIDDEN"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 10).Value = Trim(GetWordNum(TextLine, 2, "="))
                          Property_col = Trim(GetWordNum(TextLine, 2, "="))
                          If Property_col = "1" Then
                                Worksheets(liCountTable + 2).Columns(liCol).ColumnWidth = 0
                                Worksheets(liCountTable + 2).Columns(liCol).HorizontalAlignment = xlGeneral
                                Worksheets(liCountTable + 2).Columns(liCol).ShrinkToFit = True
                          End If
                        Case "IS_CODE_COL"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 11).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "TYPE_COL"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 12).Value = Trim(GetWordNum(TextLine, 2, "="))
                        Case "IS_EDIT"
                          Worksheets("System").Cells(yCol + liCountCol, xCol + 13).Value = Trim(GetWordNum(TextLine, 2, "="))
                    
                    End Select
                'Атрибуты
                Case "[ATRIBUT]"
                    Select Case GetWordNum(TextLine, 1, "=")
                    Case "[ATRIBUT]"
                          liCountAtr = 0
                          Worksheets("Реквизиты").Cells(24, 1).Value = "Атрибуты"
                    Case "#@"
                          liCountAtr = liCountAtr + 1
                          'рисуем атрибут начиная с ячейки С
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Borders(xlEdgeLeft).LineStyle = xlContinuous
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Borders(xlEdgeLeft).Weight = xlMedium
                          
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Borders(xlEdgeTop).LineStyle = xlContinuous
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Borders(xlEdgeTop).Weight = xlMedium
                
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Borders(xlEdgeBottom).LineStyle = xlContinuous
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Borders(xlEdgeBottom).Weight = xlMedium
                
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Borders(xlEdgeRight).LineStyle = xlContinuous
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Borders(xlEdgeRight).Weight = xlMedium
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Interior.ColorIndex = 15
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Interior.Pattern = xlSolid
                          
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Borders(xlEdgeLeft).LineStyle = xlContinuous
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Borders(xlEdgeLeft).Weight = xlMedium
                          
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Borders(xlEdgeTop).LineStyle = xlContinuous
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Borders(xlEdgeTop).Weight = xlMedium
                
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Borders(xlEdgeBottom).LineStyle = xlContinuous
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Borders(xlEdgeBottom).Weight = xlMedium
                
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Borders(xlEdgeRight).LineStyle = xlContinuous
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Borders(xlEdgeRight).Weight = xlMedium
                    Case "CODE_ATR"
                          Worksheets("System").Cells(1 + liCountAtr, 4).Value = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("System").Cells(1 + liCountAtr, 5).Value = liCountAtr
                    Case "NAME_ATR"
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr).Value = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("Реквизиты").Cells(24, 2 + liCountAtr + 1).Value = " "
                    Case "STR_VAL"
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).NumberFormat = "@"
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Value = Trim(GetWordNum(TextLine, 2, "="))
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr + 1).Value = " "
                          Worksheets("Реквизиты").Cells(25, 2 + liCountAtr).Locked = False
                          'Worksheets("Реквизиты").Rows(2 + liCountAtr).AutoFit
                End Select
                Case "[SETTING]"
                          If TextLine <> "[SETTING]" Then
                            iSetting = Val(GetWordNum(TextLine, 1, "="))
                            lcRow = GetWordNum(TextLine, 2, "=")
                            Worksheets("System").Cells(1 + iSetting, xForeColor).Value = Trim(GetWordNum(lcRow, 1, "#"))
                            Worksheets("System").Cells(1 + iSetting, xBackColor).Value = Trim(GetWordNum(lcRow, 2, "#"))
                          End If
                'данные
                Case "[DATA]"
                    Select Case GetWordNum(TextLine, 1, "=")
                        Case "[DATA]"
                          liCountTable = 0
                          iRow = 0
                        Case "#@"
                          liCountCol = Worksheets("System").Cells(yTable + liCountTable, xTable + 4).Value
                          If iRow <> 0 And liCountTable <> 0 Then
                           li = SetFormatCells(iRow + 5, liCountCol, liCountTable + 2)
                          End If
                          If liCountTable <> 0 Then
                           'раскрасим столбцы
                           'Боковичные
                           'пройдемся по столбцам
                            If liCountTable > 1 Then
                                    iCols = iCols + Worksheets("System").Cells(yTable + liCountTable - 1, xTable + 4).Value
                            Else
                                    iCols = 0
                            End If
                           
                           For li = 1 To liCountCol
                                iCodeCol = Worksheets("System").Cells(yCol + li + iCols, xCol + 11).Value
                                iTypeCol = Worksheets("System").Cells(yCol + li + iCols, xCol + 12).Value
                                iISEdit = Worksheets("System").Cells(yCol + li + iCols, xCol + 13).Value
                                Worksheets(liCountTable + 2).Activate
                                If iCodeCol = 1 Then
                                    Worksheets(liCountTable + 2).Range(Cells(4, li), Cells(4 + iRow, li)).Interior.Color = 7980795
                                End If
                                If iISEdit = 0 Then
                                    Worksheets(liCountTable + 2).Range(Cells(5, li), Cells(5 + iRow, li)).Interior.Color = 12632256
                                End If
                           Next
                           End If
                          
                          liCountTable = liCountTable + 1
                          iRow = 0
                        Case "ROW"
                           Line Input #1, TextLine    ' Read line into variable.
                           
                           Do While Left(TextLine, 7) <> "ROW_END" And Not EOF(1)
                               'Обработка строки
                               If Left(TextLine, 7) = "SETTING" Then
                                   'Проставляем цвет ячеек
                                   liCol = Val(GetWordNum(GetWordNum(TextLine, 2, "="), 1, "#"))
                                   iSetting = Val(GetWordNum(GetWordNum(TextLine, 2, "="), 2, "#"))
                                   iForeColor = Val(Worksheets("System").Cells(1 + iSetting, xForeColor).Value)
                                   iBackColor = Val(Worksheets("System").Cells(1 + iSetting, xBackColor).Value)
                                   
                                   'все колонки
                                   If liCol = 0 Then
                                      liCountCol = Worksheets("System").Cells(yTable + liCountTable, xTable + 4).Value
                                      For li = 1 To liCountCol
                                        Worksheets(liCountTable + 2).Cells(iRow + 5, li).Interior.Color = iBackColor
                                      Next
                                   Else
                                        Worksheets(liCountTable + 2).Cells(iRow + 5, liCol).Interior.Color = iBackColor
                                   End If
                                   
                               Else
                                   li = Val(Left(TextLine, 3))
                                   lcRow = Right(TextLine, Len(TextLine) - 4)
                                   If lcRow = "#ЗАПРЕТ" Then
                                    Worksheets(liCountTable + 2).Cells(iRow + 5, li).HorizontalAlignment = xlCenter
                                    Worksheets(liCountTable + 2).Cells(iRow + 5, li).Interior.Color = 12632256
                                    Worksheets(liCountTable + 2).Cells(iRow + 5, li).Value = "X"
                                   Else
                                    Worksheets(liCountTable + 2).Cells(iRow + 5, li).Value = lcRow
                                   End If
                                   Worksheets(liCountTable + 2).Cells(iRow + 5, li + 1).Value = " "
                               End If
                               Line Input #1, TextLine    ' Read line into variable.
                           
                           Loop
                           Application.StatusBar = "Подождите ...  Идет форматирование данных ... Таблица №" + Str(liCountTable) + ". Строка №" + Str(iRow)
                           iRow = iRow + 1
                        Case "SETTING_COL"
                                   'Проставляем цвет ячеек
                                   liCol = Val(GetWordNum(GetWordNum(TextLine, 2, "="), 1, "#"))
                                   iSetting = Val(GetWordNum(GetWordNum(TextLine, 2, "="), 2, "#"))
                                   iForeColor = Val(Worksheets("System").Cells(1 + iSetting, xForeColor).Value)
                                   iBackColor = Val(Worksheets("System").Cells(1 + iSetting, xBackColor).Value)
                                   
                                   'все строки
                                   For li = 0 To iRow - 1
                                     Worksheets(liCountTable + 2).Cells(li + 5, liCol).Interior.Color = iBackColor
                                   Next
                        Case "RGB"
                           If Len(TextLine) > 4 Then
                            lcRow = Right(TextLine, Len(TextLine) - 4)
                           Else
                            lcRow = ""
                           End If
                           code_col = Worksheets("System").Cells(liCountTable + 1, 12).Value
                           code = GetWordNum(lcRow, 1, "|")
                           Worksheets(liCountTable + 2).Activate
                           max_row = getLastRow("Таблица " + Str(liCountTable), code_col)
                           With Range(Cells(5, code_col), Cells(max_row, code_col))
                            Set find_range = .Find(code, LookIn:=xlValues, LookAt:=xlWhole)
                            If Not find_range Is Nothing Then
                                For li = 2 To GetWordCount(lcRow, "|")
                                    rgb_value = GetWordNum(lcRow, li, "|")
                                    Worksheets(liCountTable + 2).Cells(find_range.Row, li - 1).Interior.Color = Val(rgb_value)
                                Next
                            End If
                           End With
                    End Select
            
            End Select
          End If
          If lcError <> "" Then
            Response = MsgBox("Ошибка:" + lcError, vbInformation)
            Exit Do
          End If
        Loop
    ' Закрываем файл.
    Close #1
    
        Else
            Response = MsgBox("Файл " + cFileName + " не найден!", vbInformation)
        End If
    If iRow <> 0 And iCols <> 0 And liCountTable <> 0 Then
        li = SetFormatCells(iRow + 5, iCols, liCountTable + 2)
    End If
    'Worksheets(2).Cells(1, 1).Value = "Код отчета: " + Worksheets("System").Cells(2, 2).Value + " Наименование: " + Worksheets("System").Cells(3, 2).Value
    'проставляем периоды
      Worksheets("System").Cells(9, 2).Value = GetWordNum(Worksheets("System").Cells(12, 2).Value, 3, ".")
      Worksheets("System").Cells(10, 2).Value = 1
      Worksheets("System").Cells(11, 2).Value = 1
     Select Case Worksheets("System").Cells(13, 2).Value
         Case 1 'год
            Worksheets("Реквизиты").Opt_Y.Value = True
         Case 2 'квартал
            Worksheets("System").Cells(10, 2).Value = Worksheets("System").Cells(14, 2).Value
            Worksheets("Реквизиты").Opt_Q.Value = True
         Case 4 'месяц
            Worksheets("System").Cells(11, 2).Value = Worksheets("System").Cells(14, 2).Value
            Worksheets("Реквизиты").Opt_M.Value = True
         Case 8 'неделя
            Worksheets("Реквизиты").Opt_W.Value = True
     End Select
    get_weeks (Val(GetWordNum(Worksheets("System").Cells(12, 2).Value, 3, ".")))
     
    Worksheets("Реквизиты").Activate
    Worksheets("Реквизиты").Unprotect
    'удаляем реквизиты
    If liCountAtr = 0 Then
       Worksheets("Реквизиты").Range("C24:C25").EntireRow.Delete
    End If
    Worksheets("Реквизиты").Cells(2, 2).Formula = "Форма:" + Worksheets("System").Cells(2, 2).Value + " " + Worksheets("System").Cells(3, 2).Value
    Worksheets("Реквизиты").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Worksheets("Реквизиты").EnableSelection = xlUnlockedCells
    Application.StatusBar = ""
    'Response = MsgBox("Обновление завершено!", vbInformation)
    'проставляем форматирование у названий колонок
    
    Dim CountTable As Integer, ColCount As Integer
    CountTable = Val(Worksheets("System").Range("H2").Value)
    For li = 1 To CountTable
        ColCount = Val(Worksheets("System").Range("K" + CStr(li + 1)).Value)
        Worksheets("System").Range(xyFormatHead).Copy
        
        Worksheets(li + 2).Activate
        Worksheets(li + 2).Range(Cells(3, 1), Cells(4, ColCount)).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Next
    
    
    Worksheets("Реквизиты").Activate
    Application.DisplayAlerts = True


End Sub


Function SetFormatCells(iRow As Integer, iCols As Integer, iSheet As Integer) As Integer
    Dim x As Integer, y As Integer
    x = 5
    y = 1
    Worksheets(iSheet).Activate
'    With Range(Cells(x, y), Cells(iRow, iCols))
'        .HorizontalAlignment = xlRight
'        .VerticalAlignment = xlBottom
'        .WrapText = True
'    End With
    With Range(Cells(x, y), Cells(iRow, iCols)).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(x, y), Cells(iRow, iCols)).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(x, y), Cells(iRow, iCols)).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(x, y), Cells(iRow, iCols)).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(x, y), Cells(iRow, iCols)).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Range(Cells(x, y), Cells(iRow, iCols)).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

End Function

Function listexists(name As String) As Boolean
Dim obj As Object
On Error Resume Next
Set obj = Sheets(name)
listexists = (Err.Number = 0)
End Function

Function Get_Report(saveNull As Boolean, pNewVers As Boolean, sendCRC As Boolean, addValue As Boolean) As String
Dim max_tmp As Integer, limax As Integer, cCol As String, ctext As String, MaxRow As Integer, CountTable As Integer, ColCount As Integer, ColTable As Integer, li As Integer, lj As Integer, ColCode As Integer, lij As Integer, crow As String, a As DataObject, liAtr As Integer, yColTable As Integer, cRows As String, isNull As Boolean, cValue As String, crc As Long, onlytext As Integer, needSave As Integer
    crc = 0
    ctext = ""
…