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
Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  modThisWorkbook.Workbook_BeforeSave_Handler SaveAsUI, Cancel
End Sub

Private Sub Workbook_Open()
  modThisWorkbook.Workbook_Open_Handler
End Sub

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  modThisWorkbook.Workbook_SheetBeforeRightClick_Handler Sh, Target, Cancel
End Sub

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
  modThisWorkbook.Workbook_SheetFollowHyperlink_Handler Sh, Target
End Sub


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

Public Sub Workbook_Open_Handler()
  On Error Resume Next

  Application.Calculation = xlCalculationAutomatic  ' чтобы пересчет формул осуществлялся автоматически
  Application.ReferenceStyle = xlA1  ' стиль ссылок - A1

  If modServiceModule.blnIsDocumentProperty(ThisWorkbook, "Status") Then
    ThisWorkbook.CustomDocumentProperties("Status") = 1  'ТРАНС
  End If

  Check_Update ThisWorkbook
  modReestr.UpdateURLReestr
  modReestr.UpdateDocLinkReestr

End Sub


Public Sub Workbook_BeforeSave_Handler(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  On Error GoTo ErrHandler

  Application.Calculate

  Application.ReferenceStyle = xlA1

  ' Если не выбран регион - нечего проверять
  If Len(CStr(ThisWorkbook.Names("region_name").RefersToRange.cells(1, 1).Value)) = 0 Then
    Exit Sub
  End If

  If vbNo = MsgBox("Процедура проверки перед сохранением может занять некоторое время. " & _
                   "Запустить процедуру проверки шаблона?", vbInformation + vbYesNo, "Информация") Then
    Exit Sub
  End If

  modProv.Perform_Validation ThisWorkbook

  AppActivate Application.caption

  If modGlobals.glngCriticalImpactWarningsCounter > 0 Or modGlobals.glngLowImpactWarningsCounter > 0 Then
    ThisWorkbook.CustomDocumentProperties("Status") = 1  'ТРАНС
    ThisWorkbook.Worksheets("Проверка").Activate
    ThisWorkbook.Worksheets("Проверка").Range("A5").Select
  Else  'ТРАНС
    ThisWorkbook.CustomDocumentProperties("Status") = 2  'ТРАНС
  End If


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

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


Public Sub Workbook_SheetBeforeRightClick_Handler(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  Dim HLCommandBar As IHLCommandBar

  On Error Resume Next

  If Not Target Is Nothing And Target.cells(1, 1).MergeArea.cells.Count = Target.Count Then
    If InStr(Target.cells(1, 1).Value2, "http://") Or _
       InStr(Target.cells(1, 1).Value2, "https://") Then
      Cancel = True
      Set HLCommandBar = New IHLCommandBar
      HLCommandBar.ShowPopupIHLCommandBar
      Set HLCommandBar = Nothing
    End If
  End If
End Sub

Public Sub Workbook_SheetFollowHyperlink_Handler(ByVal Sh As Object, ByVal Target As Hyperlink)
  On Error Resume Next
  If Target.ScreenTip Like "http*" Then ThisWorkbook.FollowHyperlink Target.ScreenTip
End Sub

Public Sub Check_Update(ByRef wbBook As Workbook)
' Для обновления
  If modServiceModule.IsNameExists(wbBook, "chkGetUpdatesValue") = True Then
    If wbBook.Names("chkGetUpdatesValue").RefersToRange.cells(1, 1).Value = "y" Then
      modUpdTemplMain.Check_Update_Execution wbBook
    End If
  End If
End Sub

Attribute VB_Name = "modUsingAPIControlApplications"

#If VBA7 And Win64 Then
  Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" _
          Alias "ShellExecuteA" _
          (ByVal hwnd As Long, ByVal lpOperation As String, _
           ByVal lpFile As String, ByVal lpParameters As String, _
           ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

#Else
  Private Declare Function ShellExecute Lib "shell32.dll" _
                                        Alias "ShellExecuteA" _
                                        (ByVal hwnd As Long, ByVal lpOperation As String, _
                                         ByVal lpFile As String, ByVal lpParameters As String, _
                                         ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If


Public Const SW_SHOWNORMAL As Long = 1
Public Const SW_SHOWMAXIMIZED As Long = 3
Public Const SW_SHOWDEFAULT As Long = 10


Public Sub RunBrowser(strURL As String, iWindowStyle As Integer, ByVal blnShowFailedStatus As Boolean)

  Dim lSuccess As Long

  lSuccess = ShellExecute(1, "Open", _
                          strURL, 0&, 0&, iWindowStyle)

  If Not lSuccess = 42 And blnShowFailedStatus = True Then
    MsgBox "Не удалось перейти по ссылке, проверьте правильность ввода и существование указаного адреса!", vbExclamation, "Внимание"
  End If

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 = "modProv"
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 Base 1
Option Explicit

' Общая функция проверки перед сохранением
Public Sub Perform_Validation(ByVal wbBook As Workbook)

  On Error GoTo ErrHandler
  Dim Updater As clsUpdater
  Dim wsCheckSheet As Worksheet
  Dim rngCell As Range
  Dim lngI As Long

  ' в первую очередь проверим, а не удален ли лист Проверка
  If Not (modServiceModule.SheetExists("Проверка", wbBook)) Then
    ' с листом что-то не так? Просто создадим новый ;)
    modServiceModule.CreateCheckSheet wbBook, "Проверка"
  End If

  Set modProvGeneralProc.wsCheckSheet = wbBook.Worksheets("Проверка")
  Set wsCheckSheet = modProvGeneralProc.wsCheckSheet

  Set Updater = New clsUpdater
  Updater.AddWS wsCheckSheet

  modGlobals.LNG_NUM_ROW_PROV = 5

  wsCheckSheet.AutoFilterMode = False
  wsCheckSheet.Range(wsCheckSheet.Rows(5), _
                     wsCheckSheet.Rows(wsCheckSheet.UsedRange.Rows.Count + 14)).Delete
  wsCheckSheet.Range("B4:E4").AutoFilter

  modGlobals.glngCriticalImpactWarningsCounter = 0
  modGlobals.glngLowImpactWarningsCounter = 0

  'стадии проверки
  ReDim ArrCheckStage(1 To 2)
  ArrCheckStage(1).strName = "Общие проверки"
  ArrCheckStage(2).strName = "Проверка заполненности шаблона"
  lngCurrCheckStage = 1

  'показываем форму
  If blnIs_UserForm_Loaded("frmValidationInProgress") Then Unload frmValidationInProgress
  frmValidationInProgress.cmdOK.caption = frmValidationInProgress.cmdOK.caption & vbNullString
  DoEvents

  'чистим проверку голубых
  wbBook.Worksheets("modCheckCyan").DelInvalidCheck

  If modProvGeneralProc.blnCheckIfSheet And Not modProvGeneralProc.blnInvalidValues(wbBook) Then
    WarningsBeforeSavingForTitle wbBook.Worksheets("Титульный")
    frmValidationInProgress.Mark_Next_Validation
    ' ================================================================================================================================

    If wbBook.Worksheets("Титульный").Shapes("cmdStart").Visible = msoTrue Then
      modProvGeneralProc.Add_Hyperlink wbBook.Worksheets("Титульный").Range("org_id"), Nothing, _
                                       "Шаблон не заполнен полностью, заполните лист 'Титульный' и нажмите кнопку 'Продолжить заполнение'", STR_KIND_ERROR
    ElseIf wbBook.Worksheets("Тарифы").Visible = xlSheetVisible And wbBook.Worksheets("Тарифы").Shapes("cmdNext").Visible = msoTrue Then
      modProvGeneralProc.Add_Hyperlink wbBook.Worksheets("Тарифы").Range("A1"), Nothing, _
                                       "Шаблон не заполнен полностью, заполните лист 'Тарифы' и нажмите кнопку 'Продолжить заполнение'", STR_KIND_ERROR
    Else
      modProvGeneralProc.CheckCyanCells wbBook.Worksheets("modCheckCyan")

      'проверка листа ПО (П.4.3б)
      '1. Проверка-ошибка, если сумма 4.1....4.4 не равна 4.   -   убрано в версии 2.1
      '2. Проверка-ошибка, если сумма 6.1...6.4 не равна 6.
      CheckListP4_3_b wbBook.Worksheets("ПО (П.4.3б)")

      'проверка листа Покупка ЭЭ (П.4.7.1)
      '1. Проверка-ошибка, если пункт 3.2 не равен п.4*п.5.
      CheckListP4_7_1 wbBook.Worksheets("Покупка ЭЭ (П.4.7.1)")
    End If
  End If

  GoTo CleanUp

ErrHandler:
  If err.Number = vbObjectError + 1000 Then
    modProvGeneralProc.Add_Hyperlink Nothing, Nothing, _
                                     "Кол-во сообщений со статусом <" & modGlobals.STR_KIND_ERROR & _
                                     "> более " & modGlobals.glngCriticalImpactWarningsCounter & _
                                     ". Проверка прервана! Пожалуйста, сначала устраните найденные замечания!", modGlobals.STR_KIND_ERROR
  Else
    modProvGeneralProc.Add_Hyperlink Nothing, Nothing, _
                                     "Возникла ошибка при проверке шаблона: " & err.Description, modGlobals.STR_KIND_ERROR
    MsgBox "Возникла ошибка при проверке шаблона: " & err.Description, vbOKOnly + vbExclamation, modGlobals.STR_MSGBOX_WARNING_TITLE
    GoTo CleanUp
  End If

CleanUp:
  frmValidationInProgress.Mark_Next_Validation True
End Sub

' Проверка листа "Титульный"
Public Sub WarningsBeforeSavingForTitle(wsSheet As Worksheet)

  Dim rngRange As Range
  Dim rngCell As Range

  Set rngRange = Union(wsSheet.Range("type_version"), _
                       wsSheet.Range("god"), _
                       wsSheet.Range("List00_CHECK1"), _
                       wsSheet.Range("List00_CHECK2"), _
                       wsSheet.Range("fil_flag"), _
                       wsSheet.Range("org"), _
                       wsSheet.Range("inn"), _
                       wsSheet.Range("kpp"), _
                       wsSheet.Range("List00_CHECK3"))

  If LCase(wsSheet.Range("fil_flag").Value) = "да" Then Set rngRange = Union(rngRange, wsSheet.Range("fil"))

  For Each rngCell In rngRange.cells
    If Not isIntersect(rngCell, wsSheet.Range("List00_CHECK4")) Then
      If (Len(rngCell.cells(1, 1).Value) = 0) Then  ' наличие
        modProvGeneralProc.Add_Hyperlink rngCell, Nothing, _
                                         "Не указано значение!", STR_KIND_ERROR
      ElseIf (Len(rngCell.cells(1, 1).Value) > 990) Then  ' проверить длину поля
        modProvGeneralProc.Add_Hyperlink rngCell, Nothing, _
                                         "Недопустимая длина поля (допускается не более 900 символов)!", STR_KIND_ERROR
      End If
    End If
  Next rngCell


End Sub

'проверка листа ПО (П.4.3б)
'1. Проверка-ошибка, если сумма 4.1....4.4 не равна 4.    -   убрано в версии 2.1
'2. Проверка-ошибка, если сумма 6.1...6.4 не равна 6.
Public Sub CheckListP4_3_b(wsSheet As Worksheet)
  Dim lngI As Long, lngJ As Long

  For lngI = wsSheet.Range("List04_rqt_start_row").Row To wsSheet.Range("pIns_List04_rqt").Row
    If wsSheet.cells(lngI, 6) = "6" Then
      For lngJ = 9 To wsSheet.Range("List04_last_cell").Column
        If Not wsSheet.cells(1, lngJ) Like "План органа регулирования*" Or wsSheet.Parent.Names("type_version").RefersToRange = "Версия регулятора" Then
          If Abs(wsSheet.cells(lngI, lngJ) - WorksheetFunction.Sum(wsSheet.cells(lngI + 1, lngJ).Resize(4))) > 0.01 Then
            modProvGeneralProc.Add_Hyperlink wsSheet.cells(lngI, lngJ), wsSheet.cells(lngI + 1, lngJ).Resize(4), _
                                             "Пункт " & wsSheet.cells(lngI, 6) & " должен быть равен сумме подпунктов 1-4!", STR_KIND_ERROR
          End If
        End If
      Next lngJ
    End If
  Next lngI

End Sub

'проверка листа Покупка ЭЭ (П.4.7.1)
'1. Проверка-ошибка, если пункт 3.2 не равен п.4*п.5.
Public Sub CheckListP4_7_1(wsSheet As Worksheet)
  Dim lngI As Long, lngJ As Long

  For lngI = 10 To wsSheet.Range("pIns_List06_rqt").Row
    If wsSheet.cells(lngI, 13) = "3.2" Then
      For lngJ = 17 To wsSheet.Range("List06_last_cell").Column
        If Not wsSheet.cells(1, lngJ) Like "План органа регулирования*" Or wsSheet.Parent.Names("type_version").RefersToRange = "Версия регулятора" Then
          If Abs(wsSheet.cells(lngI, lngJ) - wsSheet.cells(lngI + 1, lngJ) * wsSheet.cells(lngI + 2, lngJ)) > 0.01 Then
            modProvGeneralProc.Add_Hyperlink wsSheet.cells(lngI, lngJ), wsSheet.cells(lngI + 1, lngJ).Resize(2), _
                                             "Пункт 3.2 должен быть равен произведению п.4 и п.5!", STR_KIND_ERROR
          End If
        End If
      Next lngJ
    End If
  Next lngI

End Sub


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

Sub OpenHyperlink()
  Dim rngTarget As Range
  Dim hprlHyperlink As Hyperlink
  Dim rngIndexRange As Range
  On Error GoTo ErrHandler
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Set rngTarget = Application.ActiveCell
  For Each rngIndexRange In Selection.cells
    If Len(CStr(rngIndexRange.MergeArea.cells(1, 1).Value)) > 0 And _
       rngIndexRange.MergeArea.Row = rngIndexRange.Row And _
       rngIndexRange.MergeArea.Column = rngIndexRange.Column Then
      modUsingAPIControlApplications.RunBrowser CStr(rngIndexRange.MergeArea.cells(1, 1).Value), 1, True
    End If
  Next rngIndexRange
  GoTo CleanUp
ErrHandler:
  GoTo CleanUp
CleanUp:
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Public Sub ChangeHyperlink()
  Dim rngTarget As Range
  Dim hprlHyperlink As Hyperlink
  On Error GoTo ErrHandler
  Set rngTarget = Application.ActiveCell
  If rngTarget.Locked = False Then
    rngTarget = "ссылка на документ"
  End If
  GoTo CleanUp
ErrHandler:
  GoTo CleanUp
CleanUp:
End Sub

Public Sub DeleteHyperlink()
  Dim rngTarget As Range
  Dim intrrTargetFont As Interior
  Dim hprlHyperlink As Hyperlink
  Dim rngIndexRange As Range
  On Error GoTo ErrHandler
  Set rngTarget = Application.ActiveCell
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  For Each rngIndexRange In Selection.cells
    If rngIndexRange.MergeArea.Locked = False And _
       rngIndexRange.MergeArea.Row = rngIndexRange.Row And _
       rngIndexRange.MergeArea.Column = rngIndexRange.Column Then
      rngIndexRange.MergeArea.ClearContents
    End If
  Next rngIndexRange
  GoTo CleanUp
ErrHandler:
  GoTo CleanUp
CleanUp:
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

'Public Sub AddHyperlink()
'  Dim rngTarget As Range
'  On Error GoTo ErrHandler
'  Set rngTarget = Application.ActiveCell
'  If rngTarget.MergeArea.Locked = False Then
'    frmAddHyperlink.Show
'  End If
'  GoTo CleanUp
'ErrHandler:
'  GoTo CleanUp
'CleanUp:
'End Sub

Public Sub TransformToHyperlink()
  Dim rngTarget As Range
  Dim intrrTargetFont As Interior
  Dim hprlHyperlink As Hyperlink
  Dim rngIndexRange As Range
  On Error GoTo ErrHandler
  Set rngTarget = Application.ActiveCell
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  For Each rngIndexRange In Selection.cells
    If rngIndexRange.MergeArea.Locked = False And _
       rngIndexRange.MergeArea.Row = rngIndexRange.Row And _
       rngIndexRange.MergeArea.Column = rngIndexRange.Column Then
      '      If CheckHyperlink(rngIndexRange.Value) = True Then
      CreateHyperLink rngIndexRange
      '      End If
    End If
  Next rngIndexRange
  GoTo CleanUp
ErrHandler:
  GoTo CleanUp
CleanUp:
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub

Public Sub CreateHyperLink(ByVal rngTarget As Range)
  ActiveSheet.Hyperlinks.Add Anchor:=rngTarget, _
                             Address:=rngTarget.Value, _
                             SubAddress:="", _
                             ScreenTip:="Перейти по ссылке", _
                             TextToDisplay:=rngTarget.Value
End Sub

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

Public Sub CreateDopPriznList()
  Dim lngRow As Variant
  
  [dop_priznak_list].cells(1, 1).name = "dop_priznak_list"
  
  Set frmProgressForm = Try_Show_Message_Window(vbDefaultButton1, "Обновление списка дополнительных признаков...")
  modReestr.UpdateDopPrizn
  frmProgressForm.Hide
  Set frmProgressForm = Nothing

  If IsNameExists(ThisWorkbook, "DOP_PRIZNAK_RANGE") Then
    lngRow = 1
    Do While [DOP_PRIZNAK_RANGE].cells(lngRow, 1) <> ""
      If [DOP_PRIZNAK_RANGE].cells(lngRow, 1) = [inn] And [DOP_PRIZNAK_RANGE].cells(lngRow, 2) = [kpp] Then
        [dop_priznak_list].cells([dop_priznak_list].Rows.Count + 1).Value = [DOP_PRIZNAK_RANGE].cells(lngRow, 4)
        [dop_priznak_list].Resize([dop_priznak_list].Rows.Count + 1).name = "dop_priznak_list"
      End If
      lngRow = lngRow + 1
    Loop
  End If
End Sub

Public Sub Worksheet_Change_Handler(ByVal Target As Range)
  Dim Updater As clsUpdater
  Dim lngRow As Long
  Dim ISect As Range

  On Error GoTo ErrHandler

  ' ВЫБОР МР
  Set ISect = Application.Intersect(Target, List01.Range("List01_mr_column"))
  If Not ISect Is Nothing Then
    Dim rngFind As Range

    Set Updater = clsUpdaterInit(List01)

    Target.Offset(0, 1).Value = ""
    Target.Offset(0, 2).Value = ""
    Set rngFind = ThisWorkbook.Names("MR_LIST").RefersToRange.Find(Target.cells(1, 1).Value, lookat:=xlWhole)
    If rngFind Is Nothing Then
      With Target.Offset(0, 1)
        .Validation.Delete
        .Interior.ColorIndex = xlNone
        .Locked = True
      End With
      modCheckCyan.DelCheck Target.Offset(0, 1)
    Else
      With Target.Offset(0, 1).MergeArea.Validation
        .Delete
        .Add Type:=xlValidateList, _
             AlertStyle:=xlValidAlertStop, _
             Operator:=xlBetween, _
             Formula1:="=" & rngFind.Offset(0, 1).Value
        .IgnoreBlank = False
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = STR_MSGBOX_WARNING_TITLE
        .InputMessage = ""
        .ErrorMessage = "Пожалуйста, выберите МО из списка!"
        .ShowInput = True
        .ShowError = True
      End With
      With Target.Offset(0, 1).MergeArea
        .Interior.ColorIndex = colorCyan
        .Locked = False
        .Activate
      End With
      modCheckCyan.AddCheck Target.Offset(0, 1)
      If ThisWorkbook.Names(rngFind.Offset(0, 1).Value).RefersToRange.Rows.Count = 1 Then
        Target.Offset(0, 1).Value = ThisWorkbook.Names(rngFind.Offset(0, 1).Value).RefersToRange.Value
        Target.Offset(0, 2).Value = ThisWorkbook.Names(rngFind.Offset(0, 1).Value).RefersToRange.Offset(0, 1).Value
        Target.Activate
      End If
    End If
    GoTo CleanUp
  End If

  'выбор МО
  If Not Application.Intersect(List01.Range("List01_mo_column"), Target) Is Nothing Then
    Set Updater = clsUpdaterInit(List01)

    On Error Resume Next
    Set rngFind = ThisWorkbook.Names(Mid(Target.Validation.Formula1, 2)).RefersToRange.Find(Target.cells(1, 1).Value, lookat:=xlWhole)
    If rngFind Is Nothing Then
      Target.Offset(0, 1).Value = ""
    Else
      Target.Offset(0, 1).Value = rngFind.Offset(0, 1).Value
    End If
    GoTo CleanUp
  End If

  Exit Sub

ErrHandler:

CleanUp:
End Sub

Public Sub Worksheet_FollowHyperlink_Handler(ByVal Target As Hyperlink)

End Sub

Public Sub Worksheet_SelectionChange_Handler(ByVal Target As Range)

End Sub

Public Sub Worksheet_BeforeDoubleClick_Handler(ByVal Target As Range, Cancel As Boolean, Optional blnManual As Boolean = True)
  Dim Updater As clsUpdater
  Dim wsSheet As Worksheet
  Dim lngRow As Long, lngCol As Long, lngI As Long
  Dim rngCell As Range
  On Error GoTo ErrDblClick

  Set wsSheet = Target.Parent
  lngRow = Target.Row
  lngCol = Target.Column

  If lngRow = wsSheet.Range("pIns_List01").Row And _
     lngCol = wsSheet.Range("pIns_List01").Column And _
     Len(Target.cells(1, 1).Value2) > 0 Then
    Cancel = True
    Set Updater = New clsUpdater
    Updater.AddWS wsSheet
    modHyp.InsertRangeWithEt Target, "et_List01_tariff", False, lngCol - 2
    GoTo EndDblClick

  ElseIf lngCol = wsSheet.Range("pIns_List01_mo").Column And _
         Target.cells(1, 1).Value2 = "Добавить МО" Then
    Cancel = True
    frmAskCount.Show
    If modGlobals.lngAddCount > 0 Then
      Set Updater = New clsUpdater
      Updater.AddWS wsSheet
      modHyp.InsertRangeWithEt Target, "et_List01_mo", False, lngCol - 2, , , , lngAddCount
    End If
    GoTo EndDblClick

  ElseIf Target.cells(1, 1).Value2 = "О" And lngCol = wsSheet.Range("pIns_List01").Column - 2 Then
    Cancel = True
    If MsgBox("Вы действительно хотите удалить тариф?", vbQuestion + vbYesNo) = vbYes Then
      Set Updater = New clsUpdater
      Updater.AddWS wsSheet
      modHyp.DeleteRange Target, True
    End If
    GoTo EndDblClick

  ElseIf Target.cells(1, 1).Value2 = "О" And lngCol = wsSheet.Range("pIns_List01_mo").Column - 2 Then
    Cancel = True
    Set Updater = New clsUpdater
    Updater.AddWS wsSheet
    modHyp.DeleteRange Target, False
    GoTo EndDblClick

  ElseIf isIntersect(Target.cells(1, 1), wsSheet.Range("List01_VDET")) And _
         Len(wsSheet.Range("pIns_" & wsSheet.CodeName).Value2) > 0 And _
         Target.cells(1, 1).Interior.ColorIndex = colorGreen Then
    Cancel = True

    modfrmActivity.VDET_TYPE = "HEAT"
    modfrmActivity.VDET_RESULT = Target.cells(1, 1).Value2
    frmActivity.Show vbModal
    If modGlobals.blnApplyFlag Then
      Set Updater = New clsUpdater
      Updater.AddWS wsSheet
      Target.cells(1, 1).Value = modfrmActivity.VDET_RESULT
    End If
    GoTo EndDblClick

  End If

  Exit Sub
ErrDblClick:
  MsgBox "Ошибка при обработке двойного клика", vbCritical

EndDblClick:
  If blnManual Then
    wsSheet.Activate
    wsSheet.cells(lngRow, lngCol).Select
  End If
End Sub

Function CheckList01() As Boolean
  Dim rngCell As Range
  Dim lngI As Long
  Dim col As New Collection
  
  On Error GoTo ErrHandler
  CheckList01 = False
  
  'проверяем есть ли тарифы
  If List01.Range("List01_work").Rows.Count = 2 Then
    MsgBox "Вы не указали ни одного тарифа!", vbExclamation
    Exit Function
  End If

  'проверяем все ли ячейки заполнены
  For Each rngCell In List01.Range("List01_work")
    If rngCell.MergeArea.cells(1, 1).Address = rngCell.Address And _
       (rngCell.Interior.ColorIndex = colorCyan Or _
        rngCell.Interior.ColorIndex = colorGreen) And _
        rngCell.Value2 = "" Then
      rngCell.Select
      MsgBox "Необходимо указать значение", vbExclamation
      Exit Function
    End If
  Next rngCell
  
  'проеряем уникальность МО в приеделах тарифа
  For lngI = [List01_NUM].Row + 1 To [pIns_List01].Row - 1
    If Not AddToCollection(col, List01.cells(lngI, [List01_NUM].Column).MergeArea.cells(1, 1) & List01.cells(lngI, [List01_mo_column].Column + 1)) Then
      List01.cells(lngI, [List01_mr_column].Column).Resize(, 3).Select
      MsgBox "Данное МО указано несколько раз в пределах одного тарифа", vbExclamation
      Exit Function
    End If
  Next lngI
  
  CheckList01 = True
  
  Exit Function
  
ErrHandler:
  MsgBox "Ошибка при проверке листа тарифы", vbCritical
End Function

Public Sub List01_cmdNext()
  Dim Updater As clsUpdater
  Dim rngCell As Range
  Dim lngTariffCount As Long
  Dim lngI As Long, lngCol As Long, lngCount As Long, lngRow As Long, lngRow2 As Long
  Dim nmName As name, nmEt As name
  Dim wsSheet As Worksheet

  On Error GoTo ErrHandler
  
  Application.Calculate
  
  If Not CheckList01 Then Exit Sub

  If MsgBox("Вы уверены, что хотите продолжить заполнение? Дальнейшее измение листа '" & List01.name & "' станет невозможно!", vbQuestion + vbYesNo) = vbNo Then Exit Sub

  'если всё ок то блокируем лист тарифы
  Set Updater = New clsUpdater
  Set frmProgressForm = Try_Show_Message_Window(vbDefaultButton1, "Формирование листов...")
  Updater.AddWB ThisWorkbook

  List01.Range("pIns_List01") = ""
  List01.UsedRange.Replace "О", "", lookat:=xlWhole
  List01.UsedRange.Replace "Добавить МО", "", lookat:=xlWhole

  'Тарифы
  For Each rngCell In List01.Range("List01_work")
    If rngCell.MergeArea.cells(1, 1).Address = rngCell.Address And _
       rngCell.Interior.ColorIndex = colorCyan Then
      rngCell.MergeArea.Locked = True
      rngCell.MergeArea.Interior.ColorIndex = colorGreen
    End If
  Next rngCell
  
  List01.Shapes("cmdNext").Visible = msoFalse

  frmProgressForm.ProgressTick

  'исправялем цвета
  CorrectColorsViaFormuls et_union

  'добавляем блоки с тарифами на все листы
  lngTariffCount = List01.Range("pIns_List01").Offset(-1, -1).MergeArea.cells(1, 1)

  AddTARIF List03, "pIns_List03_rqt", "et_List03_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  AddTARIF List04, "pIns_List04_rqt", "et_List04_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  AddTARIF List06, "pIns_List06_rqt", "et_List06_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  AddTARIF List07, "pIns_List07_rqt1", "et_List07_rqt1", lngTariffCount
  AddTARIF List07, "pIns_List07_rqt2", "et_List07_rqt2", lngTariffCount
  frmProgressForm.ProgressTick
  AddTARIF List08, "pIns_List08_rqt1", "et_List08_rqt1", lngTariffCount
  AddTARIF List08, "pIns_List08_rqt2", "et_List08_rqt2", lngTariffCount
  frmProgressForm.ProgressTick
  AddTARIF List22, "pIns_List22_rqt", "et_List22_rqt", lngTariffCount
  'ФОТ
  frmProgressForm.ProgressTick
  AddTARIF List18, "pIns_List18_rqt", "et_List18_rqt", lngTariffCount
  'Капремонт
  frmProgressForm.ProgressTick
  AddTARIF List16, "pIns_List16_rqt", "et_List16_rqt", lngTariffCount
  'Текремонт
  frmProgressForm.ProgressTick
  AddTARIF List17, "pIns_List17_rqt", "et_List17_rqt", lngTariffCount
  'ОПР
  frmProgressForm.ProgressTick
  AddTARIF List09, "pIns_List09_rqt1", "et_List09_rqt1", lngTariffCount
  AddTARIF List09, "pIns_List09_rqt2", "et_List09_rqt2", lngTariffCount
  AddTARIF List09, "pIns_List09_rqt3", "et_List09_rqt3", lngTariffCount
  'ОХР
  frmProgressForm.ProgressTick
  AddTARIF List10, "pIns_List10_rqt1", "et_List10_rqt1", lngTariffCount
  AddTARIF List10, "pIns_List10_rqt2", "et_List10_rqt2", lngTariffCount
  AddTARIF List10, "pIns_List10_rqt3", "et_List10_rqt3", lngTariffCount
  
  frmProgressForm.ProgressTick
  AddTARIF List11, "pIns_List11_rqt", "et_List11_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  AddTARIF List12, "pIns_List12_rqt", "et_List12_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  AddTARIF List13, "pIns_List13_rqt", "et_List13_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  AddTARIF List14, "pIns_List14_rqt", "et_List14_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  AddTARIF List15, "pIns_List15_rqt", "et_List15_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  'УЕ
  AddTARIF List20, "pIns_List20_rqt", "et_List20_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  'Корр Факт
  AddTARIF List23, "pIns_List23_rqt", "et_List23_rqt", lngTariffCount
  frmProgressForm.ProgressTick
  
  'листы ФАС
  AddTARIFwithMO List30
  frmProgressForm.ProgressTick
  AddTARIFwithMO List31
  frmProgressForm.ProgressTick
  AddTARIFwithMO List32
  frmProgressForm.ProgressTick
  AddTARIFwithMO List33
  frmProgressForm.ProgressTick
  AddTARIF List34, "pIns_List34_rqt", "et_List34_rqt", lngTariffCount, "COL"
  frmProgressForm.ProgressTick
  AddTARIF List35, "pIns_List35_rqt", "et_List35_rqt", lngTariffCount, "COL"
  frmProgressForm.ProgressTick


  'Лист П.4.4
  'для заявок у которых НУР=да нужно добавить все котельные, остальные в целом по заявке
  lngI = 2
  Do While lngI < [List01_NUM].Rows.Count - 1
    frmProgressForm.ProgressTick
    If [List01_VDET].cells(lngI) Like "*производство*" Then
      lngCol = List05.Range("pIns_List05_rqt").Column
      If LCase([List01_NUR].cells(lngI)) = "да" Then
        'считаем кол-во котельных
        lngCount = WorksheetFunction.CountIfs(List03.Columns(1), [List01_NUM].cells(lngI), List03.Columns(5), "ТИ*")
        If lngCount > 0 Then
          ThisWorkbook.Names("et_List05_rqt").RefersToRange.Copy
          List05.Range("pIns_List05_rqt").Resize(, ThisWorkbook.Names("et_List05_rqt").RefersToRange.Columns.Count * lngCount).Insert
          'номер заявки
          List05.cells(1, lngCol).Resize(, ThisWorkbook.Names("et_List05_rqt").RefersToRange.Columns.Count * lngCount) = [List01_NUM].cells(lngI)
          'проставляем номера котельных
          lngRow = Application.Match([List01_NUM].cells(lngI), List03.Columns(1), 0) + 1
          Do While List03.cells(lngRow, 1) = [List01_NUM].cells(lngI)
            If List03.cells(lngRow, 5) Like "ТИ*" Then
              List05.cells(6, lngCol) = List03.cells(lngRow, 4)
              lngCol = lngCol + ThisWorkbook.Names("et_List05_rqt").RefersToRange.Columns.Count
            End If
            lngRow = lngRow + 1
          Loop
        End If
      Else
        'просто всатвляем заявку
        ThisWorkbook.Names("et_List05_rqt").RefersToRange.Copy
        List05.Range("pIns_List05_rqt").Insert
        'номер заявки
        List05.cells(1, lngCol) = [List01_NUM].cells(lngI)
      End If
    End If
    lngI = lngI + [List01_NUM].cells(lngI).MergeArea.Rows.Count
  Loop

  'пробегаем по всем диапазонам вида ListXX_vis_flags и ОЧИЩАЕМ ненужные строки/столбцы
  Application.Calculate
  For Each nmName In ThisWorkbook.Names
    If nmName.name Like "List*_vis_flags*" Or nmName.name Like "List*_vis_reg_flags*" Then
      For Each rngCell In nmName.RefersToRange
        If rngCell.Value <> "" And Not rngCell.Value Then
          If nmName.RefersToRange.Rows.Count = 1 Then
…