VBA

add_menu_with_parameter.vba

Private Sub Auto_Open()
    On Error Resume Next
    With MenuBars("Worksheet").Menus.Add(Caption:="New_menu" & ThisWorkbook.Name)
        With .MenuItems
            .Add Caption:="Пункт меню", OnAction:="'name_macros " & parameter & "'"
            .Add Caption:="-"
        End With
    End With
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    For Each m In MenuBars("Worksheet").Menus
        x = m.Caption
        xx = m.Index
        If x = "New_menu" & ThisWorkbook.Name Then
            m.Delete
        End If
    Next m
End Sub

close_word_doc.vba

Function close_word_doc (doc)
    On Error Resume Next: Err.Clear
    doc.Close False
End Function

close_word_obj.vba

Function close_word_obj (obj)
    On Error Resume Next: Err.Clear
    obj.Quit
    Set obj = Nothing
End Function

color_this.vba

Sub color_this()
    For Each r In Selection
        r.Value = r.Interior.ColorIndex
    Next r
End Sub

DativeCase.vba

Function DativeCase(sSurname$, Optional sName$, Optional sPatronymic$) As String
    ' Функция формирует дательный падеж из ФИО
    ' Параметры: sSurname - фамилия, sName - имя, sPatronymic - отчество

    Application.Volatile True    ' автопересчёт формулы на листе
    sSurname$ = Replace(sSurname$, " - ", "-"): sSurname$ = Replace(Replace(sSurname$, " -", "-"), "- ", "-")

    On Error Resume Next
    If sName$ = "" And sPatronymic$ = "" Then
        arr = Split(Application.Trim(sSurname$))
        sSurname$ = arr(0): sName$ = arr(1): sPatronymic$ = Replace(arr(2), ".", "")
    End If

    ' пол теперь определяется иначе:   что заканчивается на "вна" или "кызы" - то женщины, остальные - мужчины.
    Dim bMaleSex As Boolean:    ' bMaleSex = (Right(sPatronymic, 1) = "ч" Or Right(sPatronymic, 4) = "оглы")
    bMaleSex = Not (Right(sPatronymic, 2) = "на" Or Right(sPatronymic, 4) = "кызы")

    If Len(sSurname) > 0 Then    '   Фамилия
        arrSurname = Split(sSurname, "-")
        For i = LBound(arrSurname) To UBound(arrSurname)    ' перебираем все части фамилий, содержащих дефис
            sRes = "": sSurnamePart = arrSurname(i)

            If bMaleSex Then    ' мужские фамилии
                Select Case Right(sSurnamePart, 1)
                    Case "о", "и", "ы", "у", "э", "е", "ю": sRes = sSurnamePart
                    Case "ь", "й": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ю"
                    Case "я", "а": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "е"
                        If UBound(arrSurname) > 0 And i = 0 Then sRes = sSurnamePart
                    Case Else: sRes = sSurnamePart & "у"
                End Select

                Select Case Right(sSurnamePart, 2)    ' добавлено, для редких фамилий
                    Case "ец": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "цу"
                        If LCase(sSurnamePart) Like "*[уеыаоэяиюё]ец" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "цу"
                        If LCase(sSurnamePart) Like "*[!уеыаоэяиюё][!уеыаоэяиюё]ец" Then sRes = sSurnamePart & "у"
                    Case "зе", "их", "ых": sRes = sSurnamePart
                    Case "ый": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ому"
                    Case "ий", "ой": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ому"
                        If Len(sSurnamePart) <= 4 Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ю"
                        If Right(sSurnamePart, 3) = "чий" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ему"
                    Case "уй": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ую"
                End Select

            Else    ' женские фамилии
                Select Case Right(sSurnamePart, 1)
                    Case "о", "е", "э", "и", "ы", "у", "ю", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", "п", _
                         "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь", "й": sRes = sSurnamePart
                    Case "я": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ой"
                    Case Else: sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ой"
                End Select

                Select Case Right(sSurnamePart, 2)    ' добавлено, для редких фамилий
                    Case "ха", "ла", "ее": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "е"
                End Select

            End If

            ' не склоняются мужские и женские фамилии, оканчивающиеся на -о, -е, -э, -и, -ы, -у, -ю,
            ' а также на -а с предшествующей гласной
            If LCase(sSurnamePart) Like "*[уеыаоэяиюё]а" Then sRes = sSurnamePart

            arrSurname(i) = sRes
        Next
        DativeCase = Join(arrSurname, "-") & " "    ' соединяем части склоняемой фамилии обратно в одну строку
    End If

    If Len(sName) > 0 Then    '   Имя
        NameException$ = GetDativeException(sName)
        If Len(NameException$) Then    ' для имен-исключений
            DativeCase = DativeCase & NameException$
        Else    ' имя не найдено в списке исключений
            If bMaleSex Then
                Select Case Right(sName, 1)
                    Case "й", "ь": DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & "ю"
                    Case "я", "а": DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & "е"
                    Case "о": DativeCase = DativeCase & sName
                    Case Else: DativeCase = DativeCase & sName & "у"
                End Select
            Else
                Select Case Right(sName, 1)
                    Case "а", "я"
                        If Mid(sName, Len(sName) - 1, 1) = "и" Then
                            DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & "и"
                        Else
                            DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & "е"
                        End If
                    Case "ь": DativeCase = DativeCase & Mid(sName, 1, Len(sName) - 1) & "и"
                    Case Else: DativeCase = DativeCase & sName
                End Select
            End If
        End If
        DativeCase = DativeCase & " "
    End If

    If Len(sPatronymic) > 0 Then    '   Отчество
        If Right(sPatronymic, 4) = "оглы" Or Right(sPatronymic, 4) = "кызы" Then
            DativeCase = DativeCase & sPatronymic
        Else
            If bMaleSex Then
                DativeCase = DativeCase & sPatronymic & "у"
            Else
                DativeCase = DativeCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) & "е"
            End If
        End If
    End If
    pol = IIf(bMaleSex, "ый", "ая")
    DativeCase = Replace(DativeCase, "-", "- ")
    DativeCase = StrConv(DativeCase, vbProperCase)
    DativeCase = Replace(DativeCase, "- ", "-") & " " & pol
End Function

dir_path.vba

Function dir_path(button_text As String, title_text As String) As String
    On Error Resume Next: Err.Clear
    Set dir_ = Application.FileDialog(msoFileDialogFolderPicker)
    With dir_
        .Filters.Clear
        .AllowMultiSelect = False
        .Title = title_text
        .ButtonName = button_text
        If (.Show = -1) And (.SelectedItems.Count > 0) Then
            dir_path = .SelectedItems(1) & "\"
        Else
            Exit Function
        End If
    End With
    Set dir_ = Nothing
End Function

disable_some_settings.vba

Public Sub disable_some_settings()
    On Error Resume Next: Err.Clear
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
End Sub

enable_some_settings.vba

Public Sub enable_some_settings()
    On Error Resume Next: Err.Clear
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
End Sub

example.vba

Sub new_()
    ex1 = split_("1[2]3_4[5]", Array("[", "]")) 'return Array("1","2","3_4","5",empty)
    ex2 = split_val("1[2]3_4[5]", Array("[", "]", "{", "}", "<", ">", "(", ")")) 'return Array("2","5")
    ex3 = split_val("1@2@3@4@5]", Array("@")) 'return Array("2","4")
End Sub

existence_sheet.vba

Function existence_sheet (SheetName As Variant) As Boolean
    On Error Resume Next: Err.Clear
    existence_sheet = Not SheetName Is Nothing
End Function

find_cell.vba

Function find_cell(sheet_ As Variant, what_find As String, Optional value_ As Boolean = True, Optional find_col As String = "A", Optional find_row As Integer = 0, Optional ret_find_col As String = "A", Optional ret_find_row As Integer = 1)
    'x = find_range(ThisWorkbook.Sheets("Лист1"), "17", True, "H", , "L")
    'x1 = find_range(ThisWorkbook.Sheets("Лист1"), "1", True, , 14, , 24)
    'xxx_next = sheet_.Cells(sheet_.Columns(where_find).Find(What:=what_find, After:=Cells(x1, "J"), SearchDirection:=xlNext).Row, ret_find_col).Value
    On Error Resume Next: Err.Clear
    If value_ Then
        If find_col <> "" Then
            find_cell = sheet_.Cells(sheet_.Columns(find_col).Find(What:=what_find, LookIn:=xlValues).Row, ret_find_col).Value
        End If
        If find_row <> 0 Then
            find_cell = sheet_.Cells(ret_find_row, sheet_.Rows(find_row).Find(what_find, LookIn:=xlValues).Column).Value
        End If
    Else
        If find_col <> "" Then
            find_cell = sheet_.Columns(find_col).Find(What:=what_find, LookIn:=xlValues).Row
        End If
        If find_row <> 0 Then
            find_cell = sheet_.Rows(find_row).Find(what_find, LookIn:=xlValues).Column
        End If
    End If
End Function

find_files_by_mask.vba

Function find_files_by_mask(dir_path As String, mask As String)
    On Error Resume Next: Err.Clear
    Set file_list = CreateObject("Scripting.Dictionary")
    Set fso = CreateObject("scripting.filesystemobject"): Set curfold = fso.GetFolder(dir_path)
    If Not curfold Is Nothing Then
        For Each file_ In curfold.Files
            If file_.Name Like mask Then
                file_new_name_ = replace_some_chars(file_.Name, Array([{"с", "c"}], [{"а", "a"}]))
                file_new_name_number = split_val(file_new_name_, [{"[", "]"}])
                file_new_name_v = split_val(file_new_name_, [{"{", "}"}])
                file_new_name_object__ = split_val(file_new_name_, [{"@"}])
                file_new_name_object_ = split_val(file_new_name_object_, [{"(", ")"}])
                file_new_name_object = IIf(file_new_name_object_ <> Empty, "@" & file_new_name_object_, "")
                file_new_name = file_new_name_number & "@" & file_new_name_v & file_new_name_object
                to_new_name(file_.Name)
                    If file_list.Exists(file_new_name) = False Then
                        file_list.Add file_new_name, CStr(file_.Path)
                    End If
            End If
        Next
    For Each sfol In curfold.SubFolders
        find_files_by_mask sfol.Path, mask
    Next
    Set file_ = Nothing: Set curfold = Nothing: Set fso = Nothing:
    End If
    Set find_files_by_mask = file_list
End Function

GenitiveCase.vba

Function GenitiveCase(sSurname$, Optional sName$, Optional sPatronymic$) As String
    ' Функция формирует родительный падеж из ФИО
    ' Параметры: sSurname - фамилия, sName - имя, sPatronymic - отчество

    Application.Volatile True    ' автопересчёт формулы на листе
    sSurname$ = Replace(sSurname$, " - ", "-"): sSurname$ = Replace(Replace(sSurname$, " -", "-"), "- ", "-")

    On Error Resume Next
    If sName$ = "" And sPatronymic$ = "" Then
        arr = Split(Application.Trim(sSurname$))
        sSurname$ = arr(0): sName$ = arr(1): sPatronymic$ = Replace(arr(2), ".", "")
    End If

    ' пол теперь определяется иначе:   что заканчивается на "вна" или "кызы" - то женщины, остальные - мужчины.
    Dim bMaleSex As Boolean:    ' bMaleSex = (Right(sPatronymic, 1) = "ч" Or Right(sPatronymic, 4) = "оглы")
    bMaleSex = Not (Right(sPatronymic, 2) = "на" Or Right(sPatronymic, 4) = "кызы")

    If Len(sSurname) > 0 Then    '   Фамилия
        arrSurname = Split(sSurname, "-")
        For i = LBound(arrSurname) To UBound(arrSurname)    ' перебираем все части фамилий, содержащих дефис
            sRes = "": sSurnamePart = arrSurname(i)

            If bMaleSex Then    ' мужские фамилии
                Select Case Right(sSurnamePart, 1)
                    Case "о", "и", "ы", "у", "э", "е", "ю": sRes = sSurnamePart
                    Case "й": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ого"
                    Case "ь": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "я"
                    Case "я": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "и"
                    Case "а": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ы"
                        If UBound(arrSurname) > 0 And i = 0 Then sRes = sSurnamePart
                    Case Else: sRes = sSurnamePart & "а"
                End Select

                Select Case Right(sSurnamePart, 2)    ' добавлено, для редких фамилий
                    Case "ец":  sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ца"
                        If LCase(sSurnamePart) Like "*[уеыаоэяиюё]ец" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ца"
                        If LCase(sSurnamePart) Like "*[!уеыаоэяиюё][!уеыаоэяиюё]ец" Then sRes = sSurnamePart & "а"
                    Case "зе", "их", "ых": sRes = sSurnamePart
                    Case "ий", "ой": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ого"
                        If Len(sSurnamePart) <= 4 Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "я"
                        If Right(sSurnamePart, 3) = "чий" Then sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "его"
                    Case "уй": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "уя"
                End Select

            Else    ' женские фамилии
                Select Case Right(sSurnamePart, 1)
                    Case "о", "е", "э", "и", "ы", "у", "ю", "б", "в", "г", "д", "ж", "з", "к", "л", "м", "н", "п", _
                         "р", "с", "т", "ф", "х", "ц", "ч", "ш", "щ", "ь", "й": sRes = sSurnamePart
                    Case "а": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "ой"
                    Case "я": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ю"
                    Case Else: sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 1) & "у"
                End Select

                Select Case Right(sSurnamePart, 2)    ' добавлено, для редких фамилий
                    Case "ха": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "хи"
                    Case "ла": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "лы"
                    Case "ая": sRes = Mid(sSurnamePart, 1, Len(sSurnamePart) - 2) & "ой"
                End Select

            End If

            ' не склоняются мужские и женские фамилии, оканчивающиеся на -о, -е, -э, -и, -ы, -у, -ю,
            ' а также на -а с предшествующей гласной
            If LCase(sSurnamePart) Like "*[уеыаоэяиюё]а" Then sRes = sSurnamePart

            arrSurname(i) = sRes
        Next
        GenitiveCase = Join(arrSurname, "-") & " "    ' соединяем части склоняемой фамилии обратно в одну строку
    End If

    If Len(sName) > 0 Then    '   Имя
        NameException$ = GetGenitiveException(sName)
        If Len(NameException$) Then    ' для имен-исключений
            GenitiveCase = GenitiveCase & NameException$
        Else    ' имя не найдено в списке исключений
            If bMaleSex Then
                Select Case Right(sName, 1)
                    Case "й", "ь": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "я"
                    Case "а": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "ы"
                    Case "я": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"
                    Case "о": GenitiveCase = GenitiveCase & sName
                    Case Else: GenitiveCase = GenitiveCase & sName & "а"
                End Select
            Else
                Select Case Right(sName, 1)
                    Case "а": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "ы"
                    Case "я": GenitiveCase = GenitiveCase & Mid(sName, 1, Len(sName) - 1) & "и"
                    Case Else: GenitiveCase = GenitiveCase & sName
                End Select
            End If
        End If
        GenitiveCase = GenitiveCase & " "
    End If

    If Len(sPatronymic) > 0 Then    '   Отчество
        If Right(sPatronymic, 4) = "оглы" Or Right(sPatronymic, 4) = "кызы" Then
            GenitiveCase = GenitiveCase & sPatronymic
        Else
            If bMaleSex Then
                GenitiveCase = GenitiveCase & sPatronymic & "а"
            Else
                GenitiveCase = GenitiveCase & Mid(sPatronymic, 1, Len(sPatronymic) - 1) & "ы"
            End If
        End If
    End If
    GenitiveCase = Replace(GenitiveCase, "-", "- ")
    GenitiveCase = StrConv(GenitiveCase, vbProperCase)
    GenitiveCase = Replace(GenitiveCase, "- ", "-")
End Function

Function GetGenitiveException(ByVal txt$) As String    ' склонение имён-исключений
    Select Case txt$
        Case "Павел": GetGenitiveException = "Павла"
        Case "Лев": GetGenitiveException = "Льва"
        Case "Пётр": GetGenitiveException = "Петра"
        Case "Любовь": GetGenitiveException = "Любови"

            ' без изменения (не склоняются) - перечисляем через запятую
        Case "Али", "Бали": GetGenitiveException = txt$
    End Select
End Function

hide_visible_sheet.vba

Sub show_sh(exception_sheetname As String)
    Prepare
    Set sheets_ = ThisWorkbook.Sheets
    For Each s In sheets_
        If s.Name <> exception_sheetname Then
            s.Visible = xlSheetVisible
        End If
    Next s
    Ended
End Sub

Sub hide_sh(exception_sheetname As String)
    Prepare
    Set sheets_ = ThisWorkbook.Sheets
    For Each s In sheets_
        If s.Name <> exception_sheetname Then
            s.Visible = xlSheetHidden
        End If
    Next s
    Ended
End Sub

in_comm.vba

Sub in_comm()
    On Error Resume Next: Err.Clear
    Prepare
    info = Format(Now(), "dd/mm/yyyy") & "(" & Application.UserName & ")"
    For Each r In Selection
        If r.Value <> Empty Then
            in_comm_ r, info
            r.Value = Empty
        End If
    Next r
    Ended
End Sub

Function in_comm_(ByVal rng As Range, ByVal name_ As String)
    va = rng.Value
    If rng.Comment Is Nothing Then
        With rng
            .ClearComments
            .AddComment name_ & ":  " & CStr(va)
        End With
    Else
        text_ = rng.Comment.Text
        With rng
            .Comment.Text text_ & vbNewLine & name_ & ":  " & CStr(va)
        End With
    End If
End Function

in_dict.vba

Function in_dict(sheet_ As Variant, range_ As String, column_ As Integer)
    On Error Resume Next: Err.Clear
    Set D = CreateObject("Scripting.Dictionary")
    For Each r In sheet_.Range(range_)
        If r.Value <> "" Then
            If D.Exists(CStr(r.Value)) = False Then
                val_ = sheet_.Cells(r.Row, column_).Value: D.Add CStr(r.Value), val_
            Else
                val_ = sheet_.Cells(r.Row, column_).Value + D(CStr(r.Value)): D(CStr(r.Value)) = val_
            End If
        End If
    Next r
    in_dict = D
End Function

mailer.vba

Function mailer(Boss)
Dim x As Range, y As Range, Fst As String, OutlookApp As Object, SM As Object
On Error Resume Next: Err.Clear
text_="Часовой прогноз Алтайский край и Республика Алтай "
text__0="20-00"
text__1="08-00"
text__2="12-00"
text__3="16-00"
def_wb = ActiveWorkbook.Name
def_tab = ActiveSheet.Name
ho = Hour(Now)
logs (2)
Select Case ho
    Case 0: nnnam_ = text_ & text__0
    Case 1: nnnam_ = text_ & text__0
    Case 2: nnnam_ = text_ & text__0
    Case 3: nnnam_ = text_ & text__0
    Case 4: nnnam_ = text_ & text__0
    Case 5: nnnam_ = text_ & text__1
    Case 6: nnnam_ = text_ & text__1
    Case 7: nnnam_ = text_ & text__1
    Case 8: nnnam_ = text_ & text__1
    Case 9: nnnam_ = text_ & text__1
    Case 10: nnnam_ = text_ & text__1
    Case 11: nnnam_ = text_ & text__1
    Case 12: nnnam_ = text_ & text__2
    Case 13: nnnam_ = text_ & text__2
    Case 14: nnnam_ = text_ & text__2
    Case 15: nnnam_ = text_ & text__2
    Case 16: nnnam_ = text_ & text__3
    Case 17: nnnam_ = text_ & text__3
    Case 18: nnnam_ = text_ & text__3
    Case 19: nnnam_ = text_ & text__3
    Case 20: nnnam_ = text_ & text__0
    Case 21: nnnam_ = text_ & text__0
    Case 22: nnnam_ = text_ & text__0
    Case 23: nnnam_ = text_ & text__0
End Select
nnnam = "02 ch, 86 ch"
Set OutlookApp = CreateObject("Outlook.Application")
Set SM = OutlookApp.CreateItem(olMailItem)
SM.To = Boss
SM.Subject = nnnam
SM.Body = nnnam_ & Chr(13) & Chr(13) & "С уважением, Диспетчерская служба Алтайского края!"
SM.Attachments.Add Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="path_ch_ak", LookIn:=xlValues).Row, 1).Value
SM.Attachments.Add Sheets("spisok_002").Cells(Sheets("spisok_002").Columns("J:J").Find(What:="path_ch_ga", LookIn:=xlValues).Row, 1).Value
If Workbooks(def_wb).Sheets("_______").Range("I100").Value = "xxx" Then
'SM.Send
End If
SM.Importance = 2
SM.Display
Set SM = Nothing
Set OutlookApp = Nothing
End Function

month_change.vba

Function month_change(num_month As Integer, upcase As Boolean, lowcase As Boolean, tail As Boolean) As String
    On Error Resume Next: Err.Clear
    Select Case num_month
        Case 1:month_now = "Январь"
        Case 2:month_now = "Февраль"
        Case 3:month_now = "Март"
        Case 4:month_now = "Апрель"
        Case 5:month_now = "Май"
        Case 6:month_now = "Июнь"
        Case 7:month_now = "Июль"
        Case 8:month_now = "Август"
        Case 9:month_now = "Сентябрь"
        Case 10:month_now = "Октябрь"
        Case 11:month_now = "Ноябрь"
        Case 12:month_now = "Декабрь"
    End Select
    month_now=IIF(upcase,UCase(month_now),IIF(lowcase,LCase(month_now)),month_now)
    If tail Then
        If num_month <> 3 And num_month <> 8 Then
            month_now = Left(month_now, Len(month_now) - 1) & "я"
        Else
            month_now = month_now & "а"
        End If
    End If
    month_change = month_now
End Function

oglavl.vba

Private Sub CommandButton1_Click()

   

   Dim sheet As Worksheet
   Dim cell As Range
   Dim i As Integer
   i = 2
   
 
   
    Columns("A:B").Select
    Selection.ClearContents
  Dim objActiveSheet As Object
   ' Если нет активной рабочей книги - закрыть процедуру
   If ActiveWorkbook Is Nothing Then Exit Sub
   ' Проверка защищенности структуры рабочей книги
   If ActiveWorkbook.ProtectStructure Then
      ' Сортировка листов защищенной рабочей книги невозможна
      MsgBox "Структура книги " & ActiveWorkbook.Name & _
       " защищена. Сортировка листов невозможна.", _
       vbCritical
      Exit Sub
   End If
   ' Сохраняем ссылку на активный лист книги
   Set objActiveSheet = ActiveSheet

   ' Отключение сочетания клавиш Ctrl+Pause Break
   Application.EnableCancelKey = xlDisabled
   ' Функция обновления экрана отключается
   Application.ScreenUpdating = False

   With ActiveWorkbook
      ' Просмотр всех листов книги и создание гиперссылок на них _
       на первом листе
      For Each sheet In ActiveWorkbook.Worksheets
      If sheet.Name <> "Оглавление" Then
      Worksheets("Оглавление").Cells(i, 1).Value = i - 1
         Set cell = Worksheets("Оглавление").Cells(sheet.Index, 2)
         .Worksheets("Оглавление").Hyperlinks.Add Anchor:=cell, Address:="", _
          SubAddress:="'" & sheet.Name & "'" & "!A1"
         cell.Formula = sheet.Name
         i = i + 1
       End If
      Next
   End With

Columns("A:B").Select

    With Selection.Font
        .Name = "Arial Cyr"
        .Size = 16
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
    End With
    Selection.Font.Bold = True
    Range("B1").Select
   ' Переход на исходный рабочий лист
   objActiveSheet.Activate
   ' Включаем обновление экрана
   Application.ScreenUpdating = True
   ' Включение сочетания клавиш Ctrl+Pause Break
   Application.EnableCancelKey = xlInterrupt
   
   


End Sub

open_close_xls.vba

Function open_xl_wb (filepath As String, ex_object as Variant)
    On Error Resume Next: Err.Clear
    Dim xl_wb As Object
    Set xl_wb = ex_object.Documents.Open(filepath)
    Set open_xl_wb = xl_wb
End Function

Function open_xl_obj (visible_object As Boolean)
    On Error Resume Next: Err.Clear
    Dim ex_object As Object
    Set ex_object = CreateObject("Excel.Application")
    ex_object.Visible = visible_object
    set open_xl_obj = ex_object
End Function

Function close_xls_wb (ex)
    On Error Resume Next: Err.Clear
    ex.Close False
End Function

Function close_xls_obj (obj)
    On Error Resume Next: Err.Clear
    obj.Quit
    Set obj = Nothing
End Function

open_word_doc.vba

Function open_word_doc (filepath As String)
    On Error Resume Next: Err.Clear
    Dim word_document As Object
    Set word_document = word_object.Documents.Open(filepath)
    Set open_word_doc = word_document
End Function

open_word_obj.vba

Function open_word_obj (visible_object As Boolean)
    On Error Resume Next: Err.Clear
    Dim word_object As Object
    Set word_object = CreateObject("Word.Application")
    word_object.Visible = visible_object
    set open_word_obj = word_object
End Function

post_post.vba

Private Sub Application_NewMail()
	Dim m_0 As New auto_mess
	Dim m_1 As New auto_mess
    m_0.str_month Month(Now()), False, False, True
    m_1.str_month Month(Now()), True, False, False
    m_0.load_att "D:\mail_snif\", "*", , , m_1.month_now
End Sub
Function FolderExists(path) As Boolean
	On Error Resume Next
	FolderExists = GetAttr(path)
End Function
Public month_now As Variant

Public Sub str_month(Optional num_month As Integer = 1, Optional upcase As Boolean = False, Optional lowcase As Boolean = False, Optional tail As Boolean = False)
    
    On Error Resume Next
    Select Case num_month
        Case 1:
            month_now = "ßíâàðü"
        Case 2:
            month_now = "Ôåâðàëü"
        Case 3:
            month_now = "Ìàðò"
        Case 4:
            month_now = "Àïðåëü"
        Case 5:
            month_now = "Ìàé"
        Case 6:
            month_now = "Èþíü"
        Case 7:
            month_now = "Èþëü"
        Case 8:
            month_now = "Àâãóñò"
        Case 9:
            month_now = "Ñåíòÿáðü"
        Case 10:
            month_now = "Îêòÿáðü"
        Case 11:
            month_now = "Íîÿáðü"
        Case 12:
            month_now = "Äåêàáðü"
    End Select
    If upcase Then
        month_now = UCase(month_now)
    End If
    If lowcase Then
        month_now = LCase(month_now)
    End If
    If tail Then
        If num_month <> 3 And num_month <> 8 Then
        month_now = Left(month_now, Len(month_now) - 1) & "à"
        Else
        month_now = month_now & "ÿ"
        End If
    End If
End Sub

Public Sub load_att(Optional folder As String, Optional filetype As String, Optional name_def As String = "", Optional sender As String, Optional mn As String)

Dim myolapp As Outlook.Application
Dim myItem As Outlook.MailItem

Set myolapp = CreateObject("Outlook.Application")
Set myNamespace = myolapp.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)

last_count = myFolder.Items.Count
Set myItem = myFolder.Items(last_count)
Set y = myItem.Attachments

If myItem.UnRead Then
    myItem.UnRead = False
    myItem.Categories = "autoload"
    
    MsgBox "Îò " & myItem.SenderName, vbOKOnly, "Âíèìàíèå! Íîâîå ñîîáùåíèå!"
    name0 = myItem.Subject & "_" & myItem.SenderName & "_" & Minute(Now()) & "_" & Hour(Now()) & "_" & Day(Now())
    name0_ = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(name0, "*", ""), "/", ""), "?", ""), ">", ""), "<", ""), """", ""), "\", ""), "|", ""), ":", "")
    name_ = "c:\Documents and Settings\f0221630.MRG022\Ðàáî÷èé ñòîë\" & name0_ & ".txt"
    myItem.SaveAs name_, olTXT
End If

If y.Count > 0 Then
    folder_ = folder & Day(Now()) & " " & month_now & " " & Year(Now())
    If Not FolderExists(folder_) Then
        MkDir (folder_)
    End If
    If Not FolderExists("\\H022-srv-02\PUBLIC\Personal\Nechyaev\Post\" & Day(Now()) & " " & month_now & " " & Year(Now())) Then
        MkDir ("\\H022-srv-02\PUBLIC\Personal\Nechyaev\Post\" & Day(Now()) & " " & month_now & " " & Year(Now()))
    End If
End If

i = 0
Do Until i = y.Count
    i = i + 1
    If y.Count > 0 Then
        mas = Split(y(i).DisplayName, ".")
        maslen = UBound(mas, 1)
        If maslen >= 1 Then
            name_def = mas(maslen - 1)
            name_def_type = mas(maslen)
        Else
            name_def = mas(0)
            name_def_type = ""
        End If
        If name_def <> "" Then
            y(i).SaveAsFile folder_ & "\" & name_def & "." & name_def_type
            y(i).SaveAsFile "\\H022-srv-02\PUBLIC\Personal\Nechyaev\Post\" & Day(Now()) & " " & month_now & " " & Year(Now()) & "\" & name_def & "." & name_def_type
            myItem.HTMLBody = myItem.HTMLBody & "<br>" & "<a href='" & folder_ & "\" & name_def & "." & name_def_type & "'>" & folder_ & "\" & name_def & "." & name_def_type & "</a>" _
        & "  <a href='" & folder_ & "\" & "'>" & "êàòàëîã" & "</a>"
        End If
    End If
Loop

While y.Count > 0
    y.Remove 1
    myItem.Save
Wend

End Sub

range_in_array.vba

Function range_in_array(sheet_ as Variant, optional row_count_int as integer, optional column_count_int as integer)
    On Error Resume Next: Err.Clear
    CountRow = sheet_.Cells(Rows.Count, column_count_int).End(xlUp).Row
    CountColumn = sheet_.Cells(row_count_int, Columns.Count).End(xlToLeft).Column
    range_in_array = sheet_.Range(sheet_.Cells(1, 1).Address & ":" & sheet_.Cells(CountRow, CountColumn).Address)
End Function

replace_some_chars.vba

Function replace_some_chars(text As String, replace_symbols) As String
    'ex1 = replace_some_chars("35a-4-0001/14с", Array([{"c", "с"}], [{"a", "а"}])) 'return 35а-4-0001/14с
    On Error Resume Next: Err.Clear
    text_replace = text
    For Each char_ In replace_symbols
        text_replace = Replace(text_replace, char_(1), char_(2))
    Next char_
    replace_some_chars=text_replace
End Function

SearchAndReplaceInStory.vba

Public Sub SearchAndReplaceInStory(ByVal rngStory As Variant, _
    ByVal strSearch As String, ByVal strReplace As String)
    With rngStory.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = strSearch
        .Replacement.Text = strReplace
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With
End Sub

select_one_file.vba

Function select_one_file(text_button As String, text_title As String)
    On Error Resume Next: Err.Clear
    Application.FileDialog(msoFileDialogOpen).Show
    Application.FileDialog(msoFileDialogOpen).ButtonName = text_button
    Application.FileDialog(msoFileDialogOpen).Title = text_title
    Select Case Application.FileDialog(msoFileDialogOpen).SelectedItems.Count
        Case 0
            MsgBox "ничего не выбрано", vbInformation, "Error!!!"
        Case 1
            filepath = (Application.FileDialog(msoFileDialogOpen).SelectedItems.Item(1))
        Case Else
            MsgBox "более одного файла", vbInformation, "Error!!!"
    End Select
    select_one_file = filepath
End Function

shablon_.vba

Function shablon_(text, shablon, rrow) As String
    If InStr(shablon, "!!") = 0 Then
        text_ = Split(text, " ")
        f___$ = text_(0):i___$ = text_(1):o___$ = text_(2)
        f_i_o = Split(DativeCase(f___, i___, o___), " ")
        f__ = f_i_o(0):i__ = f_i_o(1):o__ = f_i_o(2)
        fiosh = Split(shablon, "_")
        For Each one In fiosh
            If one = "дф" Then:one_ = Left(f__, 1) & ".":End If
            If one = "ди" Then:one_ = Left(i__, 1) & ".":End If
            If one = "до" Then:one_ = Left(o__, 1) & ".":End If
            If one = "дфф" Then:one_ = f__:End If
            If one = "рфф" Then:rodtext = Split(GenitiveCase(f___, i___, o___), " "):one_ = rodtext(0) & " ":End If
            If one = "дии" Then:one_ = i__:End If
            If one = "доо" Then:one_ = o__:End If
            If one = "ф" Then:one_ = Left(text_(0), 1) & ".":End If
            If one = "и" Then:one_ = Left(text_(1), 1) & ".":End If
            If one = "о" Then:one_ = Left(text_(2), 1) & ".":End If
            If one = "фф" Then:one_ = text_(0):End If
            If one = "ии" Then:one_ = text_(1):End If
            If one = "оо" Then:one_ = text_(2):End If
            If one = " " Then:one_ = " ":End If
            If one = "asis" Then:one_ = text:End If
            If one = "ыйая" Then:one_ = f_i_o(3):End If
            fio1 = fio1 & one_:one_ = ""
        Next one
        shablon_ = fio1
    Else
        If InStr(shablon, "#") = 0 Then
            sh_split = Split(shablon, "!!")(1)
            mas = Split(sh_split, ";")
            For Each i In mas
                zn = Split(i, ":")(0)
                then_zn = Split(i, ":")(1)
                If InStr(text, zn) > 0 Then
                    one_ = then_zn
                    fio1 = fio1 & one_
                End If
            Next i
            shablon_ = fio1
        Else
            Set gen = ThisWorkbook.Sheets("gen")
            sh_split0 = Split(shablon, "!!")(1)
            mas = Split(sh_split0, ";")
            For Each i In mas
                sh_split = Split(i, "#")
                zn = sh_split(0)
                col_zn = sh_split(1)
                sh_zn = sh_split(2)
                If InStr(text, zn) > 0 Then
                    text_ = Split(gen.Cells(rrow, CInt(col_zn)).Value, " ")
                    f___$ = text_(0):i___$ = text_(1):o___$ = text_(2)
                    f_i_o = Split(DativeCase(f___, i___, o___), " ")
                    f__ = f_i_o(0):i__ = f_i_o(1):o__ = f_i_o(2)
                    fiosh = Split(sh_zn, "_")
                    For Each one In fiosh:If one = "дф" Then:one_ = Left(f__, 1) & ".":End If
                        If one = "ди" Then:one_ = Left(i__, 1) & ".":End If
                        If one = "до" Then:one_ = Left(o__, 1) & ".":End If
                        If one = "дфф" Then:one_ = f__:End If
                        If one = "рфф" Then:rodtext = Split(GenitiveCase(f___, i___, o___), " "):one_ = rodtext(0):End If
                        If one = "дии" Then:one_ = i__:End If
                        If one = "доо" Then:one_ = o__:End If
                        If one = "ф" Then:one_ = Left(text_(0), 1) & ".":End If
                        If one = "и" Then:one_ = Left(text_(1), 1) & ".":End If
                        If one = "о" Then:one_ = Left(text_(2), 1) & ".":End If
                        If one = "фф" Then:one_ = text_(0):End If
                        If one = "ии" Then:one_ = text_(1):End If
                        If one = "оо" Then:one_ = text_(2):End If
                        If one = " " Then:one_ = " ":End If
                        If one = "ыйая" Then:one_ = f_i_o(3):End If
                        If one = "asis" Then:one_ = text:End If
                        fio1 = fio1 & one_:one_ = ""
                    Next one
                    fio2 = fio2 & fio1
                Else
                    fio2 = text
                End If
            Next i
        shablon_ = fio2
        End If
    End If
End Function

split_.vba

Function split_(text_split$, split_symbols)
    'ex1 = split_("1[2]3_4[5]", [{"[", "]"}]) 'return [{"1","2","3_4","5",empty}]
    On Error Resume Next: Err.Clear
    For Each char_ In split_symbols: text_split$ = IIf(InStr(text_split$, char_) > 0, Replace(text_split$, char_, "!!!@@@!!!"), text_split$): Next char_
    split_ = Split(text_split$, "!!!@@@!!!")
End Function

split_val.vba

Function split_val(text_split$, split_symbols)
    'ex1 = split_val("1[2]3_4[5]", [{"[", "]", "{", "}", "<", ">", "(", ")"}]) 'return [{"2","5"}]
    'ex2 = split_val("1@2@3@4@5]", [{"@"}]) 'return [{"2","4"}]
    On Error Resume Next: Err.Clear
    split_tmp = split_(text_split$, split_symbols): count_ = UBound(split_tmp, 1): ii = 0: i = 0 
    While i < count_: ii = count_ - 1 - i: nnew_ = IIf(i = 0, split_tmp(ii), split_tmp(ii) & " " & nnew_): i = i + 2: Wend
    split_val = Split(nnew_, " ")
End Function

tele.vba

Function interiorist_clear()
    ThisWorkbook.Sheets("general").Range("A:B").Clear
    'ThisWorkbook.Sheets("general").Range("B:B").NumberFormat = "m/d/yyyy"
    ThisWorkbook.Sheets("general").Range("C:G").Clear

    ThisWorkbook.Sheets("general").Range("A1:G1").Font.Bold = True
    ThisWorkbook.Sheets("general").Range("A:A").Font.Bold = True
    
    ThisWorkbook.Sheets("general").Range("A:G").HorizontalAlignment = xlRight
    ThisWorkbook.Sheets("general").Range("A:G").VerticalAlignment = xlCenter
    
    ThisWorkbook.Sheets("general").Cells(1, 1).Value = "Название"
    
    ThisWorkbook.Sheets("general").Cells(1, 2).Value = "Время"
    ThisWorkbook.Sheets("general").Cells(1, 3).Value = "V_т1"
    ThisWorkbook.Sheets("general").Cells(1, 4).Value = "V_т2"
    'ThisWorkbook.Sheets("general").Cells(1, 5).Value = "V_т3"
    ThisWorkbook.Sheets("general").Cells(1, 5).Value = "Среднесуточный V1"
    ThisWorkbook.Sheets("general").Cells(1, 6).Value = "Среднесуточный V2"
    'ThisWorkbook.Sheets("general").Cells(1, 8).Value = "Среднесуточный V3"

    ThisWorkbook.Sheets("general").Range("A1:G1").Interior.ColorIndex = 15
End Function

Private Sub Comm(path_db As String)

    days = Int(TextBox1.Value) + 1
    If days <= 9 Then
        days = "0" & days
    End If
    daypo = Int(TextBox4.Value) + 1
    If daypo <= 9 Then
        daypo = "0" & daypo
    End If
    mons = Int(TextBox2.Value)
    If mons <= 9 Then
        mons = "0" & mons
    End If
    monpo = Int(TextBox5.Value)
    If monpo <= 9 Then
        monpo = "0" & monpo
    End If
    ys = Int(TextBox3.Value)
    ypo = Int(TextBox6.Value)
    
    razn = daypo - days + 1
    
    interiorist_clear
    '#2013-08-01 13:00#
    data_begin = "#" & ys & "-" & mons & "-" & days & " 13:00#"
    data_end = "#" & ypo & "-" & monpo & "-" & daypo & " 13:00#"
    
    pathh = path_db
    Set dbs = DAO.OpenDatabase(pathh)
    zapros = "SELECT N.Название, MIN(G.Время), MAX(G.Время), SUM(G.V_т1), SUM(G.V_т2), SUM(G.V_т3) FROM G761_ARCHIVE G LEFT OUTER JOIN NODES N ON (G.PARENT_ID = N.ID AND G.Type = 1 AND G.Время >= " & data_begin & " AND G.Время <= " & data_end & ") GROUP BY N.Название UNION ALL SELECT N.Название, MIN(G.Время), MAX(G.Время), SUM(G.V_т1), SUM(G.V_т2), SUM(G.V_т3) FROM G761N_ARCHIVE G LEFT OUTER JOIN NODES N ON (G.PARENT_ID = N.ID AND G.Type = 1 AND G.Время >= " & data_begin & " AND G.Время <= " & data_end & ") GROUP BY N.Название ORDER BY N.Название"
    Set query = dbs.OpenRecordset(zapros)
    zapros_count = query.RecordCount
    Application.StatusBar = zapros_count
    I = 2
    Do While Not query.EOF
        ThisWorkbook.Sheets("general").Cells(I, 1).Value = query.Fields(0).Value
        ThisWorkbook.Sheets("general").Cells(I, 3).Value = query.Fields(3).Value
        ThisWorkbook.Sheets("general").Cells(I, 4).Value = query.Fields(4).Value
        'ThisWorkbook.Sheets("general").Cells(I, 5).Value = query.Fields(5).Value
        ThisWorkbook.Sheets("general").Cells(I, 2).Value = Replace(query.Fields(1).Value - 1, " 13:00:00", "") & " - " & Replace(query.Fields(2).Value - 1, " 13:00:00", "")
        ThisWorkbook.Sheets("general").Cells(I, 5).Value = query.Fields(3).Value / razn
        ThisWorkbook.Sheets("general").Cells(I, 6).Value = query.Fields(4).Value / razn
        'ThisWorkbook.Sheets("general").Cells(I, 8).Value = query.Fields(5).Value / razn
        With ThisWorkbook.Sheets("general").Range("A" & I & ":G" & I).Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With ThisWorkbook.Sheets("general").Range("A" & I & ":G" & I).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        I = I + 1
        query.MoveNext
    Loop
    ThisWorkbook.Sheets("general").Columns("A:G").EntireColumn.AutoFit
    'ThisWorkbook.Sheets("general").Columns("B:B").ColumnWidth = 20
    'ThisWorkbook.Sheets("general").Columns("C:E").NumberFormat = "0"
    'ThisWorkbook.Sheets("general").Columns("F:G").NumberFormat = "#,##0.000"
    query.Close
    Set query = Nothing
    dbs.Close
    Set dbs = Nothing
End Sub

Private Sub CheckBox3_Click()
    If CheckBox3.Value = True Then
        TextBox1.Value = Day(Now - 2)
        TextBox4.Value = Day(Now - 1)
        TextBox2.Value = Month(Now - 1)
        TextBox5.Value = Month(Now - 1)
        TextBox3.Value = Year(Now - 1)
        TextBox6.Value = Year(Now - 1)
    End If
End Sub

Private Sub CommandButton1_Click()
    Dim I As Integer, J As Integer
    cur = ActiveSheet.Name
    For I = 1 To Sheets.Count - 1
        For J = I + 1 To Sheets.Count
            If UCase(Sheets(I).Name) > UCase(Sheets(J).Name) Then
                Sheets(J).Move Before:=Sheets(I)
            End If
        Next J
    Next I
    Sheets(cur).Select
End Sub
Function FileExists2(path, fname) As Boolean
    With Application.FileSearch
    .NewSearch
    .Filename = fname
    .LookIn = path
    .Execute
    If .FoundFiles.Count = 1 Then
    FileExists2 = True
    Else
    FileExists2 = False
    End If
    End With
End Function
Private Sub CommandButton10_Click()
    fname10 = "K:\ОДС\Сменный Диспетчер\РАБОЧАЯ\Ежедневные\"
    fname1 = "СВОДКА_АЛТАЙ_И_РА*.rar"
    fname20 = "K:\ОДС\Сменный Диспетчер\РАБОЧАЯ\Ежедневные\"
    fname2 = "СУТКИ__*.rar"
    If FileExists2(fname10, fname1) Then
    Kill fname10 & fname1
    End If
    If FileExists2(fname20, fname2) Then
        Kill fname20 & fname2
    End If
End Sub

Private Sub CommandButton11_Click()
    If CheckBox3.Value = True Then
        x = " ЧАС."
    End If
    Label8 = "ГРС - 2 и прочие" & x
    Call Comm("\\H022-srv-11\Telemetr\Телеметрия\Телеметрия ГРС-2\MDB\PROLOG.MDB")
End Sub

Private Sub CommandButton2_Click()
    If CheckBox3.Value = True Then
        x = " ЧАС."
    End If
    Label8 = "НОВОАЛТАЙСК" & x
    Call Comm("\\H022-srv-11\Telemetr\Телеметрия\Телеметрия ГРС-Новоалтайская\MDB\prolog.mdb")
End Sub

Private Sub CommandButton3_Click()
    If CheckBox3.Value = True Then
        x = " ЧАС."
    End If
    Label8 = "БИЙСК" & x
    Call Comm("\\H022-srv-11\Telemetr\Телеметрия\Телеметрия ГРС-Бийск\MDB\prolog.mdb")
End Sub

Private Sub CommandButton4_Click()
    If CheckBox3.Value = True Then
        x = " ЧАС."
    End If
    Label8 = "ГРС - 1" & x
    Call Comm("\\H022-srv-11\Telemetr\Телеметрия\Телеметрия ГРС-1\MDB\PROLOG.MDB")
End Sub

Private Sub CommandButton5_Click()
    If CheckBox3.Value = True Then
        x = " ЧАС."
    End If
    Label8 = "ГРС - 3" & x
    Call Comm("\\H022-srv-11\Telemetr\Телеметрия\Телеметрия ГРС-3\MDB\PROLOG.MDB")
End Sub

Private Sub CommandButton6_Click()
    If CheckBox3.Value = True Then
        x = " ЧАС."
    End If
    Label8 = "МТС" & x
    Call Comm("\\H022-srv-11\Telemetr\Телеметрия\Телеметрия МТС\MDB\prolog.mdb")
End Sub

Private Sub CommandButton7_Click()
    TextBox1.Value = Day(Now - 1)
    TextBox4.Value = Day(Now - 1)
    TextBox2.Value = Month(Now - 1)
    TextBox5.Value = Month(Now - 1)
    TextBox3.Value = Year(Now - 1)
    TextBox6.Value = Year(Now - 1)
End Sub

Private Sub CommandButton8_Click()
    On Error Resume Next
    Program = "c:\Special\svodka.bat"
    TaskID = Shell(Program, vbMinimizedFocus)
    If Err <> 0 Then
        MsgBox "АХТУНГ", vbCritical, "Прячься под стол!!!"
    End If
End Sub

Private Sub CommandButton9_Click()
    On Error Resume Next
    Program = "c:\Special\sutki.bat"
    TaskID = Shell(Program, 1)
    If Err <> 0 Then
        MsgBox "АХТУНГ", vbCritical, "Прячься под стол!!!"
    End If
End Sub

Public Sub Worksheet_SelectionChange(ByVal Target As Range)
    CommandButton2.Top = ActiveCell.Top + 30
    CommandButton3.Top = ActiveCell.Top + 60
    CommandButton4.Top = ActiveCell.Top + 90
    CommandButton11.Top = ActiveCell.Top + 120
    CommandButton5.Top = ActiveCell.Top + 150
    CommandButton6.Top = ActiveCell.Top + 180
    CommandButton1.Top = ActiveCell.Top + 330
    CommandButton8.Top = ActiveCell.Top + 225
    CommandButton9.Top = ActiveCell.Top + 255
    CommandButton10.Top = ActiveCell.Top + 300
    CheckBox1.Top = ActiveCell.Top + 120
    CheckBox2.Top = ActiveCell.Top + 150
    CheckBox3.Top = ActiveCell.Top + 180
    CommandButton7.Top = ActiveCell.Top + 90
    
    CommandButton7.Left = Application.Width - 300
    CheckBox1.Left = Application.Width - 300
    CheckBox2.Left = Application.Width - 300
    CheckBox3.Left = Application.Width - 300
    
    CommandButton2.Left = Application.Width - 150
    CommandButton3.Left = Application.Width - 150
    CommandButton4.Left = Application.Width - 150
    CommandButton5.Left = Application.Width - 150
    CommandButton6.Left = Application.Width - 150
    CommandButton1.Left = Application.Width - 150
    CommandButton8.Left = Application.Width - 150
    CommandButton9.Left = Application.Width - 150
    CommandButton10.Left = Application.Width - 150
    CommandButton11.Left = Application.Width - 150
    
    TextBox3.Top = ActiveCell.Top + 30
    TextBox2.Top = ActiveCell.Top + 30
    TextBox1.Top = ActiveCell.Top + 30
    TextBox6.Top = ActiveCell.Top + 60
    TextBox5.Top = ActiveCell.Top + 60
    TextBox4.Top = ActiveCell.Top + 60
    Label1.Top = ActiveCell.Top + 35
    Label2.Top = ActiveCell.Top + 65
    
    Label3.Top = ActiveCell.Top + 10
    Label4.Top = ActiveCell.Top + 10
    Label5.Top = ActiveCell.Top + 10
    
    Label8.Top = ActiveCell.Top - 45
    Label7.Top = ActiveCell.Top - 75
    
    TextBox3.Left = Application.Width - 250
    TextBox2.Left = Application.Width - 250 - 38
    TextBox1.Left = Application.Width - 250 - 38 - 37
    TextBox6.Left = Application.Width - 250
    TextBox5.Left = Application.Width - 250 - 38
    TextBox4.Left = Application.Width - 250 - 38 - 37
    Label1.Left = Application.Width - 250 - 38 - 37 - 37
    Label2.Left = Application.Width - 250 - 38 - 37 - 37
    Label5.Left = Application.Width - 230
    Label4.Left = Application.Width - 230 - 36 - 15
    Label3.Left = Application.Width - 230 - 38 - 37 - 15
    
    Label7.Left = Application.Width - 300
    Label8.Left = Application.Width - 300
    
    TextBox3.Height = 25
    TextBox2.Height = 25
    TextBox1.Height = 25
    TextBox6.Height = 25
    TextBox5.Height = 25
    TextBox4.Height = 25
    Label1.Height = 25
    Label2.Height = 25
    
    Label3.Height = 25
    Label4.Height = 25
    Label5.Height = 25
    
    Label8.Height = 25
    Label7.Height = 25
    
    CommandButton2.Height = 25
    CommandButton3.Height = 25
    CommandButton4.Height = 25
    CommandButton5.Height = 25
    CommandButton6.Height = 25
    CommandButton1.Height = 25
    CommandButton8.Height = 25
    CommandButton9.Height = 25
    CommandButton10.Height = 25
End Sub

timer_second.vba

Function timer_second(sec As Integer)
    On Error Resume Next: Err.Clear
    time_begin = Timer
    time_end = Timer
    While time_begin < time_end + (sec)
        time_begin = Timer
    Wend
End Function

uni_array.vba

Function uni_array(massiv As Variant, ch As Integer)
    Dim NewMyArray, MyArray, D, mas() As String
    On Error Resume Next: Err.Clear
    Set D = CreateObject("Scripting.Dictionary"): MyArray = massiv
    For i = 1 To UBound(MyArray, 1)
        If MyArray(i, ch) <> "" Then
            If D.Exists(CStr(MyArray(i, ch))) = False Then
                D.Add CStr(MyArray(i, ch)), MyArray(i, ch)
            End If
        End If
    Next i
    NewMyArray = D.items
    ReDim mas(D.Count - 1)
    ii = 0
    For Each a In D
        mas(ii) = a: ii = ii + 1
    Next a
    uni_array = mas
End Function

unstick_cell_from_select.vba

Function unstick_cell_from_select()
    Dim r As Range
    On Error Resume Next: Err.Clear
    For Each r In Selection
        If r.Value <> "" Then
            If r.MergeCells Then
            value_ = r.Value:r.Select:r.UnMerge
            For Each r_ In Selection
                r_.Value = value_:r_.Interior.ColorIndex = 35
            Next r_
            End If
        End If
    Next r
End Function

using_form.vba

Public exit_ As Boolean
Public print_ As Boolean
Public f As New form
Public ret As Boolean
Public mnum As Integer
Public uniparam As Integer
Public full_v As Double

Public Sub Auto_Open()
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    exit_ = True
    print_ = False
    full_v = 0
    uniparam = 1
    f.create_form "Опись папки потребителя", 4, 3
    na4 = 30
    shag = 15
    param = 2
    f.create_opb "ИП", "testip", "off", 50, 15, 75, na4 + param * shag
    param = param + 1
    f.create_opb "ФЗ", "testipfz", "off", 50, 15, 75, na4 + param * shag
    param = param + 1
    f.create_opb "Предприятие", "testneip", "off", 50, 15, 75, na4 + param * shag
    f.dial.Show
    optzn = f.dial.Shapes(4).DrawingObject.Value
    optzn__ = f.dial.Shapes(3).DrawingObject.Value
    optzn_ = f.dial.Shapes(2).DrawingObject.Value
    If optzn = 1 Then
         mas_checkbox = Array( _
            "Паспорт покупателя газа", _
            "Свидетельство статистики", _
            "Устав", _
            "Назначение руководителя", _
            "Письмо по предоплате", _
            "ИНН", _
            "ОГРН", _
            "Справка из банка" _
            )
         mas_checkbox_whith_no = Array( _
            "Паспорт покупателя газа", _
            "Свидетельство статистики", _
            "Устав", _
            "Назначение руководителя", _
            "Письмо по предоплате", _
            "ИНН", _
            "ОГРН" _
            )
         mas_button = Array("Готово", "Отмена")
         param = param + 1
         f.create_la "Введите наименование предприятия", "test", 500, 15, 75, na4 + param * shag
         param = param + 1
         f.create_eb , "obj_name_full", 500, 15, 75, na4 + param * shag
         param = param + 1
         f.create_la "Введите наименование предприятия для корешка папки", "test", 500, 15, 75, na4 + param * shag
         param = param + 1
         f.create_eb , "obj_name_papka", 500, 15, 75, na4 + param * shag
         param = param + 2
         f.create_la "Выберите ГРС", "test", , , 75, na4 + param * shag
         f.create_dd 20, "drdo", "list_03!A1", "list_03!B1:B20", , , 155, na4 + param * shag
         f.create_but "Напечатать корешок", "print_k", 120, 15, 575, na4 + (param - 2) * shag, True, False '15
         param = param + 2
         For Each elem In mas_checkbox
             f.create_chb elem + "", "test", "off", 500, 15, 75, na4 + param * shag
             param = param + 1
         Next elem
         param = param + 2
         f.create_but "Добавить объект", "open_object", 500, 15, 75, na4 + param * shag, True, False '15
         f.create_but "Готово", "gotovo", 500, 15, 75, na4 + (param + 2) * shag, True, False '15
         f.create_but "Отмена", "esc", 500, 15, 75, na4 + (param + 3) * shag, True, True
prev:
         ret = False
         f.dial.Show
         If ret Then
             GoTo prev
         End If
             Sheets("papka").Range("A1:U1").ShrinkToFit = True
             Sheets("papka").Range("A1:U1").WrapText = False
             Sheets("papka").Range("A1:U1") = f.dial.Shapes("obj_name_papka").DrawingObject.Caption
         If print_ = True Then
             print_ = False
             Call print_papka
             GoTo prev
         End If
         If exit_ = False Then
             For Each elem In mas_checkbox_whith_no
                 If f.dial.Shapes(elem).DrawingObject.Value <> 1 Then
                     f.dial.Shapes(elem).DrawingObject.Value = 1
                     f.dial.Shapes(elem).DrawingObject.Caption = f.dial.Shapes(elem).DrawingObject.Caption & "  (НЕТ)"
                 End If
             Next elem
             f.read_item , True 'mnum
             f.create_doc_obj
             f.create_doc
             f.print_ f.dial.Shapes("obj_name_full").DrawingObject.Caption & " (" & full_v & " млн.м.куб)" & Chr(13), 16, True, False, 0, 0, 0, 1
             f.print_ f.text_, 12, False, False, 0, 0, 0, 0
             f.save_doc f.dial.Shapes("obj_name_papka").DrawingObject.Caption
             f.delete_form
             Set f = Nothing
         Else
             f.delete_form
             Set f = Nothing
         End If
         uniparam = 1
     End If
     
     If optzn_ = 1 Then
         mas_checkbox = Array( _
            "Паспорт покупателя газа", _
            "Свидетельство статистики", _
            "Паспорт гражданина РФ", _
            "Письмо по предоплате", _
            "ИНН", _
            "ОГРН", _
            "Справка из банка" _
            )
         mas_checkbox_whith_no = Array( _
            "Паспорт покупателя газа", _
            "Свидетельство статистики", _
            "Паспорт гражданина РФ", _
            "Письмо по предоплате", _
            "ИНН", _
            "ОГРН" _
            )
         mas_button = Array("Готово", "Отмена")
         param = param + 1
         f.create_la "Введите наименование предприятия", "test", 500, 15, 75, na4 + param * shag
         param = param + 1
         f.create_eb , "obj_name_full", 500, 15, 75, na4 + param * shag
         param = param + 1
         f.create_la "Введите наименование предприятия для корешка папки", "test", 500, 15, 75, na4 + param * shag
         param = param + 1
         f.create_eb , "obj_name_papka", 500, 15, 75, na4 + param * shag
         f.dial.Shapes("obj_name_full").DrawingObject.Caption = "ИП "
         f.dial.Shapes("obj_name_papka").DrawingObject.Caption = "ИП "
         param = param + 2
         f.create_la "Выберите ГРС", "test", , , 75, na4 + param * shag
         f.create_dd 20, "drdo", "list_03!A1", "list_03!B1:B20", , , 155, na4 + param * shag
         f.create_but "Напечатать корешок", "print_k", 120, 15, 575, na4 + (param - 2) * shag, True, False '15
         param = param + 2
         For Each elem In mas_checkbox
             f.create_chb elem + "", "test", "off", 500, 15, 75, na4 + param * shag
             param = param + 1
         Next elem
         param = param + 2
         f.create_but "Добавить объект", "open_object", 500, 15, 75, na4 + param * shag, True, False '15
         f.create_but "Готово", "gotovo", 500, 15, 75, na4 + (param + 2) * shag, True, False '15
         f.create_but "Отмена", "esc", 500, 15, 75, na4 + (param + 3) * shag, True, True
prev2:
         ret = False
         f.dial.Show
         If ret Then
             GoTo prev2
         End If
             Sheets("papka").Range("A1:U1").ShrinkToFit = True
             Sheets("papka").Range("A1:U1").WrapText = False
         Sheets("papka").Range("A1:U1") = f.dial.Shapes("obj_name_papka").DrawingObject.Caption
         If print_ = True Then
             print_ = False
             Call print_papka
             GoTo prev2
         End If
         If exit_ = False Then
             For Each elem In mas_checkbox_whith_no
                 If f.dial.Shapes(elem).DrawingObject.Value <> 1 Then
                     f.dial.Shapes(elem).DrawingObject.Value = 1
                     f.dial.Shapes(elem).DrawingObject.Caption = f.dial.Shapes(elem).DrawingObject.Caption & "  (НЕТ)"
                 End If
             Next elem
             f.read_item , True 'mnum
             f.create_doc_obj
             f.create_doc
             f.print_ f.dial.Shapes("obj_name_full").DrawingObject.Caption & " (" & full_v & " млн.м.куб)" & Chr(13), 16, True, False, 0, 0, 0, 1
             f.print_ f.text_, 12, False, False, 0, 0, 0, 0
             f.save_doc f.dial.Shapes("obj_name_papka").DrawingObject.Caption
             f.delete_form
             Set f = Nothing
         Else
             f.delete_form
             Set f = Nothing
         End If
         uniparam = 1
    End If
    
    If optzn__ = 1 Then
         mas_checkbox = Array( _
            "Паспорт покупателя газа", _
            "Паспорт гражданина РФ", _
            "Письмо по предоплате" _
            )
         mas_checkbox_whith_no = Array( _
            "Паспорт покупателя газа", _
            "Паспорт гражданина РФ", _
            "Письмо по предоплате" _
            )
         mas_button = Array("Готово", "Отмена")
         param = param + 1
         f.create_la "Введите наименование предприятия", "test", 500, 15, 75, na4 + param * shag
         param = param + 1
         f.create_eb , "obj_name_full", 500, 15, 75, na4 + param * shag
         param = param + 1
         f.create_la "Введите наименование предприятия для корешка папки", "test", 500, 15, 75, na4 + param * shag
         param = param + 1
         f.create_eb , "obj_name_papka", 500, 15, 75, na4 + param * shag
         f.dial.Shapes("obj_name_full").DrawingObject.Caption = "ФЗ "
         f.dial.Shapes("obj_name_papka").DrawingObject.Caption = "ФЗ "
         param = param + 2
         f.create_la "Выберите ГРС", "test", , , 75, na4 + param * shag
         f.create_dd 20, "drdo", "list_03!A1", "list_03!B1:B20", , , 155, na4 + param * shag
         f.create_but "Напечатать корешок", "print_k", 120, 15, 575, na4 + (param - 2) * shag, True, False '15
         param = param + 2
         For Each elem In mas_checkbox
             f.create_chb elem + "", "test", "off", 500, 15, 75, na4 + param * shag
             param = param + 1
         Next elem
         param = param + 2
         f.create_but "Добавить объект", "open_object", 500, 15, 75, na4 + param * shag, True, False '15
         f.create_but "Готово", "gotovo", 500, 15, 75, na4 + (param + 2) * shag, True, False '15
         f.create_but "Отмена", "esc", 500, 15, 75, na4 + (param + 3) * shag, True, True
prevfz:
         ret = False
         f.dial.Show
         If ret Then
             GoTo prevfz
         End If
             Sheets("papka").Range("A1:U1").ShrinkToFit = True
             Sheets("papka").Range("A1:U1").WrapText = False
         Sheets("papka").Range("A1:U1") = f.dial.Shapes("obj_name_papka").DrawingObject.Caption
         If print_ = True Then
             print_ = False
             Call print_papka
             GoTo prevfz
         End If
         If exit_ = False Then
             For Each elem In mas_checkbox_whith_no
                 If f.dial.Shapes(elem).DrawingObject.Value <> 1 Then
                     f.dial.Shapes(elem).DrawingObject.Value = 1
                     f.dial.Shapes(elem).DrawingObject.Caption = f.dial.Shapes(elem).DrawingObject.Caption & "  (НЕТ)"
                 End If
             Next elem
             f.read_item , True 'mnum
             f.create_doc_obj
             f.create_doc
             f.print_ f.dial.Shapes("obj_name_full").DrawingObject.Caption & " (" & full_v & " млн.м.куб)" & Chr(13), 16, True, False, 0, 0, 0, 1
             f.print_ f.text_, 12, False, False, 0, 0, 0, 0
             f.save_doc f.dial.Shapes("obj_name_papka").DrawingObject.Caption
             f.delete_form
             Set f = Nothing
         Else
             f.delete_form
             Set f = Nothing
         End If
         uniparam = 1
    End If
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
Sub add__element(name_, param)
    na4 = 30
    shag = 15
    f.create_la "• " & name_ + "", "test", 400, 15, 700, na4 + param * shag
End Sub
Sub test()
    'action null
End Sub
Sub testip()
f.dial.Hide
f.dial.Shapes("opbtestneip").DrawingObject.Visible = False
f.dial.Shapes("opbtestip").DrawingObject.Visible = False
f.dial.Shapes("opbtestipfz").DrawingObject.Visible = False
End Sub
Sub testneip()
f.dial.Hide
f.dial.Shapes("opbtestneip").DrawingObject.Visible = False
f.dial.Shapes("opbtestip").DrawingObject.Visible = False
f.dial.Shapes("opbtestipfz").DrawingObject.Visible = False
'f.dial.Hide
End Sub
Sub testipfz()
f.dial.Hide
f.dial.Shapes("opbtestneip").DrawingObject.Visible = False
f.dial.Shapes("opbtestip").DrawingObject.Visible = False
f.dial.Shapes("opbtestipfz").DrawingObject.Visible = False
'f.dial.Hide
End Sub
Sub print_papka()
    Sheets("papka").Range("A1:U1").ShrinkToFit = True
    Sheets("papka").Range("A1:U1").WrapText = False
    Sheets("papka").Range("A1:U1") = f.dial.Shapes("obj_name_papka").DrawingObject.Caption
    Call drdo
If Len(f.dial.Shapes("obj_name_papka").DrawingObject.Caption) > 3 Then

Sheets("papka").PrintOut Copies:=1, Collate:=True

End If
End Sub
Sub drdo()
    cell_row = Sheets("list_03").[A1]
    cell_zn = Sheets("list_03").Cells(cell_row, "B")
    Sheets("papka").[V1] = cell_zn
    If cell_zn = "1" Or cell_zn = "2" Or cell_zn = "3" Then
    Sheets("papka").[V1].Font.Size = 26
    Else
    Sheets("papka").[V1].Font.Size = 18
    End If
End Sub

Sub gotovo()
exit_ = False

End Sub
Sub esc()
exit_ = True

End Sub
Sub print_k()
print_ = True
End Sub
Sub open_object()
 Dim f1 As New form
    On Error Resume Next
    exit_ = True
    f1.create_form "Опись папки потребителя", 3, 3
    na4 = 30
    shag = 15
    mas_checkbox = Array( _
        "Разрешение АЛПУ", _
        "Разрешение ГГБ", _
        "Согласование ГМН филиал в АК", _
        "Разрешение Газпром", _
        "Разрешение ГТТ", _
        "Акт РБП", _
        "Теплотехнический расчёт", _
        "Регистрация расчёта" _
        )
    mas_checkbox_whith_no = Array( _
        "Разрешение АЛПУ", _
        "Разрешение ГГБ", _
        "Согласование ГМН филиал в АК", _
        "Акт РБП", _
        "Теплотехнический расчёт", _
        "Регистрация расчёта" _
        )
    mas_checkbox_whith_big_1tut = Array( _
        "Разрешение Газпром", _
        "Разрешение ГТТ" _
        )
    mas_button = Array("Готово", "Отмена")
    param = 1
    f1.create_la "Введите адрес котельной", "test", 500, 15, 75, na4 + param * shag
    param = param + 1
    f1.create_eb , "obj", 500, 15, 75, na4 + param * shag
    param = param + 1
    f1.create_la "Введите разрешённый объём в млн.м.куб.", "test", 500, 15, 75, na4 + param * shag
    param = param + 1
    f1.create_eb "num", "obj1", 500, 15, 75, na4 + param * shag
    param = param + 2
    For Each elem In mas_checkbox
        f1.create_chb elem + "", "test", "off", 500, 15, 75, na4 + param * shag
        param = param + 1
    Next elem
    param = param + 1
    f1.create_opb "Право собственности: Собственность", "test", "off", 500, 15, 75, na4 + param * shag
    param = param + 1
    f1.create_opb "Право собственности: Аренда", "test", "off", 500, 15, 75, na4 + param * shag
    param = param + 1
    f1.create_opb "Право собственности: Долевая собственность", "test", "off", 500, 15, 75, na4 + param * shag
    param = param + 1
    f1.create_opb "Право собственности: Гарантийное письмо", "test", "off", 500, 15, 75, na4 + param * shag
    param = param + 1
    f1.create_opb "Право собственности: Безвременное пользование", "test", "off", 500, 15, 75, na4 + param * shag
    param = param + 1
    f1.create_opb "Право собственности: Не все документы!!!", "test", "off", 500, 15, 75, na4 + param * shag
    param = param + 1
    f1.create_opb "Право собственности: Нет документов", "test", "on", 500, 15, 75, na4 + param * shag
    param = param + 1
    
    
    f1.create_but "Готово", "gotovo", 500, 15, 75, na4 + (param + 2) * shag, True, False '15
    f1.create_but "Отмена", "esc", 500, 15, 75, na4 + (param + 3) * shag, True, True
    f1.dial.Show
        If exit_ = False Then
        For Each elem In mas_checkbox_whith_no
            If f1.dial.Shapes(elem).DrawingObject.Value <> 1 Then
                
                    f1.dial.Shapes(elem).DrawingObject.Value = 1
                    f1.dial.Shapes(elem).DrawingObject.Caption = f1.dial.Shapes(elem).DrawingObject.Caption & "  (НЕТ)"
                
            End If
            
        Next elem
        
        For Each elem In mas_checkbox_whith_big_1tut
            If f1.dial.Shapes(elem).DrawingObject.Value <> 1 Then
            If Round(f1.dial.Shapes("obj1").DrawingObject.Caption, 9) >= 8.70647849064489E-02 Then
                f1.dial.Shapes(elem).DrawingObject.Value = 1
                f1.dial.Shapes(elem).DrawingObject.Caption = f1.dial.Shapes(elem).DrawingObject.Caption & "  (НЕТ)"
            End If
            End If
        Next elem
        
        
        
        f1.read_item
        f1.read_opb
        mnum = f1.meganum
        f.text_ = f.text_ & Chr(13) & "Адрес: " & f1.dial.Shapes("obj").DrawingObject.Caption & Chr(13) & "Разрешённый объём: " & f1.dial.Shapes("obj1").DrawingObject.Caption & " млн.м.куб"
        f.text_ = f.text_ & Chr(13) & f1.text_ & Chr(13) & String(33, Chr(151))
        
        full_v = full_v + Round(f1.dial.Shapes("obj1").DrawingObject.Caption, 9)
        '
        Call add__element(f1.dial.Shapes("obj").DrawingObject.Caption, uniparam)
        '
        f1.delete_form
        Set f1 = Nothing
        Else
        f1.delete_form
        Set f1 = Nothing
        End If
    
uniparam = uniparam + 1
    
    ret = True
    exit_ = True
End Sub
Sub test5()
DialogSheets(1).Delete
DialogSheets(1).Delete
DialogSheets(1).Delete
DialogSheets(1).Delete
DialogSheets(1).Delete
DialogSheets(1).Delete
DialogSheets(1).Delete
DialogSheets(1).Delete
DialogSheets(1).Delete
End Sub

using_form_2.vba

Public word_object As Variant
Public document As Variant
Public dial As Variant
Public dialog_ As Variant
Public dial_name As String
Public num_page As Integer
Public text_ As String
Public arr_all_value_ As Variant
Public meganum As Integer


'Variant
Public Sub read_item(Optional numer As Integer = 1, Optional yes As Boolean = False)
    On Error Resume Next
    If yes Then
        meganum = numer
        For Each shape_ In dial.Shapes
        If shape_.ZOrderPosition >= 2 Then
            If shape_.FormControlType = xlCheckBox Then
                If shape_.DrawingObject.Value = 1 Then
                    text_ = text_ & Chr(13) & meganum & ") " & shape_.DrawingObject.Caption
                    meganum = meganum + 1
                End If
            End If
        End If
        Next shape_
    Else
    meganum = numer
        For Each shape_ In dial.Shapes
        If shape_.ZOrderPosition >= 2 Then
        If shape_.FormControlType = xlCheckBox Then
            If shape_.DrawingObject.Value = 1 Then
                text_ = text_ & Chr(13) & "- " & shape_.DrawingObject.Caption
                meganum = meganum + 1
            End If
        End If
        End If
        Next shape_
    End If
End Sub

Public Sub read_opb(Optional numer As Integer = 1, Optional yes As Boolean = False)
    On Error Resume Next
    If yes Then
    meganum = numer
    For i = 2 To dial.Shapes.Count
    If dial.Shapes(i).FormControlType = xlOptionButton Then
        If dial.Shapes(i).DrawingObject.Value = 1 Then
            text_ = text_ & Chr(13) & meganum & ") " & dial.Shapes(i).DrawingObject.Caption
            meganum = meganum + 1
        End If
    End If
    Next
    Else
    meganum = numer
    For i = 2 To dial.Shapes.Count
    If dial.Shapes(i).FormControlType = xlOptionButton Then
        If dial.Shapes(i).DrawingObject.Value = 1 Then
            text_ = text_ & Chr(13) & "- " & dial.Shapes(i).DrawingObject.Caption
            meganum = meganum + 1
        End If
    End If
    Next
    End If



End Sub
Public Sub create_form(Optional cap As String = "Название диалога", Optional ширина As Integer = 4, Optional высота As Integer = 4.4)

    Set dial = DialogSheets.add
    'dial.Name = "tmp_dialog"
    dial_name = dial.Name
    Set dialog_ = dial.Shapes(1)
    dialog_.Name = "tmp_d"
    dialog_.AlternativeText = cap
    dialog_.DrawingObject.Caption = cap
    dial.Shapes(2).Delete
    dial.Shapes(2).Delete
    dialog_.DrawingObject.ShapeRange.ScaleWidth ширина, msoFalse, msoScaleFromTopLeft
    dialog_.DrawingObject.ShapeRange.ScaleHeight высота, msoFalse, msoScaleFromTopLeft
    dial.Visible = False
    
End Sub
Public Sub delete_form(Optional cap As String = "Название диалога", Optional ширина As Integer = 4, Optional высота As Integer = 4.4)

    dial.Visible = False
    dial.Delete
    
End Sub
Public Sub create_chb(Optional cap As String = "Название диалога", Optional action_ As String = "Название диалога", Optional on_off As String = "off", Optional ширина As Integer = 200, Optional высота As Integer = 20, Optional влево As Integer = 0, Optional вниз As Integer = 0)
    On Error Resume Next
    Set chb = dial.CheckBoxes.add(влево, вниз, ширина, высота) 'право-лево верх-низ ширина высота
    chb.Name = cap
    chb.Caption = "  " & cap
    chb.OnAction = action_
    
    If on_off = "off" Then
        chb.Value = xlOff
    Else
        chb.Value = xlOn
    End If

 
End Sub
Public Sub create_opb(Optional cap As String = "Название диалога", Optional action_ As String = "Название диалога", Optional on_off As String = "off", Optional ширина As Integer = 200, Optional высота As Integer = 20, Optional влево As Integer = 0, Optional вниз As Integer = 0)
    On Error Resume Next
    Set opb = dial.OptionButtons.add(влево, вниз, ширина, высота) 'право-лево верх-низ ширина высота
    opb.Caption = "  " & cap
    opb.Name = "opb" + action_
    opb.OnAction = action_
    
    If on_off = "off" Then
        opb.Value = xlOff
    Else
        opb.Value = xlOn
    End If
 
End Sub

Public Sub create_but(Optional cap As String = "Название диалога", Optional action_ As String = "Название диалога", Optional ширина As Integer = 200, Optional высота As Integer = 20, Optional влево As Integer = 0, Optional вниз As Integer = 0, Optional ok_ As Boolean = False, Optional esc_ As Boolean = False)
    On Error Resume Next
    Set but = dial.Buttons.add(влево, вниз, ширина, высота) 'право-лево верх-низ ширина высота
    but.Caption = "  " & cap
    but.OnAction = action_
    but.DismissButton = ok_
    but.CancelButton = ecs_

End Sub

Public Sub create_dd(Optional kol As Integer = 5, Optional action_ As String = "Название диалога", Optional lc As String, Optional sp As String, Optional ширина As Integer = 200, Optional высота As Integer = 20, Optional влево As Integer = 0, Optional вниз As Integer = 0)
    On Error Resume Next
    Set dd = dial.DropDowns.add(влево, вниз, ширина, высота) 'право-лево верх-низ ширина высота
    dd.OnAction = action_
    dd.Name = "dd" + action_
    dd.DropDownLines = kol
    dd.LinkedCell = lc
    dd.ListFillRange = sp
End Sub
Public Sub create_eb(Optional type_ As String = "text", Optional name_ As String = "name", Optional ширина As Integer = 200, Optional высота As Integer = 20, Optional влево As Integer = 0, Optional вниз As Integer = 0, Optional action_ As String = "test")
    On Error Resume Next
    Set eb = dial.EditBoxes.add(влево, вниз, ширина, высота) 'право-лево верх-низ ширина высота
    eb.Name = name_
    eb.OnAction = action_
    If type_ = "num" Then
    eb.InputType = xlNumber
    End If
End Sub

Public Sub create_la(Optional cap As String = "Название диалога", Optional action_ As String = "Название диалога", Optional ширина As Integer = 200, Optional высота As Integer = 20, Optional влево As Integer = 0, Optional вниз As Integer = 0)
    On Error Resume Next
    Set la = dial.Labels.add(влево, вниз, ширина, высота) 'право-лево верх-низ ширина высота
    la.Caption = cap
End Sub


Public Sub create_doc_obj()
    On Error Resume Next
    Set word_object = CreateObject("Word.Application")

End Sub


Public Sub create_doc(Optional bool_ As Boolean = True)
    On Error Resume Next
    Set document = word_object.Documents.add
    word_object.Visible = bool_

End Sub

Public Sub save_doc(Optional save_name As String = "default")
    
    On Error Resume Next
    error_symbol = Array("|", "/", "\", "«", "»", """", ".", "!", "&", "?")
    
    fname = ActiveWorkbook.Path
    
    now_month = Choose(Month(Now()), "января", "февраля", "марта", _
    "апреля", "мая", "июня", "июля", "августа", "сентября", _
    "октября", "ноября", "декабря")
       
    For Each element In error_symbol
        save_name = Replace(save_name, element, "")
    Next element
    
    sname = fname & "\" & save_name & " [" & Day(Now()) & " " & now_month & " " & Year(Now()) & "]" & "(" & Sheets("papka").[V1] & ")" & ".doc"
    
    i = 1
ret_name:
    If Dir(sname) <> "" Then
        numer = Split(sname, "__№")
        If UBound(numer, 1) > 0 Then
            sname = Replace(sname, "__№" & numer(1), "__№" & Trim(Str(Replace(numer(1), ".doc", "") + 1)) & "" & "(" & Sheets("papka").[V1] & ")" & ".doc")
            GoTo ret_name
        Else
            sname = Replace(sname, ".doc", "__№1.doc")
            GoTo ret_name
        End If
    Else
        document.SaveAs sname
    End If


End Sub


Public Sub kill_doc()
    On Error Resume Next
    document.Close False

End Sub

Public Sub kill_doc_obj()
    On Error Resume Next
    word_object.Quit
    Set word_object = Nothing

End Sub

Public Sub info_doc_numpage()
    On Error Resume Next
    num_page = document.ActiveWindow.Panes(1).Pages.Count

End Sub


Public Sub print_(Optional text_ As Variant = "", Optional fontsize_ As Integer = 14, Optional bold_ As Boolean = False, Optional italic_ As Boolean = False, Optional redline_ As Integer = 35.4, Optional margin_left_ As Integer = 240, Optional margin_right_ As Integer = 0, Optional align_ As Integer = 1)
    On Error Resume Next
    word_object.Selection.ParagraphFormat.Alignment = align_ 'справа'середина'слева'по ширине
    word_object.Selection.Font.Size = fontsize_
    word_object.Selection.Font.Bold = bold_
    word_object.Selection.Font.Italic = italic_
    word_object.Selection.ParagraphFormat.LineSpacing = 10.8
    word_object.Selection.ParagraphFormat.LeftIndent = margin_left_
    word_object.Selection.ParagraphFormat.FirstLineIndent = redline_
    word_object.Selection.text = text_ & Chr(13)
    word_object.Selection.MoveDown
End Sub