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

    'проверка голубых
    modProvGeneralProc.CheckCyanCells wbBook.Worksheets("modCheckCyan")
  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("god"), _
                       wsSheet.Range("type_flag"), _
                       wsSheet.Range("fil_flag"), _
                       wsSheet.Range("org"), _
                       wsSheet.Range("inn"), _
                       wsSheet.Range("kpp"), _
                       wsSheet.Range("mr"), _
                       wsSheet.Range("mo"), _
                       wsSheet.Range("oktmo"), _
                       wsSheet.Range("dolj_lico"))

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

  For Each rngCell In rngRange.cells
    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
  Next rngCell


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 Worksheet_Change_Handler(ByVal Target As Range)
  Dim Updater As clsUpdater
  Dim wsSheet As Variant
  Dim rngFind As Range
  On Error GoTo End_Change

  Set wsSheet = Target.Parent

  'документы
  If Not Application.Intersect(Target, wsSheet.Range(wsSheet.CodeName & "_url_column")) Is Nothing And _
     Target.Columns.Count = 1 Then
    Set Updater = New clsUpdater
    Updater.AddWS wsSheet

    If Target.cells(1, 1).Value2 = "ссылка на документ" Then
      frmURL.Show
      If modGlobals.blnApplyFlag Then
        Target.cells(1, 1).Value = modGlobals.strFormOut
      Else
        Target.cells(1, 1).Value = ""
      End If
    ElseIf Target.cells(1, 1).Value2 = "отсутствует" Then
      Dim strTemp As String
      strTemp = Application.InputBox("Введите причину отсутствия документа:", "Причина", , , , , , 2)
      If Trim(strTemp) <> "" And strTemp <> "False" Then
        Target.cells(1, 1).Value = "Отсутствует по причине: " & strTemp
      Else
        Target.cells(1, 1).Value = ""
      End If
    End If
    GoTo End_Change
  End If

  Exit Sub
End_Change:

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 Variant
  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 Target.cells(1, 1).Value2 = "Добавить документ" And wsSheet.cells(lngRow, 1).Value2 = "t" And lngCol = 5 Then
    Cancel = True
    Set Updater = New clsUpdater
    Updater.AddWS wsSheet

    If blnManual Then frmAskCount.Show
    If modGlobals.lngAddCount <> 0 Then
      modHyp.InsertRangeWithEt Target, "et_List01_1", blnManual, lngCol - 2, , , , modGlobals.lngAddCount
      If Not blnManual Then
        With Target.Offset(-modGlobals.lngAddCount * ThisWorkbook.Names("et_List01_1").RefersToRange.Rows.Count, 0).Resize(modGlobals.lngAddCount * ThisWorkbook.Names("et_List01_1").RefersToRange.Rows.Count, 1)
          .Locked = True
          .Interior.ColorIndex = xlNone
        End With
      End If
    End If

    GoTo EndDblClick
    
  ElseIf Target.cells(1, 1).Value2 = "Добавить ссылку на часть документа" And wsSheet.cells(lngRow, 1).Value2 = "t" And lngCol = 8 Then
    Cancel = True
    Set Updater = New clsUpdater
    Updater.AddWS wsSheet

    frmAskCount.Show
    If modGlobals.lngAddCount <> 0 Then
      modHyp.InsertRangeWithEt Target, "et_List01_2", , lngCol - 2, , , , modGlobals.lngAddCount
    End If

    GoTo EndDblClick

  ElseIf Target.cells(1, 1).Value2 = "О" And lngCol = 3 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 = 6 Then
    Cancel = True
    If MsgBox("Вы действительно хотите удалить часть документа?", vbQuestion + vbYesNo) = vbYes Then
      Set Updater = New clsUpdater
      Updater.AddWS wsSheet
      modHyp.DeleteRange Target, False
    End If

    GoTo EndDblClick

  ElseIf Target.cells(1, 1).Value2 Like "http*" And lngCol = wsSheet.Range(wsSheet.CodeName & "_url_column").Column Then
    On Error Resume Next
    Cancel = True
    If blnManual Then ThisWorkbook.FollowHyperlink Target.cells(1, 1).Value2
    GoTo EndDblClick
  End If

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

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

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
Private strParent 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

Public Property Let Parent(p As String)
  strParent = p
End Property

Public Property Get Parent() As String
  Parent = strParent
End Property

Private Sub ptb_Change()
  ThisWorkbook.Worksheets(strParent).FilterRange
End Sub

Attribute VB_Name = "modScrolling"
Option Explicit

#If Win64 Then
Private Type POINTAPI
  XY As LongLong
End Type
#Else
Private Type POINTAPI
  X As Long
  Y As Long
End Type
#End If

Private Type MSLLHOOKSTRUCT
  pt As POINTAPI
  mouseData As Long
  flags As Long
  tome As Long
  dwExtraInfo As Long
End Type

#If VBA7 Then

  Public Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Public Declare PtrSafe Function GetFocus Lib "User32" () As Long

  Private Declare PtrSafe Function SetWindowsHookEx Lib "User32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As Long
  Private Declare PtrSafe Function CallNextHookEx Lib "User32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
  Private Declare PtrSafe Function UnhookWindowsHookEx Lib "User32" (ByVal hHook As Long) As Long

  #If Win64 Then
    Private Declare PtrSafe Function WindowFromPoint Lib "User32" (ByVal xPoint As LongLong) As LongPtr
    Public 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 PtrSafe Function WindowFromPoint Lib "User32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
  #End If

#Else

  Public Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  Public Declare Function GetFocus Lib "User32" () As Long

  Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  Private Declare Function SetWindowsHookEx Lib "User32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
  Private Declare Function CallNextHookEx Lib "User32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
  Private Declare Function UnhookWindowsHookEx Lib "User32" (ByVal hHook As Long) As Long
  Private Declare Function WindowFromPoint Lib "User32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
  Public 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


Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private mLngMouseHook As Long
Private colControls As Collection

' ======================================================
' ======================================================

Public Sub Hook(frmUserForm As UserForm)
  Dim blnEventsValue As Boolean
  blnEventsValue = Application.EnableEvents
  If mLngMouseHook = 0 Then
    Dim ctrl As MSForms.Control
    Set colControls = New Collection

    Application.EnableEvents = False
    On Error Resume Next
    For Each ctrl In frmUserForm.Controls
      If TypeName(ctrl) = "ListBox" Or TypeName(ctrl) = "ComboBox" Then
        ctrl.SetFocus
        colControls.Add ctrl, CStr(GetFocus)
      End If
    Next ctrl
    Application.EnableEvents = blnEventsValue

    #If VBA7 Then
      mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.HinstancePtr, 0)
    #Else
      mLngMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
    #End If
  End If
End Sub

Public Sub UnHook()
  If mLngMouseHook <> 0 Then
    UnhookWindowsHookEx mLngMouseHook
    mLngMouseHook = 0
  End If
End Sub

Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MSLLHOOKSTRUCT) As Long
  Dim mCtl As Variant

  On Error GoTo ErrHandler

  If nCode = HC_ACTION Then

    If wParam = WM_MOUSEWHEEL Then

      #If Win64 Then
        Set mCtl = colControls(CStr(WindowFromPoint(lParam.pt.XY)))
      #Else
        Set mCtl = colControls(CStr(WindowFromPoint(lParam.pt.X, lParam.pt.Y)))
      #End If

      If Not mCtl Is Nothing Then
        If Not mCtl.Locked And mCtl.Enabled Then
          If lParam.mouseData > 0 Then
            If mCtl.ListIndex > 0 Then mCtl.ListIndex = mCtl.ListIndex - 1
          Else
            mCtl.ListIndex = mCtl.ListIndex + 1
          End If
        End If
      End If

    End If

  End If

  MouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)

ErrHandler:
End Function

Public Function blnIs_UserForm_Loaded(ByVal strFormName As String) As Boolean

  Dim lngICounter As Long

  blnIs_UserForm_Loaded = False
  For lngICounter = 0 To UserForms.Count - 1
    If UserForms(lngICounter).name = strFormName Then
      blnIs_UserForm_Loaded = True
      Exit Function
    End If
  Next lngICounter

End Function

Public Sub Close_UserForm_Loaded()

  Dim lngICounter As Long

  For lngICounter = 0 To UserForms.Count - 1
    Unload UserForms(lngICounter)
  Next lngICounter

End Sub




Attribute VB_Name = "modServiceModule"
Option Explicit

Private Const MODE_UNDEFINED_PROTECTION_ENABLED As Long = 0
Private Const TEST_MODE_PROTECTION_ENABLED As Long = 1
Private Const TEST_MODE_PROTECTION_DISABLED As Long = 2
Private Const RELEASE_MODE = 3

' Снять защиту с листа
Public Sub UNPROTECT_SHEET(ByRef wsSheet As Variant, _
                           Optional ByVal strPassword As String = gPASSWORD)
  wsSheet.Unprotect Password:=strPassword
End Sub

' Защитить лист
Public Sub PROTECT_SHEET(ByRef wsSheet As Worksheet, _
                         Optional ByVal blnDrawingObject As Boolean = True, _
                         Optional ByVal strPassword As String = gPASSWORD, _
                         Optional ByVal blnEnableAutoFilter As Boolean = True)

  On Error GoTo ErrHandler

  If wsSheet Is Nothing Then GoTo ErrHandler

  Dim wbBook As Workbook
  Dim lngTemplateOperationMode As Long

  Set wbBook = wsSheet.Parent

  lngTemplateOperationMode = CLng(varGetDocumentProperty(wbBook, "TemplateOperationMode"))
  If lngTemplateOperationMode = MODE_UNDEFINED_PROTECTION_ENABLED Or _
     lngTemplateOperationMode = RELEASE_MODE Or _
     lngTemplateOperationMode = TEST_MODE_PROTECTION_ENABLED Then
    wsSheet.Protect Password:=strPassword, DrawingObjects:=blnDrawingObject, _
                    Contents:=True, Scenarios:=True, _
                    AllowFormattingColumns:=True, AllowFormattingRows:=True, _
                    AllowFiltering:=blnEnableAutoFilter
  End If
ErrHandler:
End Sub

' Прочитать свойство документа
Public Function varGetDocumentProperty(ByRef wbBook As Workbook, _
                                       ByVal strName As String) As Variant

  On Error GoTo ErrHandler

  If wbBook Is Nothing Then GoTo ErrHandler

  If strName = "Title" Or strName = "Subject" Or strName = "Company" Or strName = "Comments" Then
    varGetDocumentProperty = wbBook.BuiltinDocumentProperties(strName).Value
  Else
    varGetDocumentProperty = wbBook.CustomDocumentProperties(strName).Value
  End If

  GoTo CleanUp

ErrHandler:
  varGetDocumentProperty = ""
CleanUp:
End Function

' Проверить наличие свойства документа
Public Function blnIsDocumentProperty(ByVal wbBook As Workbook, _
                                      ByVal strPropertyName As String) As Boolean

  On Error GoTo ErrHandler

  Dim varValue As Variant

  blnIsDocumentProperty = False

  If wbBook Is Nothing Or _
     Len(strPropertyName) = 0 Then
    GoTo ErrHandler
  End If

  If strPropertyName = "Title" Or strPropertyName = "Subject" Or _
     strPropertyName = "Company" Or strPropertyName = "Comments" Then
    varValue = wbBook.BuiltinDocumentProperties(strPropertyName).Value
    blnIsDocumentProperty = True
  Else
    varValue = wbBook.CustomDocumentProperties(strPropertyName).Value
    blnIsDocumentProperty = True
  End If

  GoTo CleanUp

ErrHandler:
  blnIsDocumentProperty = False
CleanUp:
End Function

' Проверяет существование листа с именем SheetName в книге wb
Function SheetExists(SheetName As String, wb As Workbook) As Boolean
  On Error GoTo ErrHandler

  Dim ws As Worksheet
  SheetExists = False
  For Each ws In wb.Worksheets
    If CStr(ws.name) = SheetName Then
      SheetExists = True
      Exit Function
    End If
  Next

ErrHandler:
  SheetExists = False
End Function

' Проверяет существование именованного диапазона с именем strName в книге wbBook
Public Function IsNameExists(wbBook As Workbook, strName As String) As Boolean
  On Error GoTo ErrHandler
  Dim rngTemp As Range
  IsNameExists = True
…