Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "xlsBook"
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_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  
  modThisWorkbook.Workbook_BeforeSave_Handler SaveAsUI, Cancel, Me

  On Error GoTo ErrHandler

  Dim status As Integer

  status = Me.CustomDocumentProperties("Status")
  If status > 2 Then
    MsgBox "Документ подписан ЭЦП и не может быть изменен", vbExclamation + vbOKOnly, ThisWorkbook.name
    Cancel = True
    Exit Sub
  End If

  Exit Sub

ErrHandler:
  MsgBox Err.Description, vbOKOnly + vbExclamation, ThisWorkbook.name
End Sub

Private Sub Workbook_Open()
  modThisWorkbook.Workbook_Open_Handler Me
End Sub

Attribute VB_Name = "modHTTPServerCaller"
Option Explicit
Option Base 1

' Для реестров
' Для реестров
Public Const STR_REESTR_TYPE As String = "FULL_OWNER"
''Public Const STR_REESTR_TYPE As String = "FULL"
' FULL    - полная версия
' REDU_Y  - без МР/МО/ОКТМО с видом деятельности
' REDU_N  - без МР/МО/ОКТМО без вида деятельности
' STAT    - статистика
' ENER    - энергетика
' FULL_OWNER    - полная версия с МР/МО регистрации

Public Const STR_ACTIVITY_SPHERE As String = "VO"
'--------------
'-----FULL-----
'--------------
'   ALL
'   VS
'   VO
'   TBO
'   HOT_VS
'   VS_VO
'   VS_VO_TBO
'   EE
'   GAS
'   JKH_EE
'   WARM
'--------------
'-----REDU-----
'--------------
'   WARM
'   VS
'   HOT_VS
'   VS_VO
'   VO
'   TBO
'   EE
'--------------

Public Const STR_ADDITIONAL_REGIONS As String = ""      'дополнительные субъекты через ;
Public Const STR_REESTR_MR_MO_TYPE As String = "MRMO"


Public Const STR_RANGE_NAME As String = "REESTR_ORG_RANGE"
Public Const STR_REESTR_SHEET_NAME As String = "REESTR_ORG"
Public STR_REESTR_MO_SHEET_NAME As String
''Public Const STR_REESTR_MO_SHEET_NAME As String = "REESTR_MO"

' Адреса DNS, именно в этом порядке производится опрос
Public Const STR_HTTP_REQUEST_BASE_URL_1 As String = "https://tariff.eias.ru/procwsxls/"
Public Const STR_HTTP_REQUEST_BASE_URL_2 As String = "https://appsrv02.eias.ru/procwsxls/"
Public Const STR_HTTP_REQUEST_BASE_URL_3 As String = "https://appsrv01.eias.ru/procwsxls/"  ' TBD
Public Const STR_HTTP_REQUEST_BASE_URL_4 As String = "https://tariff.eias.ru/procwsxls/"    ' TBD

Public Const STR_HTTP_REQUEST_PROC_MR_MO_OKTMO_NAME As String = "MO_REESTR?"
Public Const STR_HTTP_REQUEST_PROC_MR_MO_OKTMO_PARAM_1 As String = "p_NSRF="
Public Const STR_HTTP_REQUEST_PROC_MR_MO_OKTMO_PARAM_2 As String = "p_TC="

Public Const STR_HTTP_REQUEST_PROC_ORG_FULL As String = "ORG_REESTR?"
Public Const STR_HTTP_REQUEST_PROC_ORG_FULL_1 As String = "p_NSRF="
Public Const STR_HTTP_REQUEST_PROC_ORG_FULL_2 As String = "p_AS="
Public Const STR_HTTP_REQUEST_PROC_ORG_FULL_3 As String = "p_VDET="
Public Const STR_HTTP_REQUEST_PROC_ORG_FULL_4 As String = "p_TC="

Public Const STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER As String = "ORG_REESTR_OWNER?"
Public Const STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER_1 As String = "p_NSRF="
Public Const STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER_2 As String = "p_AS="
Public Const STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER_3 As String = "p_VDET="
Public Const STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER_4 As String = "p_TC="

Public Const STR_HTTP_REQUEST_PROC_ORG_STAT As String = "ORG_STAT_REESTR?"
Public Const STR_HTTP_REQUEST_PROC_ORG_STAT_1 As String = "p_NSRF="
Public Const STR_HTTP_REQUEST_PROC_ORG_STAT_2 As String = "p_TC="

Public Const STR_HTTP_REQUEST_PROC_ORG_REDU As String = "ORG_REESTR_REDUCED?"
Public Const STR_HTTP_REQUEST_PROC_ORG_REDU_1 As String = "p_NSRF="
Public Const STR_HTTP_REQUEST_PROC_ORG_REDU_2 As String = "p_AS="
Public Const STR_HTTP_REQUEST_PROC_ORG_REDU_3 As String = "P_INCL_VDET="
Public Const STR_HTTP_REQUEST_PROC_ORG_REDU_4 As String = "p_TC="

Public Const STR_HTTP_REQUEST_PROC_ORG_ENER As String = "ORG_EE_REESTR?"
Public Const STR_HTTP_REQUEST_PROC_ORG_ENER_1 As String = "p_NSRF="
Public Const STR_HTTP_REQUEST_PROC_ORG_ENER_2 As String = "p_VDET="
Public Const STR_HTTP_REQUEST_PROC_ORG_ENER_3 As String = "p_TC="

' любые данные
Public Const STR_HTTP_REQUEST_PROC_GET_DATA As String = "GET_DATA?"
Public Const STR_HTTP_REQUEST_PROC_GET_DATA_1 As String = "p_DATA_TYPE="
Public Const STR_HTTP_REQUEST_PROC_GET_DATA_2 As String = "p_TC="

' Выгрузка данных
Public Function Get_Data(strTypeData As String, _
                         ByRef ArrOut() As Variant, _
                         ParamArray ArrParams()) As String

  On Error GoTo ErrHandler

  Dim strUrl As String, strTemplateCode As String

  strTemplateCode = modServiceModule.varGetDocumentProperty(ThisWorkbook, "Version")

  Select Case strTypeData
    Case "ORG"
      Select Case STR_REESTR_TYPE
        Case "FULL"
          strUrl = STR_HTTP_REQUEST_PROC_ORG_FULL & _
                   STR_HTTP_REQUEST_PROC_ORG_FULL_1 & ArrParams(0) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_FULL_2 & ArrParams(1) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_FULL_3 & ArrParams(2) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_FULL_4 & strTemplateCode
        Case "FULL_OWNER"
          strUrl = STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER & _
                   STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER_1 & ArrParams(0) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER_2 & ArrParams(1) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER_3 & ArrParams(2) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_FULL_OWNER_4 & strTemplateCode
        Case "REDU_Y"
          strUrl = STR_HTTP_REQUEST_PROC_ORG_REDU & _
                   STR_HTTP_REQUEST_PROC_ORG_REDU_1 & ArrParams(0) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_REDU_2 & ArrParams(1) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_REDU_3 & "YES" & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_REDU_4 & strTemplateCode
        Case "REDU_N"
          strUrl = STR_HTTP_REQUEST_PROC_ORG_REDU & _
                   STR_HTTP_REQUEST_PROC_ORG_REDU_1 & ArrParams(0) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_REDU_2 & ArrParams(1) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_REDU_3 & "NO" & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_REDU_4 & strTemplateCode
        Case "STAT"
          strUrl = STR_HTTP_REQUEST_PROC_ORG_STAT & _
                   STR_HTTP_REQUEST_PROC_ORG_STAT_1 & ArrParams(0) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_STAT_2 & strTemplateCode
        Case "ENER"
          strUrl = STR_HTTP_REQUEST_PROC_ORG_ENER & _
                   STR_HTTP_REQUEST_PROC_ORG_ENER_1 & ArrParams(0) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_ENER_2 & ArrParams(2) & "&" & _
                   STR_HTTP_REQUEST_PROC_ORG_ENER_3 & strTemplateCode
        Case Else
          GoTo ErrHandler
      End Select
    Case "MRMO"
      strUrl = STR_HTTP_REQUEST_PROC_MR_MO_OKTMO_NAME & _
               STR_HTTP_REQUEST_PROC_MR_MO_OKTMO_PARAM_1 & ArrParams()(0) & "&" & _
               STR_HTTP_REQUEST_PROC_MR_MO_OKTMO_PARAM_2 & strTemplateCode
    Case "ORGS_DATA"
      strUrl = STR_HTTP_REQUEST_PROC_GET_DATA & _
               STR_HTTP_REQUEST_PROC_GET_DATA_1 & ArrParams(0) & "&" & _
               STR_HTTP_REQUEST_PROC_GET_DATA_2 & strTemplateCode
    Case Else
      GoTo ErrHandler
  End Select

  Get_Data = modInvokeHTTPServer.strQuery_Data(strUrl, ArrOut)

  GoTo CleanUp

ErrHandler:
  Get_Data = STR_UPDATE_FAILED

CleanUp:
End Function


Attribute VB_Name = "cHandleEvents"
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

Private WithEvents ptb As MSForms.TextBox
Attribute ptb.VB_VarHelpID = -1
Public strWsName As String

Public Property Set Control(p As MSForms.TextBox)
  Set ptb = p
End Property

Public Property Get Control() As Control
  Set Control = ptb
End Property

Private Sub ptb_Change()
''  modfrmReestr.FilterRange
  ThisWorkbook.Worksheets(strWsName).FilterRange
End Sub

Attribute VB_Name = "modInternetConnectionState"
Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

#If VBA7 And Win64 Then
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet" _
  (ByRef dwFlags As Long, _
   ByVal dwReserved As Long) As Long
#Else
Private Declare Function InternetGetConnectedState Lib "wininet" _
  (ByRef dwFlags As Long, _
   ByVal dwReserved As Long) As Long
#End If

' Local system uses a modem to connect to the Internet.
Private Const INTERNET_CONNECTION_MODEM As Long = &H1

' Local system uses a LAN to connect to the Internet.
Private Const INTERNET_CONNECTION_LAN As Long = &H2

' Local system uses a proxy server to connect to the Internet.
Private Const INTERNET_CONNECTION_PROXY As Long = &H4

' No longer used.
Private Const INTERNET_CONNECTION_MODEM_BUSY As Long = &H8

Private Const INTERNET_RAS_INSTALLED As Long = &H10
Private Const INTERNET_CONNECTION_OFFLINE As Long = &H20
Private Const INTERNET_CONNECTION_CONFIGURED As Long = &H40

Public Function blnIsOnLine() As Boolean
  If strGetNetConnectString = "Not connected to the internet now." Then
    blnIsOnLine = False
  Else
    blnIsOnLine = True
  End If
End Function

Private Function blnIsNetConnectViaLAN() As Boolean

  Dim dwFlags As Long
   
  ' pass an empty variable into which the API will
  ' return the flags associated with the connection
  Call InternetGetConnectedState(dwFlags, 0&)

  ' return True if the flags indicate a LAN connection
  blnIsNetConnectViaLAN = dwFlags And INTERNET_CONNECTION_LAN
     
End Function

Private Function blnIsNetConnectViaModem() As Boolean

  Dim dwFlags As Long
   
  ' pass an empty variable into which the API will
  ' return the flags associated with the connection
  Call InternetGetConnectedState(dwFlags, 0&)

  ' return True if the flags indicate a modem connection
  blnIsNetConnectViaModem = dwFlags And INTERNET_CONNECTION_MODEM
     
End Function

Private Function blnIsNetConnectViaProxy() As Boolean

  Dim dwFlags As Long
   
  ' pass an empty variable into which the API will
  ' return the flags associated with the connection
  Call InternetGetConnectedState(dwFlags, 0&)

  ' return True if the flags indicate a proxy connection
  blnIsNetConnectViaProxy = dwFlags And INTERNET_CONNECTION_PROXY
     
End Function

Private Function IsNetConnectOnline() As Boolean

  ' no flags needed here - the API returns True
  ' if there is a connection of any type
  IsNetConnectOnline = InternetGetConnectedState(0&, 0&)
     
End Function

Private Function blnIsNetRASInstalled() As Boolean

  Dim dwFlags As Long
   
  ' pass an empty variable into which the API will
  ' return the flags associated with the connection
  Call InternetGetConnectedState(dwFlags, 0&)

  ' return True if the flags include RAS installed
  blnIsNetRASInstalled = dwFlags And INTERNET_RAS_INSTALLED
     
End Function

Private Function strGetNetConnectString() As String

   Dim dwFlags As Long
   Dim strMsg As String

   ' Build a string for display
   If InternetGetConnectedState(dwFlags, 0&) Then
     
      If dwFlags And INTERNET_CONNECTION_CONFIGURED Then
         strMsg = strMsg & "You have a network connection configured." & vbCrLf
      End If

      If dwFlags And INTERNET_CONNECTION_LAN Then
         strMsg = strMsg & "The local system connects to the Internet via a LAN"
      End If
      
      If dwFlags And INTERNET_CONNECTION_PROXY Then
         strMsg = strMsg & ", and uses a proxy server. "
      Else
         strMsg = strMsg & "."
      End If
      
      If dwFlags And INTERNET_CONNECTION_MODEM Then
         strMsg = strMsg & "The local system uses a modem to connect to the Internet. "
      End If
      
      If dwFlags And INTERNET_CONNECTION_OFFLINE Then
         strMsg = strMsg & "The connection is currently offline. "
      End If
      
      If dwFlags And INTERNET_CONNECTION_MODEM_BUSY Then
         strMsg = strMsg & "The local system's modem is busy with a non-Internet connection. "
      End If
      
      If dwFlags And INTERNET_RAS_INSTALLED Then
         strMsg = strMsg & "Remote Access Services are installed on this system."
      End If
      
   Else
    
      strMsg = "Not connected to the internet now."
      
   End If
   
   strGetNetConnectString = strMsg

End Function

Attribute VB_Name = "modUpd_Templ_HTTP_Request"
Option Explicit
Option Base 1

' === These constants and corresponding values indicate HTTP status codes returned by servers on the Internet. ===
Public Const HTTP_STATUS_CONTINUE As Long = 100  ' The request can be continued.
Public Const HTTP_STATUS_SWITCH_PROTOCOLS As Long = 101  ' The server has switched protocols in an upgrade header.
Public Const HTTP_STATUS_OK As Long = 200                 ' The request completed successfully.
Public Const HTTP_STATUS_CREATED As Long = 201  ' The request has been fulfilled and resulted in the creation of a new resource.
Public Const HTTP_STATUS_ACCEPTED As Long = 202  ' The request has been accepted for processing, but the processing has not been completed.
Public Const HTTP_STATUS_PARTIAL As Long = 203  ' The returned meta information in the entity-header is not the definitive set available from the originating server.
Public Const HTTP_STATUS_NO_CONTENT As Long = 204  ' The server has fulfilled the request, but there is no new information to send back.
Public Const HTTP_STATUS_RESET_CONTENT As Long = 205  ' The request has been completed, and the client program should reset the document view that caused the request to be sent to allow the user to easily initiate another input action.
Public Const HTTP_STATUS_PARTIAL_CONTENT As Long = 206  ' The server has fulfilled the partial GET request for the resource.
Public Const HTTP_STATUS_WEBDAV_MULTI_STATUS As Long = 207  ' During a World Wide Web Distributed Authoring and Versioning (WebDAV) operation, this indicates multiple status codes for a single response. The response body contains Extensible Markup Language (XML) that describes the status codes. For more information, see HTTP Extensions for Distributed Authoring.
Public Const HTTP_STATUS_AMBIGUOUS As Long = 300  ' The requested resource is available at one or more locations.
Public Const HTTP_STATUS_MOVED As Long = 301                 ' The requested resource has been assigned to a new permanent Uniform Resource Identifier (URI), and any future references to this resource should be done using one of the returned URIs.
Public Const HTTP_STATUS_REDIRECT As Long = 302  ' The requested resource resides temporarily under a different URI.
Public Const HTTP_STATUS_REDIRECT_METHOD As Long = 303  ' The response to the request can be found under a different URI and should be retrieved using a GET HTTP verb on that resource.
Public Const HTTP_STATUS_NOT_MODIFIED As Long = 304  ' The requested resource has not been modified.
Public Const HTTP_STATUS_USE_PROXY As Long = 305  ' The requested resource must be accessed through the proxy given by the location field.
Public Const HTTP_STATUS_REDIRECT_KEEP_VERB As Long = 307  ' The redirected request keeps the same HTTP verb. HTTP/1.1 behavior.
Public Const HTTP_STATUS_BAD_REQUEST As Long = 400  ' The request could not be processed by the server due to invalid syntax.
Public Const HTTP_STATUS_DENIED As Long = 401  ' The requested resource requires user authentication.
Public Const HTTP_STATUS_PAYMENT_REQ As Long = 402  ' Not implemented in the HTTP protocol.
Public Const HTTP_STATUS_FORBIDDEN As Long = 403  ' The server understood the request, but cannot fulfill it.
Public Const HTTP_STATUS_NOT_FOUND As Long = 404  ' The server has not found anything that matches the requested URI.
Public Const HTTP_STATUS_BAD_METHOD As Long = 405  ' The HTTP verb used is not allowed.
Public Const HTTP_STATUS_NONE_ACCEPTABLE As Long = 406  ' No responses acceptable to the client were found.
Public Const HTTP_STATUS_PROXY_AUTH_REQ As Long = 407  ' Proxy authentication required.
Public Const HTTP_STATUS_REQUEST_TIMEOUT As Long = 408  ' The server timed out waiting for the request.
Public Const HTTP_STATUS_CONFLICT As Long = 409  ' The request could not be completed due to a conflict with the current state of the resource. The user should resubmit with more information.
Public Const HTTP_STATUS_GONE As Long = 410                 ' The requested resource is no longer available at the server, and no forwarding address is known.
Public Const HTTP_STATUS_LENGTH_REQUIRED As Long = 411  ' The server cannot accept the request without a defined content length.
Public Const HTTP_STATUS_PRECOND_FAILED As Long = 412  ' The precondition given in one or more of the request header fields evaluated to false when it was tested on the server.
Public Const HTTP_STATUS_REQUEST_TOO_LARGE As Long = 413  ' The server cannot process the request because the request entity is larger than the server is able to process.
Public Const HTTP_STATUS_URI_TOO_LONG As Long = 414  ' The server cannot service the request because the request URI is longer than the server can interpret.
Public Const HTTP_STATUS_UNSUPPORTED_MEDIA As Long = 415  ' The server cannot service the request because the entity of the request is in a format not supported by the requested resource for the requested method.
Public Const HTTP_STATUS_RETRY_WITH As Long = 449  ' The request should be retried after doing the appropriate action.
Public Const HTTP_STATUS_SERVER_ERROR As Long = 500  ' The server encountered an unexpected condition that prevented it from fulfilling the request.
Public Const HTTP_STATUS_NOT_SUPPORTED As Long = 501  ' The server does not support the functionality required to fulfill the request.
Public Const HTTP_STATUS_BAD_GATEWAY As Long = 502  ' The server, while acting as a gateway or proxy, received an invalid response from the upstream server it accessed in attempting to fulfill the request.
Public Const HTTP_STATUS_SERVICE_UNAVAIL As Long = 503  ' The service is temporarily overloaded.
Public Const HTTP_STATUS_GATEWAY_TIMEOUT As Long = 504  ' The request was timed out waiting for a gateway.
Public Const HTTP_STATUS_VERSION_NOT_SUP As Long = 505  ' The server does not support the HTTP protocol version that was used in the request message.

' Запросить информацию о доступных обновлениях
Public Function tviQuery_Update_Info(ByRef strXMLTagNames() As String, _
                                     ByVal strTemplateCode As String, _
                                     Optional blnShowMessage As Boolean = True) As TVersionInfo

  On Error GoTo ErrHandler

  Dim strUrl As String
  Dim lngICounter As Long
  Dim lngNumberOfQueryFields As Long

  Dim lngRequestCounter As Long
  Dim strBaseURL(4) As String

  Dim blnSuccessfulRequest As Boolean

  If Len(strTemplateCode) > 0 Then
    ' Сформировать URL-запрос
    strUrl = STR_HTTP_REQUEST_PROC_GET_UPDATE_INFO_NAME & _
             STR_HTTP_REQUEST_PROC_GET_UPDATE_INFO_PARAM_1 & strTemplateCode
  Else
    GoTo ErrHandler
  End If

  Dim tviResult As TVersionInfo
  tviResult.lngFileSize = 0
  tviResult.strDescription = vbNullString
  tviResult.strVersion = vbNullString
  tviResult.strNewVersionURL = vbNullString

  For lngICounter = 1 To UBound(strXMLTagNames)
    ' Проверить, что все запрашиваемые поля валидные
    If Len(strXMLTagNames(lngICounter)) = 0 Then
      GoTo ErrHandler
    End If
  Next lngICounter

  lngNumberOfQueryFields = UBound(strXMLTagNames)

  ' Check Internet Connection Status
  If modInternetConnectionState.blnIsOnLine = False Then
    GoTo Offline
  End If

  Dim lngRequestStatus As Long  ' Статус запроса

  ' HTTP Request
  Dim objXMLHTTP As MSXML2.XMLHTTP
  Dim objXMLDOMDocument As MSXML2.DOMDocument

  Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP.3.0")

  strBaseURL(1) = STR_HTTP_REQUEST_BASE_URL_1
  strBaseURL(2) = STR_HTTP_REQUEST_BASE_URL_2
  strBaseURL(3) = STR_HTTP_REQUEST_BASE_URL_3
  strBaseURL(4) = STR_HTTP_REQUEST_BASE_URL_4

  blnSuccessfulRequest = False

  ' Последовательный опрос DNS...
  For lngRequestCounter = LBound(strBaseURL) To UBound(strBaseURL)

    On Error GoTo TryNextDNS

    ' Отправить HTTP-запрос...
    lngRequestStatus = lngSend_Request(objXMLHTTP, objXMLDOMDocument, strBaseURL(lngRequestCounter) & strUrl)

    If Not lngRequestStatus = HTTP_STATUS_OK Then
      GoTo TryNextDNS
    End If

    If objXMLDOMDocument Is Nothing Then
      GoTo TryNextDNS
    End If

    If objXMLDOMDocument.DocumentElement Is Nothing Then
      GoTo TryNextDNS
    End If

    If objXMLDOMDocument.DocumentElement.ChildNodes Is Nothing Then
      GoTo TryNextDNS
    End If

    If objXMLDOMDocument.DocumentElement.ChildNodes.Length >= 0 Then
      blnSuccessfulRequest = True
      Exit For
    End If

TryNextDNS:
  Next lngRequestCounter


  On Error GoTo ErrHandler
  
  If blnSuccessfulRequest = False Then
    GoTo ErrHandler
  End If

  ' Найти последнюю версию
  Dim strMaxVersion As String
  Dim strDescription As String
  Dim strFileSize As String
  Dim strNewVersionURL As String
  
  If objXMLDOMDocument.DocumentElement.ChildNodes.Length > 0 Then

    For lngICounter = 0 To objXMLDOMDocument.DocumentElement.ChildNodes.Length - 1

      Dim rec As MSXML2.IXMLDOMElement
      Set rec = objXMLDOMDocument.DocumentElement.ChildNodes.Item(lngICounter)

      If Len(strMaxVersion) = 0 Then

        ' Первое значение считаем максимальным
        strMaxVersion = rec.getElementsByTagName(strXMLTagNames(1)).Item(0).Text          ' Поиск тэга "версия"
        strDescription = rec.getElementsByTagName(strXMLTagNames(2)).Item(0).Text         ' Поиск тэга "описание"
        strFileSize = rec.getElementsByTagName(strXMLTagNames(3)).Item(0).Text            ' Поиск тэга "размер обновления"
        strNewVersionURL = rec.getElementsByTagName(strXMLTagNames(4)).Item(0).Text       ' Поиск тэга "ссылка на шаблон"

      Else

        ' 1.2.5 : 1 - это MasterVersion, 2 - это SubVersion, 5 - минорные изменения
        
        If modUpdTemplMain.blnIs_New_Version(strMaxVersion, rec.getElementsByTagName(strXMLTagNames(1)).Item(0).Text) = True Then
          ' обновление до этой версии возможно
          strMaxVersion = rec.getElementsByTagName(strXMLTagNames(1)).Item(0).Text        ' новое значение версии больше
          strDescription = rec.getElementsByTagName(strXMLTagNames(2)).Item(0).Text       ' Поиск тэга "описание"
          strFileSize = rec.getElementsByTagName(strXMLTagNames(3)).Item(0).Text          ' Поиск тэга "размер обновления"
          strNewVersionURL = rec.getElementsByTagName(strXMLTagNames(4)).Item(0).Text     ' Поиск тэга "ссылка на шаблон"
        End If

      End If

    Next lngICounter

  End If

  If Len(strFileSize) = 0 Then
    tviResult.lngFileSize = 0
  Else
    tviResult.lngFileSize = CLng(strFileSize)
  End If
  tviResult.strDescription = strDescription
  tviResult.strVersion = strMaxVersion
  tviResult.strNewVersionURL = strNewVersionURL

  GoTo Success

Success:
  GoTo CleanUp
ErrHandler:
  If blnShowMessage = True Then
    MsgBox STR_UPDATE_FAILED, vbExclamation, modGlobals.STR_MSGBOX_WARNING_TITLE
  End If
  GoTo CleanUp
Offline:
''  Instruction.Shapes("cmdAct_1").Visible = False
''  Instruction.Shapes("cmdAct_2").Visible = False
''  Instruction.Shapes("cmdNoAct_1").Visible = False
''  Instruction.Shapes("cmdNoAct_2").Visible = False
''  Instruction.Shapes("cmdNoInet_1").Visible = True
''  Instruction.Shapes("cmdNoInet_2").Visible = True
  ' Для обновления статуса на листе "Инструкция"
  tviResult.strDescription = "offline"
  tviResult.strVersion = vbNullString
  tviResult.strNewVersionURL = vbNullString
  If blnShowMessage = True Then
    MsgBox STR_INET_CONNECTION_IS_OFFLINE, vbExclamation, modGlobals.STR_MSGBOX_WARNING_TITLE
  End If
  GoTo CleanUp
CleanUp:
  tviQuery_Update_Info = tviResult
End Function

' Запросить обновление, возвращает имя файла
Public Function strQuery_Update(ByVal strFullFileName As String, _
                                ByVal strTemplateCode As String, _
                                ByVal strVersion As String) As String

  On Error GoTo ErrHandler

  Dim strUrl As String

  Dim lngRequestCounter As Long
  Dim strBaseURL(4) As String

  If Len(strFullFileName) > 0 And _
     Len(strTemplateCode) > 0 And _
     Len(strVersion) > 0 Then
    ' Сформировать URL-запрос
    strUrl = STR_HTTP_REQUEST_PROC_GET_UPDATE_NAME & _
             STR_HTTP_REQUEST_PROC_GET_UPDATE_PARAM_1 & strTemplateCode & "&" & _
             STR_HTTP_REQUEST_PROC_GET_UPDATE_PARAM_2 & strVersion
  Else
    GoTo ErrHandler
  End If

  Dim lngRequestStatus As Long  ' Статус запроса

  Dim lngFileNum As Long
  Dim bytFileData() As Byte
  Dim strMyFile As String
  Dim objWHTTP As Object

  On Error Resume Next

  Set objWHTTP = CreateObject("WinHTTP.WinHTTPrequest.5")
  If Err.Number <> 0 Then
    Set objWHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
  End If

  On Error GoTo 0

  strBaseURL(1) = STR_HTTP_REQUEST_BASE_URL_1
  strBaseURL(2) = STR_HTTP_REQUEST_BASE_URL_2
  strBaseURL(3) = STR_HTTP_REQUEST_BASE_URL_3
  strBaseURL(4) = STR_HTTP_REQUEST_BASE_URL_4

  ' Последовательный опрос DNS...
  For lngRequestCounter = LBound(strBaseURL) To UBound(strBaseURL)

    On Error GoTo TryNextDNS

    ' Отправить HTTP-запрос...
    lngRequestStatus = lngSend_File_Request(objWHTTP, strBaseURL(lngRequestCounter) & strUrl)

    If Not lngRequestStatus = HTTP_STATUS_OK Then
      GoTo TryNextDNS
    End If

    bytFileData = objWHTTP.responseBody

    If UBound(bytFileData) > 100 Then  ' Файл меньше никак быть не может...

      Set objWHTTP = Nothing

      lngFileNum = FreeFile
      Open strFullFileName For Binary Access Write As lngFileNum
      Put lngFileNum, 1, bytFileData
      Close lngFileNum

      GoTo Success

    End If

TryNextDNS:
  Next lngRequestCounter

  Select Case lngRequestStatus
  Case HTTP_STATUS_OK
    ' Successful, но выход должен был быть выше, значит...
    strQuery_Update = "Файла обновления повреждён"
  Case HTTP_STATUS_NO_CONTENT
    strQuery_Update = "Отсутствует содержимое файла обновления [HTTP_STATUS_NO_CONTENT}"
  Case HTTP_STATUS_PROXY_AUTH_REQ
    strQuery_Update = "Ошибка запроса файла обновления: необходима аутентификация прокси-сервера: [HTTP_STATUS_PROXY_AUTH_REQ]"
  Case HTTP_STATUS_BAD_GATEWAY
    strQuery_Update = "Ошибка запроса файла обновления: получен неверный ответ от шлюза или прокси-сервера: [HTTP_STATUS_BAD_GATEWAY]"
  Case HTTP_STATUS_NOT_FOUND
    strQuery_Update = "Файл обновления не найден: [HTTP_STATUS_NOT_FOUND}"
  Case HTTP_STATUS_BAD_REQUEST
    strQuery_Update = "Ошибка запроса файла обновления: [HTTP_STATUS_BAD_REQUEST]"
  Case HTTP_STATUS_BAD_METHOD
    strQuery_Update = "Ошибка запроса файла обновления: [HTTP_STATUS_BAD_METHOD]"
  Case Else
    strQuery_Update = "Ошибка запроса файла обновления: код ошибки [" & lngRequestStatus & "]"
  End Select

  GoTo ErrHandler

Success:
  strQuery_Update = strFullFileName
  GoTo CleanUp
ErrHandler:
  If Len(strQuery_Update) = 0 Then
    strQuery_Update = "Ошибка запроса файла обновления: код ошибки [UNDEFINED]"
  End If
  MsgBox strQuery_Update, vbExclamation, modGlobals.STR_MSGBOX_WARNING_TITLE
  GoTo CleanUp
CleanUp:
End Function

' Удалить существующий именованный диапазон
Public Sub Delete_Existing_Name_In_Workbook(wbBook As Workbook, _
                                            strNameOfRange As String)
  On Error GoTo ErrHandler
  If wbBook Is Nothing Or _
     Len(strNameOfRange) = 0 Then
    GoTo ErrHandler
  End If
  wbBook.Names(strNameOfRange).Delete
ErrHandler:
End Sub

Public Sub SaveXML(ByVal wbBook As Workbook, _
                   ByVal strXML As String)

  Dim FileNo As Long
  FileNo = FreeFile

  Open wbBook.Path & "\" & "Save.txt" For Output As FileNo

  Print #FileNo, strXML

  Close FileNo

End Sub

' Отправить HTTP-запрос на файл
Private Function lngSend_File_Request(ByRef objWHTTP As Object, _
                                      ByVal strUrl As String) As Long

  On Error GoTo ErrHandler

  objWHTTP.Open "GET", strUrl, False
  objWHTTP.send

  lngSend_File_Request = objWHTTP.status

  GoTo CleanUp

ErrHandler:
  lngSend_File_Request = HTTP_STATUS_BAD_REQUEST
  GoTo CleanUp
CleanUp:
End Function

' Отправить HTTP-запрос
Private Function lngSend_Request(ByRef objXMLHTTP As MSXML2.XMLHTTP, _
                                 ByRef objXMLDOMDocument As MSXML2.DOMDocument, _
                                 ByVal strUrl As String) As Long

  On Error GoTo ErrHandler

  objXMLHTTP.Open bstrMethod:="GET", bstrUrl:=strUrl, varAsync:=False
  objXMLHTTP.send

  Set objXMLDOMDocument = objXMLHTTP.responseXML

  lngSend_Request = objXMLHTTP.status

  If modGlobals.gblnTestMode = True Then
    Debug.Print objXMLDOMDocument.Text
  End If

  GoTo CleanUp

ErrHandler:
  lngSend_Request = HTTP_STATUS_BAD_REQUEST
  GoTo CleanUp
CleanUp:
End Function


Attribute VB_Name = "TSH_et_union_vert"
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 = "modUpdTemplMain"
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
Option Base 1

Private gstrNewVersion As String
Private gstrTemplateCode As String
Private gstrResultUpdate As String
Private gstrPatchFileName As String

' Проверка доступных обновлений (при открытии книги)
Public Sub Check_Update_Execution(ByVal wbBook As Workbook)
  Check_Updates wbBook, False
End Sub

' Хендлер кнопки проверить наличие обновлений
Public Sub cmdCheckForUpdates_Click_Handler()
  blnMsgBoxActualVersion = True
  Check_Updates ThisWorkbook, True
End Sub

' Проверить наличие обновлений
Public Sub Check_Updates(ByVal wbBook As Workbook, _
                         Optional blnShowMessage As Boolean = True)
  
  On Error GoTo ErrHandler
  
  Dim strNewVersion As String
  Dim strTemplateCode As String
  Dim strDescription As String

  Dim tviResultSet As TVersionInfo
  Dim vbResult As VbMsgBoxResult
  Dim strCurrentVersion As String
  
  If wbBook Is Nothing Then
    GoTo CleanUp
  End If
  
  strTemplateCode = modServiceModule.varGetDocumentProperty(ThisWorkbook, "Version")
  gstrTemplateCode = strTemplateCode

  If Len(strTemplateCode) = 0 Then
  
    lbInfo_AddInfo "Не удалось определить код шаблона!", STR_FORM_STATUS_WARNING
    GoTo CleanUp
    
  Else
  
    lbInfo_AddInfo "Проверка доступных обновлений...", STR_FORM_STATUS_INFO
    
    ' Запрос информации о последней доступной для обновления версии
    tviResultSet = modUpd_Templ_Caller.Query_Last_Version_Info(strTemplateCode, _
                                                               blnShowMessage)
    
    strNewVersion = tviResultSet.strVersion
    gstrNewVersion = strNewVersion
    strDescription = tviResultSet.strDescription
    
    If Len(strNewVersion) = 0 Then
    
      ' обновление не требуется
      If blnMsgBoxActualVersion = True Then _
        MsgBox "Нет доступных обновлений для шаблона с кодом " & _
                     strTemplateCode, _
               vbInformation, _
               modGlobals.STR_MSGBOX_INFORMATION_TITLE
      
      lbInfo_AddInfo "Нет доступных обновлений для шаблона с кодом " & _
                     strTemplateCode & "!", STR_FORM_STATUS_INFO
      
      ' Статус версии
      If strDescription = "offline" Then
        Set_Update_Availability_Status "Offline"
      Else
        Set_Update_Availability_Status "Act"
      End If
          
      GoTo CleanUp
      
    Else ' Новая версия определена
    
      strCurrentVersion = CStr(ThisWorkbook.CustomDocumentProperties("CurrentVersion").Value)
      
      If Len(strCurrentVersion) = 0 Then
        lbInfo_AddInfo "Не удалось определить текущую версию шаблона!", STR_FORM_STATUS_ERROR
        GoTo CleanUp
      End If
    
      ' Определить необходимость обновления
      If blnIs_New_Version(strCurrentVersion, strNewVersion) = False Then
        ' обновление не требуется
        If blnMsgBoxActualVersion = True Then _
          MsgBox "Версия шаблона " & strCurrentVersion & " актуальна", _
                 vbInformation, _
                 modGlobals.STR_MSGBOX_INFORMATION_TITLE
        lbInfo_AddInfo "Версия шаблона " & strCurrentVersion & _
                       " актуальна, обновление не требуется", STR_FORM_STATUS_INFO
        
        ' Статус версии
        Set_Update_Availability_Status "Act"
        
        GoTo CleanUp
      End If
      
      lbInfo_AddInfo "Доступно обновление до версии " & tviResultSet.strVersion, STR_FORM_STATUS_INFO
      lbInfo_AddInfo "Описание изменений: " & tviResultSet.strDescription, STR_FORM_STATUS_INFO
      lbInfo_AddInfo "Размер файла обновления: " & CStr(tviResultSet.lngFileSize) & " байт", STR_FORM_STATUS_INFO

      ' Статус версии
      Set_Update_Availability_Status "NoAct"
      
      modUpd_Templ_Defines.LNG_UPDATE_MODULE_SIZE = tviResultSet.lngFileSize
      modUpd_Templ_Defines.STR_NEW_VERSION_URL = tviResultSet.strNewVersionURL
      
      If modUpd_Templ_Defines.LNG_UPDATE_MODULE_SIZE > 0 Then
      
        modUpd_Templ_Defines.STR_UPDATE_TO_VERSION = "Доступно обновление до версии " & tviResultSet.strVersion
        
        modUpd_Templ_Defines.STR_UPDATE_DESCRIPTION = CStr(tviResultSet.strDescription)
        
        modUpd_Templ_Defines.STR_UPDATE_MODULE_ATTRIBUTES = "Размер файла обновления: " & CStr(tviResultSet.lngFileSize) & " байт"
      
      Else
      
        modUpd_Templ_Defines.STR_UPDATE_TO_VERSION = vbNullString
        
        modUpd_Templ_Defines.STR_UPDATE_DESCRIPTION = vbNullString
        
        modUpd_Templ_Defines.STR_UPDATE_MODULE_ATTRIBUTES = vbNullString
      
      End If
      
      frmCheckUpdates.Show vbModal

      If modUpd_Templ_Defines.BLN_INSTALL_UPDATES = True Then
      
        lbInfo_AddInfo "Подготовка к обновлению...", STR_FORM_STATUS_INFO
        
        Init_Update ThisWorkbook, strTemplateCode, strNewVersion
      
      Else
      
        lbInfo_AddInfo "Обновление отменено пользователем", STR_FORM_STATUS_WARNING
        
      End If

    End If
  
  End If

  GoTo Success

Success:
  GoTo CleanUp
ErrHandler:
  lbInfo_AddInfo "Ошибка проверки обновления", STR_FORM_STATUS_ERROR
  GoTo CleanUp
CleanUp:
End Sub

' Кнопка "Обновить шаблон"
Public Sub cmdPerformUpdate_Click_Handler()
  
  lbInfo_AddInfo "Начало обновления...", STR_FORM_STATUS_INFO
  
  Init_Update ThisWorkbook, gstrTemplateCode, gstrNewVersion

End Sub

Private Sub Init_Update(ByRef wbBook As Workbook, _
                        ByVal strTemplateCode As String, _
                        ByVal strNewVersion As String)
  
  On Error GoTo ErrHandler
  
  Dim strBackupFileName As String
  Dim strCurrentWBPath As String
  Dim strCurrentWBName As String
  
  Dim wbBackupWorkbook As Workbook
  Dim wbUpdatingWorkbook As Workbook
  
  Dim strWorkbookName As String
  Dim strFileExtension As String
  Dim lngFileFormatNum As Long
  
  If wbBook Is Nothing Or _
     Len(strTemplateCode) = 0 Or _
     Len(strNewVersion) = 0 Then
    GoTo CleanUp
  End If
  
  Set wbBackupWorkbook = wbBook
  
  ' Имя файла для резервной копии
  strBackupFileName = Application.GetSaveAsFilename(wbBackupWorkbook.FullName, , , _
                                                    "Сохранить резервную копию")

  If CStr(strBackupFileName) = "False" Then
    lbInfo_AddInfo "Создание резервной копии отменено, обновление прервано", STR_FORM_STATUS_WARNING
…