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
Dim SErr As Boolean

Private Sub Workbook_BeforeClose(Cancel As Boolean)

End Sub

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

    Application.Calculate
    Dim Proverka As Integer
    If ActiveWorkbook.Sheets(sh1).cells(1, 1) = 0 Then
        MsgBox "В шаблоне нет ни одной организации!", vbOKOnly + vbExclamation, ThisWorkbook.name
        Exit Sub
    ElseIf PROV.checkBeforSaveAll > 1 Then
        If PROV.ProvFlagOsh = True Then
            MsgBox "Шаблон сохранен, но НЕ БУДЕТ принят к рассмотрению из-за невыполнения ОБЯЗАТЕЛЬНЫХ условий! См. лист 'Проверка'!", vbOKOnly + vbExclamation, "Результат проверки"
            ActiveWorkbook.Sheets("Проверка").Activate
        Else
            MsgBox "Шаблон сохранен и будет принят к рассмотрению, но обратите ВНИМАНИЕ на НЕВЫПОЛНЕНИЕ ПРЕДУПРЕДИТЕЛЬНЫХ условий! См. лист 'Проверка'!", vbOKOnly + vbExclamation, "Результат проверки"
            ActiveWorkbook.Sheets("Проверка").Activate
        End If
        Exit Sub
    End If
    Cancel = False

    On Error GoTo errhandler

    Dim status As Integer
    Dim response As Integer
    Dim Error_string As String
    status = ThisWorkbook.CustomDocumentProperties("Status")
    If status > 2 Then
        MsgBox "Документ подписан ЭЦП и не может быть изменен", vbExclamation + vbOKOnly, ThisWorkbook.name
        Cancel = True
        Exit Sub
    End If
    ThisWorkbook.CustomDocumentProperties("Status") = 1
    response = vbNo
    MsgBox "Шаблон готов к сохранению без замечаний!", vbInformation, "Результат проверки"
    If response = vbYes Then
        Error_string = is_ok

        If Error_string <> "" Then
            MsgBox Error_string, vbInformation + vbOKOnly, "Ошибка формирования!"
            ThisWorkbook.CustomDocumentProperties("Status") = 1
            Exit Sub
        End If

        ThisWorkbook.CustomDocumentProperties("Status") = 2

        If Not ParseBook2 Then
            MsgBox "Ошибка при вызове команды формирования XML-документа. Если АРМ СЕМ не установлен - установите его, если пункт АРМ СЕМ присутствует в меню - выберите АРМ СЕМ->XML->Сформировать XML-документ", vbOKOnly + vbExclamation, ThisWorkbook.name
            Cancel = True
            Exit Sub
        End If
    ElseIf response = vbCancel Then
        Cancel = True
    End If
    Exit Sub
errhandler:
    MsgBox err.Description, vbOKOnly + vbExclamation, ThisWorkbook.name
End Sub



Private Sub Workbook_Open()

Dim a As Excel.AddIn
'Application.Calculation = xlCalculationAutomatic ' чтобы пересчет формул осуществлялся автоматически
''protUnprot True True
    If IsNull(LookupMenu(Application.CommandBars("Worksheet Menu Bar"), "АРМ СЕМ")) Then
        For Each a In Excel.AddIns
            If a.name = "ARMSEM.xla" Then
                If Not TryRun(a) Then
                    If Not TryReInstall(a) Then
                        TryReOpen a
                    End If
                End If
            End If
        Next
    End If

  'SErr = False
  'HypLink.HypFl = True

    If IsNull(LookupMenu(Application.CommandBars("Worksheet Menu Bar"), "АРМ СЕМ")) Then
        ' Ни один из известных мне способов не сработал
        ' User, тебе не повезло!
        MsgBox "Не удалось вывести пункт меню АРМ СЕМ. Для активации меню используйте Сервис->Надстройки и выберите АРМ СЕМ вручную.", vbOKOnly + vbExclamation, ThisWorkbook.name
    End If

    If Len(ActiveWorkbook.Sheets("Список организаций").Range("I7").Value) = 0 Then
        ActiveWorkbook.Sheets(sh1).Visible = xlVeryHidden
        ActiveWorkbook.Sheets(sh2).Visible = xlVeryHidden

        ActiveWorkbook.Sheets(sh4).Visible = xlVeryHidden
'        ActiveWorkbook.Sheets(sh5).Visible = xlVeryHidden
'        ActiveWorkbook.Sheets(sh6).Visible = xlVeryHidden
        ActiveWorkbook.Sheets("Комментарии").Visible = xlVeryHidden
        ActiveWorkbook.Sheets("Проверка").Visible = xlVeryHidden

          ActiveWorkbook.Sheets("Свод").Visible = xlVeryHidden
        ActiveWorkbook.Sheets("Ошибки загрузки").Visible = xlVeryHidden

        ActiveWorkbook.Sheets("Инструкция").Activate
        ActiveWorkbook.Sheets("Инструкция").CommandButton1.Enabled = True
        ActiveWorkbook.Sheets("Инструкция").CommandButton1.Visible = True
    Else
        ActiveWorkbook.Sheets(sh1).Visible = True
        ActiveWorkbook.Sheets(sh2).Visible = True

        ActiveWorkbook.Sheets(sh4).Visible = True
'        ActiveWorkbook.Sheets(sh5).Visible = True
'        ActiveWorkbook.Sheets(sh6).Visible = True
        ActiveWorkbook.Sheets("Комментарии").Visible = True
        ActiveWorkbook.Sheets("Проверка").Visible = True

          ActiveWorkbook.Sheets("Свод").Visible = True
        ActiveWorkbook.Sheets("Ошибки загрузки").Visible = True

        'ActiveWorkbook.Sheets("Инструкция").Activate
        'ActiveWorkbook.Sheets("Инструкция").CommandButton1.Enabled = False
        'ActiveWorkbook.Sheets("Инструкция").CommandButton1.Visible = False
    End If
End Sub
Private Function TryRun(a As Excel.AddIn) As Boolean
    On Error GoTo errhandler
    Application.Run "'" & a.FullName & "'!SetupMenus"
    TryRun = True
    Exit Function
errhandler:
    TryRun = False
End Function
Private Function TryReInstall(a As Excel.AddIn) As Boolean
    On Error GoTo errhandler
    a.Installed = False
    a.Installed = True
    TryReInstall = True
    Exit Function
errhandler:
    TryReInstall = False
End Function
Private Function TryReOpen(a As Excel.AddIn) As Boolean
    On Error GoTo errhandler
    Workbooks.Open a.FullName
    TryReOpen = True
    Exit Function
errhandler:
    TryReOpen = False
End Function








Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Лист9"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "NamedRangeAppender"
Option Explicit

' Версия:     1.1 (22.02.2006)
' Автор:      Компьюлинк
' Назначение: Модуль обеспечивает работу с именованными диапазонами


' Процедура возвращает префикс для именованного диапазона
' Формат имен диапазонов <Префикс>?<Имя>

Public Function GetNamePrefix(name As String) As String
    Dim i As Integer
    i = VBA.InStr(name, "?")

    If i = 0 Then
        GetNamePrefix = ""
    Else
        GetNamePrefix = VBA.Mid(name, 1, i - 1)
    End If
End Function


' Процедура возвращает имя диапазона без префикса

Public Function GetLocalName(name As String) As String
    Dim i As Integer
    i = VBA.InStr(name, "?")

    If i = 0 Then
        GetLocalName = "???"
    Else
        GetLocalName = VBA.Mid(name, i + 1)
    End If
End Function



' Функция добавляет к диапазону ячеек другой диапазон, определяемый именем

Public Function AppendNameToRange(r As Range, n As name) As Range
    On Error GoTo errhandler

    If r Is Nothing Then
        Set AppendNameToRange = Range(n.name)
    Else
        Set AppendNameToRange = Application.Union(r, Range(n.name))
    End If

    Exit Function
errhandler:
    Set AppendNameToRange = r
End Function

' Функция возвращает имя листа, на котором находится именованный диапазон

Public Function GetNameWorksheetName(n As name) As String
    On Error GoTo errhandler

    GetNameWorksheetName = Range(n.name).Worksheet.name

    Exit Function
errhandler:
    GetNameWorksheetName = ""
End Function

' Функция сравнивает два диапазона

Public Function rangesEqual(R1 As Excel.Range, R2 As Excel.Range) As Boolean
    Dim r As Excel.Range

    If R1 Is Nothing Or R2 Is Nothing Then
        rangesEqual = False
    Else
        Set r = Intersect(R1, R2)
        If r Is Nothing Then
            rangesEqual = False
        ElseIf Union(R1, R2).Address = r.Address Then
            rangesEqual = True
        Else
            rangesEqual = False
        End If
    End If
End Function

' Функция возвращает имя первого диапазона, совпадающего
' с выделенными пользователем ячейками

Public Function SelectionRangeName() As String
    Dim nam As Excel.name
    Dim r As Excel.Range

    For Each nam In Names
        Set r = nvlRefersToRange(nam)

        If Not r Is Nothing Then
            If r.Worksheet.name = Selection.Worksheet.name Then
                If rangesEqual(Selection, r) Then
                    SelectionRangeName = nam.name
                    Exit Function
                End If
            End If
        End If
    Next nam
    
    SelectionRangeName = ""
End Function
' Функция возвращает Nothing, если именованый диапазон не существует

Public Function nvlRefersToRange(n As Excel.name) As Excel.Range
    On Error GoTo errhandler

    Set nvlRefersToRange = Range(n.name)

    Exit Function
errhandler:
    Set nvlRefersToRange = Nothing
End Function

' Функция проверяет, существует ли имя

Public Function nameExists(name As String, ws As Worksheet) As Boolean
    Dim n As Excel.name

    On Error GoTo errhandler

    Set n = ws.parent.Names(name)
    nameExists = True
    Exit Function
errhandler:
    nameExists = False
End Function


Public Function nameExists2(name As String) As Boolean
    Dim r As Range

    On Error GoTo errhandler

    Set r = Range(name)
    nameExists2 = True
    Exit Function
errhandler:
    nameExists2 = False
End Function


' Функция добавляет ячейки к именованному диапазону.
' Если диапазон состоит из многих областей (больше, чем
' может содержать строка RefersTo), то такой диапазон
' разбивается на несколько поддиапазонов, которым
' также присваиваются имена

Public Sub addRangeToName(r As Excel.Range, n As Excel.name)
    Dim R1 As Excel.Range
    Dim R2 As Excel.Range
    Dim n1 As Excel.name
    Dim wb As Excel.Workbook



    '-------------------------------
    'Set r1 = n.RefersToRange  ' - не работает
    Set R1 = Range(n.name)     ' - работает
    '-------------------------------
    
    Set wb = R1.Worksheet.parent

    ' Проверим, можно ли обойтись малой кровью -
    ' ускорение работы где-то на порядок
'    On Error GoTo errhandler
'    address$ = n.RefersTo
'    address2$ = "'" & r.Worksheet.name & "'!" & r.AddressLocal
'    If address$ = "=" Then
'        n.RefersTo = address$ & address2$
'        Exit Sub
'    ElseIf Len(address$) + 1 + Len(address2$) <= 255 Then
'        n.RefersTo = address$ & "," & address2$
'        Exit Sub
'    End If
'
'errhandler:
'    Err.Clear

    ' Получить объединенный диапазон и
    ' удалить ненужные имена. Кстати,
    ' union объединяет две смежные области
    ' в одну, что также позволяет сэкономить
    ' на количестве имен
    Dim pattern$
    If Not R1 Is Nothing Then
        Set R2 = Union(r, R1)
        pattern$ = "*_" & Replace(n.name, "?", "[?]")
        For Each n1 In wb.Names
            If n1.name Like pattern$ Then
                n1.Delete
            End If
        Next n1
    Else
        Set R2 = r
    End If

    ' Будем строить (при необходимости)
    ' пирамиду имен. Для этого считываем адреса
    ' областей в массив. В него же будем записывать
    ' имена созданных дочерних диапазонов
    Dim an#
    an# = R2.Areas.Count
    Dim ar() As String
    ReDim ar(2 * an#)
    Dim i#, j#, t#
    i# = LBound(ar)
    For Each R1 In R2.Areas
        ar(i#) = "'" & R1.Worksheet.name & "'!" & R1.AddressLocal
        i# = i# + 1
    Next R1

    j# = LBound(ar) + 1
    t# = 1
    Dim Address$
    Address$ = "=" & ar(LBound(ar))

    While j# < i#
        If Len(Address$) + 1 + Len(ar(j#)) > 150 Then
            wb.Names.Add name:="P" & t# & "_" & n.name, RefersTo:=Address$, Visible:=False
            ar(i#) = "P" & t# & "_" & n.name
            i# = i# + 1
            t# = t# + 1
            Address$ = "=" & ar(j#)
        Else
            Address$ = Address$ & "," & ar(j#)
        End If
        j# = j# + 1
    Wend
    
    n.RefersTo = Address$
End Sub

' Объединить диапазоны

Public Sub AppendNames(copy_range As Range, dest_range As Range, prefix As String)
    Dim nam As Excel.name

    For Each nam In ActiveWorkbook.Names
        If GetNamePrefix(nam.name) = prefix Then
            CopyHasAreas copy_range, dest_range, nam
        End If
    Next nam
End Sub

Function CopyHasAreas(copy_range As Range, dest_range As Range, nam As name) As Boolean
    Dim a As Range

    Dim OffsetX#, OffsetY#
    OffsetX# = dest_range.Column - copy_range.Column
    OffsetY# = dest_range.Row - copy_range.Row

    For Each a In Range(nam.name).Areas
        If a.Worksheet.name = copy_range.Worksheet.name Then
            If rangesEqual(a, Intersect(a, copy_range)) Then
                addRangeToName a.Offset(OffsetY#, OffsetX#), nam
            End If
        End If
    Next a
End Function


Sub ClearNames(prefix As String)
    Dim nam As Excel.name

'    On Error GoTo errhandler

    For Each nam In Names
        If InStr(nam.name, prefix) Then
            nam.Delete
        End If
    Next nam

    Exit Sub
'errhandler:
'    MsgBox Err.Description, vbOKOnly + vbExclamation, Err.Source
End Sub


Public Function ISect(R1 As Range, R2 As Range) As Range
    Set ISect = Intersect(R1, R2)
End Function


Attribute VB_Name = "Wrapper"
' Функция возвращает диапазон, по которому следует фильтровать данные

Function GetFilterRange(r As Range, v As Variant) As Range
    Dim cell As Range

    If r.Columns.Count > 1 Then   ' Диапазон по горизонтали
        For Each cell In r
            If cell.Value = v Then
                If GetFilterRange Is Nothing Then
                    Set GetFilterRange = cell.Worksheet.Columns(cell.Column)
                Else
                    Set GetFilterRange = Union(GetFilterRange, cell.Worksheet.Columns(cell.Column))
                End If
            End If
        Next cell
    Else                    ' Диапазон по вертикали
        For Each cell In r
            If cell.Value = v Then
                If GetFilterRange Is Nothing Then
                    Set GetFilterRange = cell.Worksheet.Rows(cell.Row)
                Else
                    Set GetFilterRange = Union(GetFilterRange, cell.Worksheet.Rows(cell.Row))
                End If
            End If
        Next cell
    End If
End Function


' Функция возвращает ячейку из диапазона r1, отфильтрованную по условию r2 = v2

Public Function GetValueFilter1(R1 As Range, R2 As Range, v2 As Variant, Optional R3 As Range) As Range
    On Error GoTo errhandler

    If IsMissing(R3) Then
        Set GetValueFilter1 = Intersect(R1, GetFilterRange(R2, v2))
    ElseIf R3 Is Nothing Then
        Set GetValueFilter1 = Intersect(R1, GetFilterRange(R2, v2))
    Else
        Set GetValueFilter1 = Intersect(R1, GetFilterRange(R2, v2), R3)
    End If

    Exit Function
errhandler:
    Set GetValueFilter1 = Nothing
End Function


' Функция возвращает ячейку из диапазона r1, отфильтрованную по условию r2 = v2 and r3 = v3

Public Function GetValueFilter2(R1 As Range, R2 As Range, v2 As Variant, R3 As Range, v3 As Variant, Optional R4 As Range) As Range
    On Error GoTo errhandler

    If IsMissing(R4) Then
        Set GetValueFilter2 = Intersect(R1, GetFilterRange(R2, v2), GetFilterRange(R3, v3))
    ElseIf R4 Is Nothing Then
        Set GetValueFilter2 = Intersect(R1, GetFilterRange(R2, v2), GetFilterRange(R3, v3))
    Else
        Set GetValueFilter2 = Intersect(R1, GetFilterRange(R2, v2), GetFilterRange(R3, v3), R4)
    End If

    Exit Function
errhandler:
    Set GetValueFilter2 = Nothing
End Function


' Функция возвращает ячейку из диапазона r1, отфильтрованную по условию r2 = v2 and r3 = v3 and r4 = v4

Public Function GetValueFilter3(R1 As Range, R2 As Range, v2 As Variant, R3 As Range, v3 As Variant, R4 As Range, v4 As Variant, Optional r5 As Range) As Range
    On Error GoTo errhandler

    If IsMissing(r5) Then
        Set GetValueFilter3 = Intersect(R1, GetFilterRange(R2, v2), GetFilterRange(R3, v3), GetFilterRange(R4, v4))
    ElseIf r5 Is Nothing Then
        Set GetValueFilter3 = Intersect(R1, GetFilterRange(R2, v2), GetFilterRange(R3, v3), GetFilterRange(R4, v4))
    Else
        Set GetValueFilter3 = Intersect(R1, GetFilterRange(R2, v2), GetFilterRange(R3, v3), GetFilterRange(R4, v4), r5)
    End If

    Exit Function
errhandler:
    Set GetValueFilter3 = Nothing
End Function


Public Function SumValueFilter1(R1 As Range, R2 As Range, v2 As Variant, Optional R3 As Range) As Variant
    Dim cell As Range
    Dim cells As Range

    On Error GoTo errhandler

    SumValueFilter1 = CDbl(0)
    Set cells = GetValueFilter1(R1, R2, v2, R3)
    If cells Is Nothing Then
        Exit Function
    Else
        For Each cell In cells
            SumValueFilter1 = SumValueFilter1 + CDbl(cell.Value)
        Next cell
    End If

    Exit Function
errhandler:
    SumValueFilter1 = CVErr(xlErrNum)
End Function


Public Function SumValueFilter2(R1 As Range, R2 As Range, v2 As Variant, R3 As Range, v3 As Variant, Optional R4 As Range) As Variant
    Dim cell As Range
    Dim cells As Range

    On Error GoTo errhandler

    SumValueFilter2 = CDbl(0)
    Set cells = GetValueFilter2(R1, R2, v2, R3, v3, R4)
    If cells Is Nothing Then
        Exit Function
    Else
        For Each cell In cells
            SumValueFilter2 = SumValueFilter2 + CDbl(cell.Value)
        Next cell
    End If

    Exit Function
errhandler:
    SumValueFilter2 = CVErr(xlErrNum)
End Function


Public Function SumValueFilter3(R1 As Range, R2 As Range, v2 As Variant, R3 As Range, v3 As Variant, R4 As Range, v4 As Variant, Optional r5 As Range) As Variant
    Dim cell As Range
    Dim cells As Range

    On Error GoTo errhandler

    SumValueFilter3 = CDbl(0)
    Set cells = GetValueFilter3(R1, R2, v2, R3, v3, R4, v4, r5)
    If cells Is Nothing Then
        Exit Function
    Else
        For Each cell In cells
            SumValueFilter3 = SumValueFilter3 + CDbl(cell.Value)
        Next cell
    End If

    Exit Function
errhandler:
    SumValueFilter3 = CVErr(xlErrNum)
End Function


Public Function ExcelIntersect(R1 As Range, R2 As Range) As Range
    On Error GoTo errhandler
    Set ExcelIntersect = Intersect(R1, R2)
    Exit Function
errhandler:
    Set ExcelIntersect = Nothing
End Function



Public Function ParseBook2() As Boolean
    Dim ctl As Variant
    Dim btn As CommandBarButton

    On Error GoTo errhandler

    Set ctl = LookupMenu(CommandBars("Worksheet Menu Bar"), "АРМ СЕМ")
    Set ctl = LookupMenu(ctl, "XML")
    Set btn = LookupMenu(ctl, "Сформировать XML-документ")
    If Not TryExecute(btn) Then
        ParseBook2 = TryRun(btn)
    Else
        ParseBook2 = True
    End If

    Exit Function
errhandler:
    ParseBook2 = False
End Function
Private Function TryExecute(btn As CommandBarButton) As Boolean
    On Error GoTo errhandler
    btn.Execute
    TryExecute = True
    Exit Function
errhandler:
    TryExecute = False
End Function
Private Function TryRun(btn As CommandBarButton) As Boolean
    On Error GoTo errhandler
    Application.Run btn.OnAction
    TryRun = True
    Exit Function
errhandler:
    TryRun = False
End Function


Public Function LookupMenu(ByRef parent As Variant, caption As String) As Variant
    Dim ctl As CommandBarControl

    For Each ctl In parent.Controls
        If ctl.caption = caption Then
            Set LookupMenu = ctl
            Exit Function
        End If
    Next ctl
    
    LookupMenu = Null
End Function


Public Function nErr(val As Variant, Optional val2 As Variant) As Variant
    If IsError(val) Then
        If IsMissing(val2) Then
            nErr = Empty
        Else
            nErr = val2
        End If
    Else
        nErr = val
    End If
End Function


Public Function ProcedureExists(name As String, module As Variant) As Boolean
    On Error Resume Next
    ProcedureExists = module.ProcStartLine(name, vbext_pk_Proc) <> 0
End Function


Public Function CanAutomate() As Boolean
    CanAutomate = ThisWorkbook.CustomDocumentProperties("ARMSEM").Value
End Function
Public Function RegisterARMSEM() As Boolean
    Dim a As AddIn

    RemoveReferenceToARMSEM

    On Error GoTo errhandler

    For Each a In AddIns
        If a.name = "ARMSEM.xla" Then
            ThisWorkbook.VBProject.References.AddFromfile a.FullName
            RegisterARMSEM = True
            ThisWorkbook.CustomDocumentProperties("ARMSEM").Value = True
            Exit Function
        End If
    Next a
    
errhandler:
    RegisterARMSEM = False
    ThisWorkbook.CustomDocumentProperties("ARMSEM").Value = False
End Function
Public Sub RemoveReferenceToARMSEM()
    On Error Resume Next

    ThisWorkbook.VBProject.References.Remove ThisWorkbook.VBProject.References("ARMSEM")
End Sub


Attribute VB_Name = "Sheet3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "FormRegion"
Attribute VB_Base = "0{00397008-164E-4010-BD2C-325F2416F876}{2837500C-8E1E-42AF-B8ED-BB95BE8C8548}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private Sub ComCancel_Click()
Unload Me
End Sub

Private Sub ComOK_Click()
Dim ws As Worksheet
Dim strdel As String

Set ws = ActiveWorkbook.Sheets(sh1)

If Help.PrinadlDiapazon(ActiveWorkbook.Sheets("TEHSHEET").Range("REGION"), ComboRegion.Value) = False Then
        MsgBox "РЕГИОН указан не верно!", vbCritical
Else
        strdel = MsgBox("Вы уверены в выборе региона: '" & ComboRegion.Value & "' ?", vbYesNo + vbQuestion, "Подтверждение!")
        If strdel = vbYes Then
            ' функция переопределения диапазонов и удаления не нужных регионов со служебных листов
            ws.Unprotect ("aq1sw2de3")
            ws.Range("I7").Value = ComboRegion.Value
            Label2.caption = "2"
            
            If reestr.FROM_REESTR(ComboRegion.Value) = True Then
                reestr.OKTMO_MO_NEW
                ws.Range("B1").Value = 1
                flag = True
            Else
                reestr.OKTMO_MO_NEW
                ws.Range("B1").Value = 0
            End If
                ActiveWorkbook.Sheets(sh1).Visible = True
                ActiveWorkbook.Sheets(sh1).Activate
                
                ActiveWorkbook.Sheets(sh2).Visible = True
                
                ActiveWorkbook.Sheets(sh4).Visible = True
'                ActiveWorkbook.Sheets(sh5).Visible = True
'                ActiveWorkbook.Sheets(sh6).Visible = True
                ActiveWorkbook.Sheets("Проверка").Visible = True
                ActiveWorkbook.Sheets("Комментарии").Visible = True
                
                ActiveWorkbook.Sheets("Свод").Visible = True
                ActiveWorkbook.Sheets("Ошибки загрузки").Visible = True
        
                
                ActiveWorkbook.Sheets("Инструкция").CommandButton1.Enabled = False
                ActiveWorkbook.Sheets("Инструкция").CommandButton1.Visible = False
                ws.Protect Password:="aq1sw2de3", DrawingObjects:=False, Contents:=True, Scenarios:=True _
                , AllowFormattingColumns:=True, AllowFormattingRows:=True
                Unload Me
        End If

    End If
End Sub

Private Sub Label2_Click()

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If Label2.caption = "1" Then
    ActiveWorkbook.Sheets("Инструкция").Activate
    ActiveWorkbook.Sheets("Инструкция").CommandButton1.Visible = True
End If
End Sub



Attribute VB_Name = "Лист2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "FormOrg"
Attribute VB_Base = "0{65268050-E186-45D4-BAF4-6DA8F27B7D34}{8364CE69-C182-4665-B3EC-4CC3F47FC825}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Private Sub nds_Change()

End Sub

' ДОБАВИТЬ/ИЗМЕНИТЬ
Private Sub OK_Click()

flag = False
If Proverka = True Then
    PerConst.fil = Trim(FormOrg.fil)
    PerConst.org = Trim(FormOrg.org)
    PerConst.pr_fil = Trim(FormOrg.pr_fil)
    PerConst.fil = Trim(FormOrg.fil)
    PerConst.inn = Trim(FormOrg.inn)
    PerConst.kpp = Trim(FormOrg.kpp)
    PerConst.vprod = Trim(FormOrg.vprod)
   
    PerConst.od = Trim(FormOrg.od)
    PerConst.nds = Trim(FormOrg.nds)
    flag = True
    Unload Me
End If

End Sub
Private Sub Cancel_Click()
    Unload Me
End Sub
' определение признака филиала
Private Sub pr_fil_Change()
    UpdPrFil
End Sub
' инициализация формы - подстановка значений из формы FormReestr
Private Sub UserForm_Initialize()
flag = False

    FormOrg.fil = PerConst.fil
    FormOrg.org = PerConst.org
    FormOrg.pr_fil = PerConst.pr_fil
    FormOrg.fil = PerConst.fil
    FormOrg.inn = PerConst.inn
    FormOrg.kpp = PerConst.kpp
    FormOrg.vprod = PerConst.vprod
'    FormOrg.pp = PerConst.pp
    FormOrg.od = PerConst.od
    FormOrg.nds = PerConst.nds

End Sub

' КОРРЕКТИРОВКА формы в зависимости от признака филиала
Sub UpdPrFil()
  If pr_fil.Value = "да" Then
        FormOrg.fil.Locked = False
        FormOrg.fil.Enabled = True
        FormOrg.LOrg = "Наименование ГОЛОВНОЙ организации"
        FormOrg.LKpp = "КПП данного ФИЛИАЛА"
        FormOrg.LInn = "ИНН ГОЛОВНОЙ организации"
        FormOrg.LFil = "Наименование ФИЛИАЛА"
    Else
        FormOrg.fil.Locked = True
        FormOrg.fil.Enabled = False
        FormOrg.fil = ""
        
        FormOrg.LOrg = "Наименование организации"
        FormOrg.LInn = "ИНН организации"
        FormOrg.LKpp = "КПП организации"
        FormOrg.LFil = "Наименование филиала (Не указывается!!!)"
    End If
End Sub
' проверка при добавлениии или изменении
Function Proverka() As Boolean
Proverka = True
'признак филиала
If Len(Trim(FormOrg.pr_fil)) = 0 Then
    Proverka = False
    MsgBox "Укажите является ли данная организация филиалом!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.pr_fil.SetFocus
    GoTo end_:
End If

'организация
If Len(Trim(FormOrg.org)) = 0 Then
    Proverka = False
    MsgBox "Введите наименование организации!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.org.SetFocus
    GoTo end_:
End If

'ИНН
If Len(Trim(FormOrg.inn)) = 0 Then
    Proverka = False
    MsgBox "Введите ИНН!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.inn.SetFocus
    GoTo end_:
End If

If allCheck.InnCh(Trim(FormOrg.inn)) = False Then
    Proverka = False
    MsgBox "ИНН должен состоять из 10-12 цифр!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.inn.SetFocus
    GoTo end_:
End If

'КПП
If Len(Trim(FormOrg.kpp)) = 0 Then
    Proverka = False
    MsgBox "Введите КПП!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.kpp.SetFocus
    GoTo end_:
End If

If allCheck.KppCh(Trim(FormOrg.kpp)) = False Then
    Proverka = False
    MsgBox "КПП должен состоять из 9 цифр!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.kpp.SetFocus
    GoTo end_:
End If

'НАИМЕНОВАНИЕ ФИЛИАЛА
If pr_fil.Value = "да" And Len(Trim(FormOrg.fil)) = 0 Then
    Proverka = False
    MsgBox "Так как признак филиала - 'да'! Введите наименование филиала!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.fil.SetFocus
    GoTo end_:
End If

' Вид деятельности
If Len(Trim(FormOrg.vprod)) = 0 Then
    Proverka = False
    MsgBox "Выберите вид деятельности!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.vprod.SetFocus
    GoTo end_:
End If

' Действует
If Len(Trim(FormOrg.od)) = 0 Then
    Proverka = False
    MsgBox "Укажите осуществляет ли деятельность данная организация!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.od.SetFocus
    GoTo end_:
End If

' НДС
If Len(Trim(FormOrg.nds)) = 0 Then
    Proverka = False
    MsgBox "Укажите является ли данная организация плательщиком НДС!", vbOKOnly + vbExclamation, ThisWorkbook.name
    FormOrg.nds.SetFocus
    GoTo end_:
End If

end_:

End Function
' изменение вида деятельности
Private Sub vprod_Change()
UpdVProd
End Sub

' КОРРЕКТИРОВКА ПЕРЕПРОДАЖИ в ЗАВИСИМОСТИ от ВИДА ДЕЯТЕЛЬНОСТИ
Sub UpdVProd()

End Sub

Attribute VB_Name = "Лист11"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
…