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

Dim SErr As Boolean

Private Const SAVE_STATUS_CRITICAL_IMPACT_WARNING As String = "Шаблон будет сохранен, но НЕ БУДЕТ принят к рассмотрению из-за невыполнения ОБЯЗАТЕЛЬНЫХ условий! См. лист 'Проверка'!"
Private Const SAVE_STATUS_SUCCESS As String = "Шаблон готов к сохранению без замечаний"
Private Const SAVE_STATUS_LOW_IMPACT_WARNING As String = "Шаблон будет принят к рассмотрению, но обратите внимание НЕВЫПОЛНЕНИЕ ПРЕДУПРЕДИТЕЛЬНЫХ условий на листе 'Проверка'"
Private Const SAVE_MESSAGE_TITLE As String = "Результат проверки"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Application.Calculate

    Dim wsSheet As Worksheet

    Set wb = Application.ThisWorkbook
    Set wsSheet = wb.ActiveSheet

    If Len(CStr(Me.Names("region_name").RefersToRange.Value)) > 0 Then
        modPROV.WarningsBeforeSaving Me

        If modPROV.gintCriticalImpactWarningsCounter > 0 Then
          Me.CustomDocumentProperties("Status") = 1 'ТРАНС
          MsgBox SAVE_STATUS_CRITICAL_IMPACT_WARNING, vbCritical + vbOKOnly, SAVE_MESSAGE_TITLE
          Me.Worksheets("Проверка").Activate
        ElseIf modPROV.gintLowImpactWarningsCounter > 0 Then
          Me.CustomDocumentProperties("Status") = 1 'ТРАНС
          MsgBox SAVE_STATUS_LOW_IMPACT_WARNING, vbExclamation + vbOKOnly, SAVE_MESSAGE_TITLE
          Me.Worksheets("Проверка").Activate
        Else 'ТРАНС
          Me.CustomDocumentProperties("Status") = 2 'ТРАНС
          MsgBox SAVE_STATUS_SUCCESS, vbInformation, SAVE_MESSAGE_TITLE
          wsSheet.Activate
        End If

    End If

    On Error GoTo ErrHandler

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

    GoTo cleanUp

ErrHandler:
    MsgBox "При сохранении шаблона произошла ошибка: '" & Err.Description & "'!", _
           vbOKOnly + vbCritical, _
           STR_MSGBOX_WARNING_TITLE
    GoTo cleanUp

cleanUp:


End Sub

Private Sub Workbook_Open()

  On Error GoTo ErrHandler

  Application.Calculation = xlCalculationAutomatic ' чтобы пересчет формул осуществлялся автоматически
  Application.ReferenceStyle = xlA1 ' стиль ссылок - A1
  ThisWorkbook.CustomDocumentProperties("Status") = 1 'ТРАНС

  Dim wsSheet As Worksheet
  Dim wsActiveSheet As Worksheet
  Dim wsTitleSheet As Worksheet
  Dim wbBook As Workbook

  Set wbBook = Application.ThisWorkbook
  Set wsActiveSheet = wbBook.ActiveSheet

    ' Проверить необходимые для работы диапазоны
    If modServiceModule.IsNameExists(wbBook, "region_name") = False Or _
       modServiceModule.IsNameExists(wbBook, "strPublication") = False Or _
       modServiceModule.IsNameExists(wbBook, "flag_ipr") = False Then

         MsgBox "Повреждены рабочие диапазоны на листе '" & gstrMainSheetName & "': '" & Err.Description & "'!", _
                vbOKOnly + vbCritical, _
                STR_MSGBOX_WARNING_TITLE
      GoTo cleanUp
    End If

  If Len(CStr(wbBook.Names("region_name").RefersToRange.cells(1, 1).Value)) = 0 Then

    For Each wsSheet In wbBook.Worksheets
      If wsSheet.Visible = True Then
        If wsSheet.Tab.ColorIndex = colorPaleBlue Then
          wsSheet.Visible = xlSheetVeryHidden
        End If
      End If
    Next wsSheet

  Else
    Set wsTitleSheet = wbBook.Names("region_name").RefersToRange.parent
    wsTitleSheet.Activate
    wsTitleSheet.Range("strPublication").Value = wsTitleSheet.Range("strPublication").Value
    wsTitleSheet.Range("flag_ipr").cells(1, 1).Value = wsTitleSheet.Range("flag_ipr").cells(1, 1).Value

    wsActiveSheet.Activate

  End If

  ' Для обновления
  For Each wsSheet In wbBook.Worksheets
    If wsSheet.CodeName = "SHEET_UPDATE_INSTRUCTION" Then
      If wbBook.Worksheets("Обновление").chkGetUpdates.Value = True Then
        modUpdTemplMain.Check_Update_Execution Me
      End If
    End If
  Next wsSheet
  GoTo cleanUp

ErrHandler:
    MsgBox "При открытии шаблона произошла ошибка: '" & Err.Description & "'!", _
           vbOKOnly + vbCritical, _
           STR_MSGBOX_WARNING_TITLE
    GoTo cleanUp

cleanUp:

End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)
  
  Dim wbBook As Workbook
  Dim wsSheet As Worksheet
  
  Dim vbResult As VbMsgBoxResult
  
  Dim rngRange As Range
  Dim rngCell As Range
  
  Dim strCenterFooter As String
  Dim strNameColumn As String
  Dim strNameRow As String
  
  Dim intCounter As Integer
  Dim intCounter2 As Integer
  Dim intCounterEndRow As Integer
   
  Set wbBook = Application.ThisWorkbook

  vbResult = MsgBox("Установить для данного шаблона колонтитулы на листах?", vbYesNo + vbQuestion, "Подтверждение!")
  If vbResult = vbYes Then
    strCenterFooter = _
                     "&""Tahoma,обычный""&8" & Chr(10) & "" & _
                     "Документ распечатан из отчетной формы ФГИС ЕИАС ФСТ России: " & _
                     wbBook.CustomDocumentProperties("Version") & _
                     ", &D" & " г. "
                     
    If Len(Trim(wbBook.Names("responsible_post").RefersToRange.Value)) <> 0 Or _
       Len(Trim(wbBook.Names("responsible_FIO").RefersToRange.Value)) <> 0 Then
     strCenterFooter = strCenterFooter & _
                       "Ответственный за заполнение формы: " & _
                       wbBook.Names("responsible_post").RefersToRange.Value & " " & _
                       wbBook.Names("responsible_FIO").RefersToRange.Value  '& Chr(10)
    End If
  Else
    strCenterFooter = ""
  End If
    
  For Each wsSheet In wbBook.Sheets
    If wsSheet.Tab.ColorIndex <> modGlobals.colorLightBrown Then
      With wsSheet
             .PageSetup.CenterFooter = strCenterFooter
      End With
    End If
  Next wsSheet
    
  ' скрываем столбцы и строки
  strNameColumn = "hide_me_column_"
  strNameRow = "hide_me_row_"
  For intCounter = 1 To 5
    If intCounter = 1 Then
         intCounterEndRow = 2
    ElseIf intCounter = 3 Or intCounter = 4 Or _
           intCounter = 5 Then
         intCounterEndRow = 1
    Else
         intCounterEndRow = 3
    End If
    
    ' столбцы
    For intCounter2 = 1 To 2
      If modServiceModule.IsNameExists(wbBook, strNameColumn & CStr(intCounter) & "_" & CStr(intCounter2)) = True Then
        wbBook.Names(strNameColumn & CStr(intCounter) & "_" & CStr(intCounter2)).RefersToRange.EntireColumn.Hidden = True
      End If
    Next intCounter2
        
    ' строки
    For intCounter2 = 1 To intCounterEndRow
      If (intCounter2 = 2 And intCounter = 1) Or _
         intCounter = 4 Then
        If modServiceModule.IsNameExists(wbBook, strNameRow & CStr(intCounter) & "_" & CStr(intCounter2)) = True Then
          For Each rngCell In wbBook.Names(strNameRow & CStr(intCounter) & "_" & CStr(intCounter2)).RefersToRange.Columns(9).cells
            If InStr(1, rngCell.Value, "Добавить ") = 1 Or _
               InStr(1, rngCell.Offset(0, -2).cells(1, 1).Value, "Добавить ") = 1 Or _
               InStr(1, rngCell.Offset(0, -3).cells(1, 1).Value, "Добавить ") = 1 Then
              rngCell.EntireRow.Hidden = True
            End If
          Next rngCell
        End If
      Else
        If modServiceModule.IsNameExists(wbBook, strNameRow & CStr(intCounter) & "_" & CStr(intCounter2)) = True Then
          wbBook.Names(strNameRow & CStr(intCounter) & "_" & CStr(intCounter2)).RefersToRange.EntireRow.Hidden = True
        End If
      End If
    Next intCounter2
  Next intCounter
    
cleanUp:
  Application.OnTime Now + TimeValue("00:00:01"), "modServiceModule.WorkbookAfterPrint"

End Sub


Attribute VB_Name = "modChange"
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 WsInstrChange(Target As Range)
  If Target.Interior.ColorIndex = colorYellow Then
    modServiceModule.UNPROTECT_SHEET Target.parent
    Target.Font.Size = 9
    Target.Font.name = "Tahoma"
    Application.ThisWorkbook.Sheets(gstrInstructionSheetName).cmdApplyContactChanges.Enabled = True
    Application.ThisWorkbook.Sheets(gstrInstructionSheetName).cmdApplyContactChanges.Visible = True
    modServiceModule.PROTECT_SHEET Target.parent, True
  End If
End Sub

' для стандартных листов
Public Sub WsGeneralChange(Target As Range)
  On Error GoTo ErrWsGeneralChange
  
  Dim wbBook As Workbook
  
  Dim wsSheet As Worksheet
    
  Dim intNRow As Integer
  Dim intNColumn As Integer
  Dim intRowHeight As Integer
  
  Dim rngCell As Range
  Dim rngRange As Range
  
  Dim ISect
    
  blnValueEnableEvents = Application.EnableEvents
  blnValueScreenUpdating = Application.ScreenUpdating
  
  Application.EnableEvents = False
  Application.ScreenUpdating = False

  Set wbBook = Me.parent
  Set wsSheet = Target.parent
    
  modServiceModule.UNPROTECT_SHEET wsSheet
  
  intNRow = Target.cells(1, 1).Row
  intNColumn = Target.cells(1, 1).Column
  
  If Target.cells(1, 1).Row > 6 Then
    If Target.MergeCells Then
      modServiceModule.AutoFitMergedCellRowHeight Target
    Else
      Target.cells(1, 1).EntireRow.AutoFit
      intRowHeight = Target.cells(1, 1).RowHeight
      If intRowHeight < 20 Then Target.cells(1, 1).RowHeight = 20
    End If
  End If
    
  modServiceModule.PROTECT_SHEET wsSheet, True

ErrWsGeneralChange:
  Debug.Print Err.Description
  GoTo cleanUp
  
cleanUp:
  Application.EnableEvents = blnValueEnableEvents
  Application.ScreenUpdating = blnValueScreenUpdating
  
End Sub


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

Private glngMRCOLUMN As Long     ' Номер колонки "МР"
Private glngMOCOLUMN As Long     ' Номер колонки "МО"
Private glngORGCOLUMN As Long    ' Номер колонки "ОРГАНИЗАЦИЯ"
Private glngCOLUMNSCOUNT As Long ' Количество колонок в ListBox

Public Sub chkFilterEnabled_Click_Handler()

  frmReestr.txtMRFilter.Enabled = frmReestr.chkFilterEnabled.Value
  frmReestr.txtMOFilter.Enabled = frmReestr.chkFilterEnabled.Value
  frmReestr.txtOrgFilter.Enabled = frmReestr.chkFilterEnabled.Value
  frmReestr.txtMRFilter.Value = vbNullString
  frmReestr.txtMOFilter.Value = vbNullString
  frmReestr.txtOrgFilter.Value = vbNullString
  If frmReestr.txtOrgFilter.Enabled = False Then
    If modServiceModule.IsNameExists(ThisWorkbook, modGlobals.STR_RANGE_NAME) = True Then
      frmReestr.ListReestr.RowSource = modGlobals.STR_RANGE_NAME
    End If
    frmReestr.txtMRFilter.BackColor = &H80000000
    frmReestr.txtMOFilter.BackColor = &H80000000
    frmReestr.txtOrgFilter.BackColor = &H80000000
  Else
    frmReestr.txtMRFilter.BackColor = &H80000005
    frmReestr.txtMOFilter.BackColor = &H80000005
    frmReestr.txtOrgFilter.BackColor = &H80000005
  End If

End Sub

Public Sub cmdOK_Click_Handler()

  On Error GoTo ErrHandler

  Dim wbBook As Workbook
  Dim wsSheet As Worksheet
  
  Dim lngNumber As Long
  
  lngNumber = frmReestr.ListReestr.ListIndex

  If lngNumber >= 0 Then
    
    Set wbBook = Application.ThisWorkbook
    Set wsSheet = wbBook.Sheets(gstrMainSheetName)

    wsSheet.Activate
    modServiceModule.UNPROTECT_SHEET wsSheet

    wsSheet.Range("org").cells(1, 1).Value = frmReestr.ListReestr.List(lngNumber, 4)
    wsSheet.Range("inn").Value = frmReestr.ListReestr.List(lngNumber, 5)
    wsSheet.Range("kpp").Value = frmReestr.ListReestr.List(lngNumber, 6)
    
    modServiceModule.PROTECT_SHEET wsSheet, False

    Unload frmReestr

  Else

    MsgBox "Не выбрана организация из списка!", vbCritical, modGlobals.STR_MSGBOX_WARNING_TITLE

  End If

  GoTo cleanUp

ErrHandler:
  Application.EnableEvents = True
  GoTo cleanUp
  
cleanUp:
End Sub

Public Sub ListReestr_Change_Handler()
  If frmReestr.ListReestr.ListIndex > -1 Then
    frmReestr.lblMirror = frmReestr.ListReestr.List(frmReestr.ListReestr.ListIndex, 4)
  Else
    frmReestr.lblMirror = vbNullString
  End If
End Sub

Public Sub txtMOFilter_Change_Handler()
  Filter_Change_Handler frmReestr.txtMRFilter.Text, frmReestr.txtMOFilter.Text, frmReestr.txtOrgFilter.Text
End Sub

Public Sub txtMRFilter_Change_Handler()
  Filter_Change_Handler frmReestr.txtMRFilter.Text, frmReestr.txtMOFilter.Text, frmReestr.txtOrgFilter.Text
End Sub

Public Sub txtOrgFilter_Change_Handler()
  Filter_Change_Handler frmReestr.txtMRFilter.Text, frmReestr.txtMOFilter.Text, frmReestr.txtOrgFilter.Text
End Sub

Public Sub Filter_Change_Handler(ByVal strMRPattern As String, _
                                 ByVal strMOPattern As String, _
                                 ByVal strOrgPattern As String)

  On Error GoTo ErrHandler

  Dim wbBook As Workbook
  Dim wsReestrOrg As Worksheet
  Dim wsReestrFiltered As Worksheet
  Dim rngBaseReestr As Range
  Dim rngTemp As Range

  Dim strRangeTempName As String
  Dim lngReestrColumns As Long
  Dim lngCurrentRow As Long      ' Текущая строка на листе с отфильтрованными данными
  Dim lngCount As Long
  Dim lngRowReestrOrg As Long
  Dim lngColumnReestrOrg As Long

  If glngMOCOLUMN <= 0 Or _
     glngMRCOLUMN <= 0 Or _
     glngORGCOLUMN <= 0 Then
    GoTo ErrHandler
  End If

  Set wbBook = ThisWorkbook

  If modServiceModule.IsNameExists(wbBook, modGlobals.STR_RANGE_NAME) = False Then
    GoTo ErrHandler
  End If

  If Len(strMRPattern) = 0 And _
     Len(strMOPattern) = 0 And _
     Len(strOrgPattern) = 0 Then
    frmReestr.ListReestr.RowSource = modGlobals.STR_RANGE_NAME
  Else

    Application.EnableEvents = False

    strRangeTempName = "REESTR_FILTERED"

    lngCurrentRow = 2
    Set wsReestrOrg = wbBook.Worksheets(modGlobals.STR_REESTR_ORG_SHEET_NAME)
    Set wsReestrFiltered = wbBook.Worksheets(modGlobals.STR_REESTR_FILTERED_SHEET_NAME)
    Set rngBaseReestr = wsReestrOrg.Range(modGlobals.STR_RANGE_NAME)
    lngReestrColumns = rngBaseReestr.Columns.Count
    lngCount = rngBaseReestr.Rows.Count + 1

    ' На время формирования отфильтрованного списка переключить режим вычислений Excel
    Application.Calculation = xlCalculationManual

    ' удаление существующего списка
    If modServiceModule.IsNameExists(wbBook, strRangeTempName) = True Then
      wbBook.Names(strRangeTempName).Delete
      wsReestrFiltered.Range(wsReestrFiltered.cells(2, 1), _
                             wsReestrFiltered.cells(wsReestrFiltered.UsedRange.Rows.Count + 2, _
                                                    wsReestrFiltered.UsedRange.Columns.Count)).ClearContents
    End If

    ' переносим подходящие строки
    For lngRowReestrOrg = rngBaseReestr.Row To lngCount + rngBaseReestr.Row - 2
      ' проверка строки на соответствие установленным фильтрам
      If (InStr(1, CStr(wsReestrOrg.cells(lngRowReestrOrg, glngMRCOLUMN).Value), _
                  strMRPattern, vbTextCompare) > 0 Or _
          Len(wsReestrOrg.cells(lngRowReestrOrg, glngMRCOLUMN).Value) = 0) And _
         (InStr(1, CStr(wsReestrOrg.cells(lngRowReestrOrg, glngMOCOLUMN).Value), _
                  strMOPattern, vbTextCompare) > 0 Or _
          Len(wsReestrOrg.cells(lngRowReestrOrg, glngMOCOLUMN).Value) = 0) And _
         (InStr(1, CStr(wsReestrOrg.cells(lngRowReestrOrg, glngORGCOLUMN).Value), _
                  strOrgPattern, vbTextCompare) > 0 Or _
          Len(wsReestrOrg.cells(lngRowReestrOrg, glngORGCOLUMN).Value) = 0) Then
        ' запись строки на лист
        For lngColumnReestrOrg = rngBaseReestr.Column + 1 To glngCOLUMNSCOUNT
          wsReestrFiltered.cells(lngCurrentRow, lngColumnReestrOrg - rngBaseReestr.Column + 1).Value = _
            wsReestrOrg.cells(lngRowReestrOrg, lngColumnReestrOrg).Value
        Next lngColumnReestrOrg
        ' НОМЕР
        wsReestrFiltered.cells(lngCurrentRow, 1).Value = lngCurrentRow - 1
        lngCurrentRow = lngCurrentRow + 1
      End If
    Next lngRowReestrOrg

    ' Определить диапазон
    If Len(CStr(wsReestrFiltered.Range("A2").cells(1, 1).Value)) > 0 Then ' если что-то попало на лист по фильтру
      wbBook.Names.Add strRangeTempName, _
                       RefersToR1C1:="=" & modGlobals.STR_REESTR_FILTERED_SHEET_NAME & _
                       "!R2C1:R" & CStr(lngCurrentRow - 1) & _
                       "C" & CStr(lngReestrColumns)
    End If
    If modServiceModule.IsNameExists(wbBook, strRangeTempName) = True Then
      frmReestr.ListReestr.RowSource = strRangeTempName
    Else
      frmReestr.ListReestr.RowSource = vbNullString
    End If
    frmReestr.Repaint
  End If

  GoTo cleanUp

ErrHandler:
  GoTo cleanUp
cleanUp:
  Application.EnableEvents = True
  Application.Calculation = xlCalculationAutomatic
End Sub

' Удаление колонок НСРФ и МР_ОКТМО
Public Sub Define_Range(strSheetName As String, _
                        wbBook As Workbook)

  On Error GoTo ErrHandler

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

  Dim wsSheet As Worksheet
  Dim rngRange As Range
  Dim intOrgRegionRowCount As Long
  Set wsSheet = wbBook.Worksheets(strSheetName)

  modServiceModule.UNPROTECT_SHEET wsSheet
  wsSheet.Columns(3).Delete
  wsSheet.Columns(1).Delete

  ' Заголовки
  wsSheet.Range("A1").Value = "МР"
  wsSheet.Range("B1").Value = "МО"
  wsSheet.Range("C1").Value = "МО ОКТМО"
  wsSheet.Range("D1").Value = "ОРГАНИЗАЦИЯ"
  wsSheet.Range("E1").Value = "ИНН"
  wsSheet.Range("F1").Value = "КПП"
  wsSheet.Range("G1").Value = "ВИД ДЕЯТЕЛЬНОСТИ"

  wsSheet.Application.DisplayAlerts = False

  ' Вставить колонку для номеров
  wsSheet.Activate
  wsSheet.Columns("A:A").Insert Shift:=xlToRight

  wsSheet.Application.DisplayAlerts = True

  intOrgRegionRowCount = 1
  Do While Len(CStr(wsSheet.cells(intOrgRegionRowCount + 1, 5).Value)) > 0
    ' Проставить номера
    wsSheet.cells(intOrgRegionRowCount + 1, 1).Value = intOrgRegionRowCount
    intOrgRegionRowCount = intOrgRegionRowCount + 1
  Loop

  ' Заголовок НОМЕР
  wsSheet.Range("A1").Value = "№"

  If modServiceModule.IsNameExists(ActiveWorkbook, modGlobals.STR_RANGE_NAME) = True Then
    ActiveWorkbook.Names(modGlobals.STR_RANGE_NAME).Delete
  End If

  If intOrgRegionRowCount > 1 Then
    Set rngRange = wsSheet.Range(wsSheet.cells(2, 1), _
                                 wsSheet.cells(intOrgRegionRowCount, 8))

    If Len(modGlobals.STR_RANGE_NAME) > 0 Then
      rngRange.name = modGlobals.STR_RANGE_NAME
    End If
  End If

ErrHandler:
End Sub

Public Sub cmdUpdateReestr_Click_Handler()

  On Error GoTo ErrHandler

  ' Очистить поле фильтры быстрого поиска
  frmReestr.txtMRFilter.Text = vbNullString
  frmReestr.txtMOFilter.Text = vbNullString
  frmReestr.txtOrgFilter.Text = vbNullString

  ' Убрать старый список
  frmReestr.ListReestr.RowSource = ""

  modSheetMain01.cmdUpdateOrgData_Click_Handler ActiveSheet, frmReestr.cmdUpdateReestr

  If modServiceModule.IsNameExists(ThisWorkbook, modGlobals.STR_RANGE_NAME) = True Then
    ' Список организаций обновлён и он не пустой
     frmReestr.ListReestr.RowSource = modGlobals.STR_RANGE_NAME
  Else
    ' Убрать старый список
    frmReestr.ListReestr.RowSource = ""
  End If

  GoTo cleanUp

ErrHandler:
  GoTo cleanUp
cleanUp:
  Application.ScreenUpdating = True
End Sub

Public Sub ListReestr_DblClick_Handler(ByVal Cancel As MSForms.ReturnBoolean)
  cmdOK_Click_Handler
End Sub

Public Sub txtURL_DblClick_Handler(ByVal Cancel As MSForms.ReturnBoolean)
  'modWindowClipboard.PutOnClipboard txtURL
  Application.ThisWorkbook.FollowHyperlink frmReestr.txtURL.Text
End Sub

Public Sub UserForm_Initialize_Handler()

  Dim wbBook As Workbook
  Dim lngICounter As Long
  Dim wsOrgSheet As Worksheet
  Dim wsFilteredSheet As Worksheet

  Set wbBook = ThisWorkbook
  
  If modGlobals.gblnTestMode = False Then
    frmReestr.ListReestr.SetFocus
    hW = GetFocus
    frmReestr.cmdOK.SetFocus
    Hook hW ' for LB scrolling
  End If

  If modServiceModule.IsNameExists(wbBook, "region_name") = True Then
    frmReestr.Label1.caption = wbBook.Names("region_name").RefersToRange.Value
  End If

  If Len(modGlobals.STR_RANGE_NAME) > 0 Then

    If modServiceModule.IsNameExists(wbBook, modGlobals.STR_RANGE_NAME) = True Then
      frmReestr.ListReestr.RowSource = modGlobals.STR_RANGE_NAME
    End If

    Set wsOrgSheet = ThisWorkbook.Worksheets(modGlobals.STR_REESTR_ORG_SHEET_NAME)
    Set wsFilteredSheet = ThisWorkbook.Worksheets(modGlobals.STR_REESTR_FILTERED_SHEET_NAME)

    modServiceModule.UNPROTECT_SHEET wsOrgSheet
    modServiceModule.UNPROTECT_SHEET wsFilteredSheet

    ' Прописать заголовки на листы
''    If Len(wsOrgSheet.Range("A2").cells(1, 1).Value) > 0 Then
      For lngICounter = 1 To wsOrgSheet.UsedRange.Columns.Count
        wsFilteredSheet.cells(1, lngICounter).Value = wsOrgSheet.cells(1, lngICounter).Value
        If wsFilteredSheet.cells(1, lngICounter).Value = "МР" Then
          glngMRCOLUMN = lngICounter ' Колонка "МР"
        End If
        If wsFilteredSheet.cells(1, lngICounter).Value = "МО" Then
          glngMOCOLUMN = lngICounter ' Колонка "МО"
        End If
        If wsFilteredSheet.cells(1, lngICounter).Value = "ОРГАНИЗАЦИЯ" Then
          glngORGCOLUMN = lngICounter ' Колонка "ОРГАНИЗАЦИЯ"
        End If
      Next lngICounter
''    End If

    glngCOLUMNSCOUNT = frmReestr.ListReestr.ColumnCount

  End If

  frmReestr.lblLookupOrganization.Visible = False
  frmReestr.lblLookupOrganization = vbNullString

  frmReestr.lblMirror = vbNullString

  Application.ScreenUpdating = True

End Sub

Public Sub UserForm_Terminate_Handler()
  frmReestr.ListReestr.RowSource = vbNullString
  If modGlobals.gblnTestMode = False Then
    UnHook hW ' for LB scrolling
  End If
End Sub


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

' Проверка длины строки и числовых знаков
Private Function blnValidate_Len_Number(strValue As String, _
                                        intMinLen As Integer, _
                                        intMaxLen As Integer) As Boolean
                                        
  Dim intCounter As Integer
  
  blnValidate_Len_Number = False
  If intMinLen <= 0 Or intMinLen <= 0 Then Exit Function
  
  If Len(strValue) = 0 Then ' пустая строка
    blnValidate_Len_Number = True ' не проверять такое поле, считать его валидным
    Exit Function
  End If
  
  If Len(strValue) > intMaxLen Or Len(strValue) < intMinLen Then
    Exit Function
  End If
  
  For intCounter = 1 To Len(strValue)
    If Mid(strValue, intCounter, 1) < "0" Or Mid(strValue, intCounter, 1) > "9" Then
      Exit Function
    End If
  Next intCounter
  
  blnValidate_Len_Number = True

End Function

' ---------------------------------------------------------------------------------
' ---------------------------------------------------------------------------------
' ----------------------------- ПРОВЕРКА на форме ---------------------------------
' ---------------------------------------------------------------------------------
' ---------------------------------------------------------------------------------

' ПРОВЕРКА ИНН на форме
Public Function blnValidate_INN_OnForm(strINN As String, _
                                       Optional blnMsgBoxShow As Boolean = True) As Boolean
                                       
  blnValidate_INN_OnForm = False
  
  If blnValidate_Len_Number(strINN, 10, 12) = False Then
    GoTo ErrHandler
  Else
    GoTo Success
  End If
  
Success:
  blnValidate_INN_OnForm = True
  GoTo cleanUp
ErrHandler:
  blnValidate_INN_OnForm = False
  If blnMsgBoxShow = True Then
    MsgBox "ИНН введён не верно! ИНН должен содержать 10-12 числовых знаков! Добавление невозможно!", _
           vbCritical, "Предупреждение"
  End If
  GoTo cleanUp
cleanUp:
  Exit Function
  
End Function

' ПРОВЕРКА КПП на форме
Public Function blnValidate_KPP_OnForm(strKPP As String, _
                                       Optional blnMsgBoxShow As Boolean = True) As Boolean
                                       
  blnValidate_KPP_OnForm = False
  
  If LCase(Trim(strKPP)) = "не определено" Or _
     LCase(Trim(strKPP)) = "отсутствует" Then
        GoTo Success
  ElseIf blnValidate_Len_Number(strKPP, 9, 9) = False Then
        GoTo ErrHandler
  Else
        GoTo Success
  End If
  
Success:
  blnValidate_KPP_OnForm = True
  GoTo cleanUp
ErrHandler:
  blnValidate_KPP_OnForm = False
  If blnMsgBoxShow = True Then
    MsgBox "КПП введён не верно! КПП должен содержать 9 числовых знаков! Добавление невозможно!", _
           vbCritical, "Предупреждение"
  End If
  GoTo cleanUp
cleanUp:
  Exit Function
  
End Function

' ПРОВЕРКА ОКТМО на форме
Public Function blnValidate_OKTMO_OnForm(strOKTMO As String, _
                                         Optional blnMsgBoxShow As Boolean = True) As Boolean
                                         
  blnValidate_OKTMO_OnForm = False
  
  If blnValidate_Len_Number(strOKTMO, 7, 8) = False Then
    GoTo ErrHandler
  Else
    GoTo Success
  End If
  
Success:
  blnValidate_OKTMO_OnForm = True
  GoTo cleanUp
ErrHandler:
  blnValidate_OKTMO_OnForm = False
  If blnMsgBoxShow = True Then
    MsgBox "ОКТМО введён не верно! ОКТМО должен содержать 7-8 числовых знаков! Добавление невозможно!", _
           vbCritical, "Предупреждение"
  End If
  GoTo cleanUp
cleanUp:
  Exit Function
  
End Function

' ПРОВЕРКА ОКАТО на форме
Public Function blnValidate_OKATO_OnForm(strOKATO As String, _
                                         Optional blnMsgBoxShow As Boolean = True) As Boolean
                                         
  blnValidate_OKATO_OnForm = False
  
  If blnValidate_Len_Number(strOKATO, 7, 11) = False Then
    GoTo ErrHandler
  Else
    GoTo Success
  End If
  
Success:
  blnValidate_OKATO_OnForm = True
  GoTo cleanUp
ErrHandler:
  blnValidate_OKATO_OnForm = False
  If blnMsgBoxShow = True Then
    MsgBox "ОКАТО введён не верно! ОКАТО должен содержать 7-11 числовых знаков! Добавление невозможно!", _
           vbCritical, "Предупреждение"
  End If
  GoTo cleanUp
cleanUp:
  Exit Function
  
End Function

' ---------------------------------------------------------------------------------
' ---------------------------------------------------------------------------------
' ----------------------------- ПРОВЕРКА на листе ---------------------------------
' ---------------------------------------------------------------------------------
' ---------------------------------------------------------------------------------

' ПРОВЕРКА ИНН на листе
Public Function blnValidate_INN_OnSheet(rngValidatingRange As Range, _
                                Optional blnMsgBoxShow As Boolean = True) As Boolean
                                
  blnValidate_INN_OnSheet = False
  
  If rngValidatingRange Is Nothing Then
    GoTo cleanUp
  End If
  
  If blnValidate_Len_Number(CStr(rngValidatingRange.cells(1, 1).Value), 10, 12) = False Then
    GoTo ErrHandler
  Else
    GoTo Success
  End If
  
Success:
  blnValidate_INN_OnSheet = True
  GoTo cleanUp
ErrHandler:
  blnValidate_INN_OnSheet = False
  If blnMsgBoxShow = True Then
    MsgBox "ИНН введён не верно! Ячейка '" & rngValidatingRange.Address & "'!", _
           vbOKOnly + vbExclamation, "Предупреждение"
  End If
  rngValidatingRange.parent.Activate
  rngValidatingRange.Activate
  GoTo cleanUp
cleanUp:
  Exit Function
  
End Function

' ПРОВЕРКА КПП на листе
Public Function blnValidate_KPP_OnSheet(rngValidatingRange As Range, _
                                        Optional blnMsgBoxShow As Boolean = True) As Boolean
                                        
  blnValidate_KPP_OnSheet = False
  
  If rngValidatingRange Is Nothing Then
    GoTo cleanUp
  End If
  
  If LCase(Trim(CStr(rngValidatingRange.cells(1, 1).Value))) = "не определено" Or _
     LCase(Trim(CStr(rngValidatingRange.cells(1, 1).Value))) = "отсутствует" Then
        GoTo Success
  ElseIf blnValidate_Len_Number(CStr(rngValidatingRange.cells(1, 1).Value), 9, 9) = False Then
        GoTo ErrHandler
  Else
        GoTo Success
  End If
  
Success:
  blnValidate_KPP_OnSheet = True
  GoTo cleanUp
ErrHandler:
  blnValidate_KPP_OnSheet = False
  If blnMsgBoxShow = True Then
    MsgBox "ОКАТО введён не верно! ОКАТО должен содержать 7-11 числовых знаков! Добавление невозможно!", _
           " Ячейка '" & rngValidatingRange.Address & "'!", vbCritical, "Предупреждение"
  End If
  rngValidatingRange.parent.Activate
  rngValidatingRange.Activate
  GoTo cleanUp
cleanUp:
  Exit Function
  
End Function

' ПРОВЕРКА ОКТМО на листе
Public Function blnValidate_OKTMO_OnSheet(rngValidatingRange As Range, _
                                          Optional blnMsgBoxShow As Boolean = True) As Boolean
                                          
  blnValidate_OKTMO_OnSheet = False
  
  If rngValidatingRange Is Nothing Then
    GoTo cleanUp
  End If
  
  If blnValidate_Len_Number(CStr(rngValidatingRange.cells(1, 1).Value), 7, 8) = False Then
    GoTo ErrHandler
  Else
    GoTo Success
  End If
  
Success:
  blnValidate_OKTMO_OnSheet = True
  GoTo cleanUp
ErrHandler:
  blnValidate_OKTMO_OnSheet = False
  If blnMsgBoxShow = True Then
    MsgBox "ОКТМО введён не верно! ОКТМО должен содержать 9 числовых знаков! Добавление невозможно!", _
           " Ячейка '" & rngValidatingRange.Address & "'!", vbCritical, "Предупреждение"
  End If
  rngValidatingRange.parent.Activate
  rngValidatingRange.Activate
  GoTo cleanUp
cleanUp:
  Exit Function
  
End Function

' ПРОВЕРКА ОКАТО на листе
Public Function blnValidate_OKATO_OnSheet(rngValidatingRange As Range, _
                                          Optional blnMsgBoxShow As Boolean = True) As Boolean
                                          
  blnValidate_OKATO_OnSheet = False
  
  If rngValidatingRange Is Nothing Then
    GoTo cleanUp
  End If
  
  If blnValidate_Len_Number(CStr(rngValidatingRange.cells(1, 1).Value), 7, 11) = False Then
    GoTo ErrHandler
  Else
    GoTo Success
  End If
  
Success:
  blnValidate_OKATO_OnSheet = True
  GoTo cleanUp
ErrHandler:
  blnValidate_OKATO_OnSheet = False
  If blnMsgBoxShow = True Then
    MsgBox "ОКАТО введён не верно! ОКАТО должен содержать 7-11 числовых знаков! Добавление невозможно!", _
           " Ячейка '" & rngValidatingRange.Address & "'!", vbCritical, "Предупреждение"
  End If
  rngValidatingRange.parent.Activate
  rngValidatingRange.Activate
  GoTo cleanUp
cleanUp:
  Exit Function
  
End Function

' ---------------------------------------------------------------------------------
' ---------------------------------------------------------------------------------
' -------------------- ПРОВЕРКА на листе, возвращает строку -----------------------
' ---------------------------------------------------------------------------------
' ---------------------------------------------------------------------------------

' ПРОВЕРКА ИНН на листе, возвращает строку
Public Function strValidate_INN_OnSheet(rngValidatingRange As Range) As String

  strValidate_INN_OnSheet = "Проверка не может быть выполнена!"
  
  If rngValidatingRange Is Nothing Then
    GoTo cleanUp
  End If
  
  If blnValidate_Len_Number(CStr(rngValidatingRange.cells(1, 1).Value), 10, 12) = False Then
    GoTo ErrHandler
  Else
    GoTo Success
  End If
…