Крах оперативной памяти при выполнении макроса

Sub Start()
    'If Dir("d:\Raspechatka\.Автоматизация\log\", vbDirectory) = "" Then MkDir "d:\Raspechatka\.Автоматизация\log\"
   frmPrintPP.Show (vbModeless)
End Sub

Option Explicit
' ####### глобальные переменные #######
Dim FilesCount As Integer       ' счетчик файлов, в штуках
Dim FilesDirName As String      ' адрес и именя искомого файла
Dim Nalich_CSV As Byte          ' проверка наличия готовых к обработке файлов-заданий (0 - нет, 1 - есть)
Dim Nalich_FILE As Byte         ' факт наличия искомого файла (0 - нет, 1 - есть)
Dim Nalich_PRINTER As Byte      ' проверка наличия файла для загрузки параметров принтеров (0 - нет, 1 - есть)
Dim Nalich_VIZ As Byte          ' проверка наличия готовых к печати визиток (0 - нет, 1 - есть)
Dim PrintDo As Long             ' окончание печати по списку
Dim PrintOt As Long             ' начало печати по списку
Dim PrinterViz As Integer       ' индекс выбранного принтера на вкладке "Визитки"
Dim PrinterBrosh As Integer     ' индекс выбранного принтера на вкладке "Брошюры"
Dim PrinterSpisok As Integer    ' индекс выбранного принтера на вкладке "Список"
Dim WhatUserLuking As String    ' имя выбранной вкладки
Dim zadanie_info_file
Dim zadanie_info_program
' #####################################
 
Private Sub cboDoliaSp_Change()
    Dim for_case As String    ' тип составляемого списка
    
    Call SpisViewReload   '=== процедура: обновление внешнего вида вкладки "Список"
    for_case = cboDoliaSp.value
    If for_case = "Способ отображения..." Then
        lstSpis.Clear
        lstSpis.BackColor = &H80000004
        lstSpis.Enabled = False
     Else
        Call NapolnenieSpiska     ' наполнение списка
    End If
End Sub
 
Private Sub cboDoliaViz_Change()
    Dim rInd As Integer
    Dim strSelection As String  ' выбранный пункт списка
    Dim TruFal As Boolean
    Dim FalTru As Boolean
    
    strSelection = cboDoliaViz.value
    FalTru = True
    TruFal = False
    Select Case strSelection
    Case Is = "Текущая"
        txbCopy.BackColor = &H80000004
        txbCopy.value = Null
    Case Is = "Все"
        FalTru = True
        lstViz.ListIndex = 1
        txbCopy.BackColor = &H80000004
        txbCopy.value = Null
    Case Is = "От"
        txbCopy.BackColor = &H80000004
        txbCopy.value = Null
    Case Is = "До"
        txbCopy.BackColor = &H80000004
        txbCopy.value = Null
    Case Is = "Коррекция числа копий:"
        TruFal = True
        rInd = lstViz.ListIndex
        If rInd > 0 Then
            txbCopy.value = lstViz.List(rInd, 2)
            txbCopy.BackColor = &H80000005
          Else
            cboDoliaViz.value = "Текущая"
        End If
    End Select
    If lstViz.List(0, 0) = "Нет файлов для печати..." Then FalTru = False
    cmdCalcV.Enabled = TruFal
    lstViz.Enabled = FalTru
    txbCopy.Enabled = TruFal
End Sub
 
Private Sub cboFZad_Change()                        ' ========= выбрали файл: проанализировали =========
    chkPrinted.Enabled = False
    chkPrinted.value = False
    Call FZAnaliz        '=== процедура:
    Call AnalizInReport    '=== процедура:
    If cboFZad.value = "" _
        Or cboFZad.value = "Выберите задание..." _
        Or cboFZad.value = "Полный список.fz" _
        Or Nalich_CSV < 1 Then
        cmdArhiving.Enabled = False
     Else
        cmdArhiving.Enabled = True
    End If
End Sub
 
Private Sub cboFZSp_Change()
    If Nalich_CSV < 1 Then Exit Sub
    
    Dim strFZN As String
    Dim TruFal As Boolean
    cboKatSp.Clear                              ' очистили список категорий
    cboKatSp.value = "Выберите категорию..."
    cmdCalcS.Enabled = False
    lblAdr.Caption = "Адрес выбранного файла..."
    lblName.Caption = "Выбранный файл..."
    lstSpis.Clear
    txbCopies.BackColor = &H80000004
    txbCopies.Enabled = False
    txbCopies.value = Null
    strFZN = CStr(cboFZSp.value)
    If strFZN = "" Or strFZN = "Выберите задание..." Then TruFal = False Else TruFal = True
    cboKatSp.Enabled = TruFal
    If strFZN <> "Полный список.fz" Then cmdArhiving.Enabled = TruFal
    If TruFal Then Call SeparatorSpiska     ' наполнение списка категорий
End Sub
 
Private Sub cboKatSp_Change()
    If cboKatSp.value = "Выберите категорию..." Then Exit Sub
    cboDoliaSp.Enabled = True
    Call SpisViewReload  '=== процедура: обновление внешнего вида вкладки "Список"
    If cboDoliaSp = "Способ отображения..." Then Exit Sub
    Call NapolnenieSpiska    '=== процедура: наполнение списка
End Sub
 
Private Sub cboPrinter_Change()           ' ========= выбор принтера =========
    If cboPrinter.value <> "Укажите принтер ..." Then
        cmdPrinterProp.Enabled = True
     Else
        cmdPrinterProp.Enabled = False
    End If
    Select Case WhatUserLuking
        Case Is = "pViz"        ' если выбрана вкладка "Визитки"
            PrinterViz = cboPrinter.ListIndex
        Case Is = "pBrosh"      ' если выбрана вкладка "Брошюры и Буклеты"
            PrinterBrosh = cboPrinter.ListIndex
        Case Is = "pSpisok"     ' если выбрана вкладка "Список"
            PrinterSpisok = cboPrinter.ListIndex
    End Select
End Sub
 
Private Sub cboVizArhiv_Change()
  If cboVizArhiv.value = "Укажите файл для возврата из архива..." Or _
     cboVizArhiv.value = "В архиве файлов нет..." Then
     cmdVFromArhiv.Enabled = False
    Else
     cmdVFromArhiv.Enabled = True
  End If
End Sub
 
Private Sub cboVizArhiv_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    cboVizArhiv.ListIndex = cboVizArhiv.ListCount - 1   ' выделяем последнюю строку в списке
End Sub
 
Private Sub cboZArhiv_Change()
    If cboZArhiv.value = "Укажите файл для возврата из архива..." Or _
       cboZArhiv.value = "В архиве файлов нет..." Then
       cmdZFromArhiv.Enabled = False
     Else
       cmdZFromArhiv.Enabled = True
    End If
End Sub
 
Private Sub cboZArhiv_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    cboZArhiv.ListIndex = cboZArhiv.ListCount - 1   ' выделяем последнюю строку в списке
End Sub
 
 
Private Sub chkPrinted_Click()                         
 ' ========= выбор файла: автоматический анализ при выборе ====
    Call FZAnaliz
End Sub
 
Private Sub cmdArhiving_Click()    ' ========= кнопка: поместить в АРХИВ =========
    Select Case WhatUserLuking
        Case Is = "pBrosh"          ' если выбрана вкладка "Брошюры и Буклеты"
            Call FZToArhiv(cboFZad.value)   ' поместить в архив файл-задание
            Call FZReload         ' перезагрузка списков файлов-заданий
            Call FZReloadArhiv    ' перезагрузка списка архива файлов-заданий
        Case Is = "pSpisok"         ' если выбрана вкладка "Список"
            Call FZToArhiv(cboFZSp.value)    ' поместить в архив задание
            Call FZReload         ' перезагрузка списков файлов-заданий
            Call FZReloadArhiv    ' перезагрузка списка архива файлов-заданий
        Case Is = "pViz"            ' если выбрана вкладка "Визитки"
            Call VizToArhiv         ' поместить архив визитку
            Call VizReload          ' перезагрузка списка визиток к печати
            Call VizReloadArhiv     ' перезагрузка списка визиток в архиве
    End Select
    lstLog.ListIndex = lstLog.ListCount - 1     ' выделяем последнюю строку в отчёте
End Sub
 
Private Sub cmdCalcS_Click()
    Set objAscker = frmPrintPP.txbCopies
    frmCalc.Show
    Set objAscker = Nothing
End Sub
 
Private Sub cmdCalcV_Click()
    Set objAscker = frmPrintPP.txbCopy
    frmCalc.Show
    Set objAscker = Nothing
End Sub
 
Private Sub cmdLogClear_Click()
    lstLog.Clear     ' ========= очистка "Справочно-информационного поля" (ЛОГ)
End Sub
 
Private Sub cmdPRINT_Click()      ' ========= кнопка: ПЕЧАТЬ =========
    Dim i, iStart, iEnd As Integer  ' индексы цикла
    Dim lisInd, lisCount As Integer
    Dim msgTxt, msgTxtAdd As String
    Dim pCount As Integer
    Dim printerNm As String
    Dim ShouldArhiv As Boolean
    Dim strSelection As String  ' выбранный пункт списка
    Dim TipSpiska As String
 
    printerNm = cboPrinter.value
    If printerNm = "Укажите принтер ..." Or printerNm = "" Then
        MsgBox "УКАЖИТЕ принтер для печати.", vbQuestion, "Ошибка: не указан принтер."
        cboPrinter.SetFocus
        Exit Sub
    End If
    Select Case WhatUserLuking
        Case Is = "pBrosh"  ' если выбрано: вкладка "Брошюры и Буклеты"
             msgTxt = PrintBrosh(printerNm)             '=== процедура: печать элемента задания
             If lstMain.Enabled = True Then lstMain.SetFocus    ' установили фокус на список частей задания
        Case Is = "pSpisok" ' если выбрано: вкладка "Список"
             TipSpiska = cboDoliaSp.value
             If TipSpiska = "От и До" Or TipSpiska = "От..." Or TipSpiska = "...До" Then
                msgTxt = PrintBroshOtDo(printerNm)      '=== процедура: печать "От и До"
              Else
                msgTxt = PrintBroshSpisok(printerNm)    '=== процедура: печать элемента списка
             End If
             If lstSpis.Enabled = True Then lstSpis.SetFocus    ' установили фокус на список элементов
        Case Is = "pViz"    ' если выбрано: вкладка "Визитки"
            lisInd = lstViz.ListIndex
            lisCount = lstViz.ListCount
            If lisCount > 1 And lisInd > 0 Then
                strSelection = cboDoliaViz.value
                Select Case strSelection
                Case Is = "Текущая"
                    iStart = lisInd
                    iEnd = lisInd
                Case Is = "Все"
                    lstViz.ListIndex = 1
                    iStart = 1
                    iEnd = lisCount - 1
                Case Is = "От"
                    iStart = lisInd
                    iEnd = lisCount - 1
                Case Is = "До"
                    iStart = 1
                    iEnd = lisInd
                Case Is = "Коррекция числа копий:"
                    iStart = lisInd
                    iEnd = lisInd
                    pCount = CInt(txbCopy.value)
                End Select
                ShouldArhiv = chkVizToArh.value
                For i = iStart To iEnd
                    msgTxtAdd = msgTxtAdd & Chr(13) & lstViz.List(lstViz.ListIndex, 0)
                    If strSelection <> "Коррекция числа копий:" Then
                        pCount = pCount + lstViz.List(lstViz.ListIndex, 2)
                    End If
                    Call PrintVizitka(printerNm)    '=== процедура: печать визиток
                    If ShouldArhiv = True Then Call VizToArhiv
                    lstViz.RemoveItem (lstViz.ListIndex)    ' удаляем выполненное задание из списка заданий
                Next i
                chkVizToArh.value = True
                txbCopy.BackColor = &H80000004
                txbCopy.value = Null
                txbCopy.Enabled = False
                If ShouldArhiv = True Then Call VizReloadArhiv  ' перезагрузка архива
                'cmdArhiving.Enabled = False
                msgTxt = "Отправка визиток на печать завершена." & Chr(13) _
                        & "На принтер: " & printerNm & " отправлено " & CStr(pCount) & " страниц." _
                        & msgTxtAdd
            Else
                msgTxt = "Отпаравка на печать не возможна. Не правильно указаны параметры печати"
            End If
            If lstViz.Enabled = True Then lstViz.SetFocus   ' установили фокус на список визиток
    End Select
    If msgTxt = "" Then Exit Sub
    MsgBox msgTxt, vbInformation, "Отправка на печать визиток." ' отчитались пользователю
End Sub
 
Private Sub cmdPrinterProp_Click()       ' ========= кнопка: свойства принтера - 1 =========
    Dim retval As Double
    Dim name_print As String
    Dim printrName As String
    printrName = cboPrinter.value
    If printrName = "" Or printrName = "Укажите принтер ..." Then   ' если принтер НЕ УКАЗАН, то:
        cboPrinter.SetFocus
        Exit Sub
    End If
    name_print = "rundll32 printui.dll, PrintUIEntry /n " & Chr(34) & printrName & Chr(34) & " /p c"
    retval = Shell(name_print, 1)
End Sub
 
Private Sub cmdReload_Click()     ' ========= кнопка: ПЕРЕЗАГРУЗКА =========
    cboPrinter.value = "Укажите принтер ..."
    Select Case WhatUserLuking
        Case Is = "pBrosh"          ' если выбрано: вкладка "Брошюры и Буклеты"
            PrinterBrosh = -1       ' сбрасываем индекс выбранного принтера
            Call FZReload           ' перезагрузка списков файлов-заданий
            Call FZReloadArhiv      ' перезагрузка списка архива файлов-заданий
        Case Is = "pSpisok"         ' если выбрано: вкладка "Список"
            PrinterSpisok = -1      ' сбрасываем индекс выбранного принтера
            Call FZReload
            Call SpisReload         ' перезагрузка вкладки "Список"
            lblWellAdd.Caption = "="
        Case Is = "pViz"            ' если выбрано: вкладка "Визитки"
            PrinterViz = -1         ' сбрасываем индекс выбранного принтера
            Call VizReload          ' перезагрузка списка визиток к печати
            Call VizReloadArhiv     ' перезагрузка списка визиток в архиве
        Case Is = "pSettings"       ' если выбрано: вкладка "Переменные"
            Call ReloadPrinter      ' перезагрузка списка пиртреров
    End Select
End Sub
 
Private Sub cmdVFromArhiv_Click()
    Call VizFromArhiv
    Call VizReload
    Call VizReloadArhiv
End Sub
 
Private Sub cmdZFromArhiv_Click()           ' ========= кнопка: возврат файлов из архива =========
    Call FZFromArhiv
    Call FZReload
    Call FZReloadArhiv
End Sub
 
 
 
Private Sub lblWellAdd_Click()
    If lblWellAdd.Caption = "=" Then
        lblWellAdd.Caption = "+"
        lblWellAdd.ForeColor = &HFF&
    Else
        lblWellAdd.Caption = "="
        lblWellAdd.ForeColor = &H80000012
    End If
End Sub
 
 
Private Sub lstMain_Click()
    If Nalich_CSV < 0 Then Exit Sub
    
    Dim PrintedOrNot As Byte           ' признак (на/нена)печатано
    
    If cboFZad.value = "Выберите задание..." Or lstMain.ListIndex < 1 Then
        cmdPRINT.Enabled = False
     Else
        cmdPRINT.Enabled = True
    End If
    PrintedOrNot = 0
    On Error Resume Next
    PrintedOrNot = lstMain.List(lstMain.ListIndex, 4)
    If PrintedOrNot = 1 Then
       MsgBox "ВНИМАНИЕ: Выбрано напечатанное задание!", vbExclamation
    End If
End Sub
 
Private Sub lstMain_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ' ====== удаление записи из Задания по DblClick =
    Dim zadanie As String
    zadanie = lstMain.List(lstMain.ListIndex, 0)
    If zadanie = "Название задания:" Then Exit Sub
    lstMain.RemoveItem (lstMain.ListIndex)
    lstLog.AddItem Format(Now, "hh:mm:ss") & "  ПРИНУДИТЕЛЬНОЕ УДАЛЕНИЕ задания: [" & zadanie & "]"
    lstLog.AddItem "---------------------------------------------------------------------------------------------------------"
    lstLog.ListIndex = lstLog.ListCount - 1          ' выделяем последнюю строку в отчёте
End Sub
 
Private Sub lstSpis_Click()
    If lstSpis.ListCount = 0 Then Exit Sub
    If lstSpis.List(0, 0) = "Все элементы удалены!" Then Exit Sub
    
    Dim copies_print As Integer     ' количество копий файлов, отправляемых на печать
    Dim for_case As String          ' тип составляемого списка
    Dim OtDoSwicher As String
    Dim zadanie As String
    
    for_case = cboDoliaSp.value
    OtDoSwicher = cboOtDoSp.value
    zadanie = lstSpis.List(lstSpis.ListIndex, 0)
    Select Case for_case
       Case Is = "От и До"
          Select Case OtDoSwicher
             Case Is = "От..."
                lblName.Caption = "Начало печати:" & Chr(13) & zadanie
                PrintOt = lstSpis.ListIndex
             Case Is = "...До"
                lblAdr.Caption = "Окончание печати:" & Chr(13) & zadanie
                PrintDo = lstSpis.ListIndex
          End Select
          If PrintOt > PrintDo And lblAdr.Caption <> "Окончание печати..." Then
             MsgBox "Ничего не будет напечатано, поскольку " & Chr(34) & "Начало печати..." & Chr(34) & Chr(13) & _
                    "указано позже её " & Chr(34) & "Окончания" & Chr(34) & "!", _
                    vbCritical, _
                    "Ошибка указания " & Chr(34) & "Начальной" & Chr(34) & _
                    " и " & Chr(34) & "Конечной" & Chr(34) & " позиции отправки на печать."
          End If
       Case Is = "От..."
          lblName.Caption = "Начало печати:" & Chr(13) & zadanie
          lblAdr.Caption = "Окончание печати:" & Chr(13) & lstSpis.List(lstSpis.ListCount - 1, 0)
          PrintOt = lstSpis.ListIndex
          PrintDo = lstSpis.ListCount - 1
       Case Is = "...До"
          lblName.Caption = "Начало печати:" & Chr(13) & lstSpis.List(0, 0)
          lblAdr.Caption = "Окончание печати:" & Chr(13) & zadanie
          PrintOt = 0
          PrintDo = lstSpis.ListIndex
       Case Else
          lblName.Caption = zadanie
          lblAdr.Caption = lstSpis.List(lstSpis.ListIndex, 2)
          cmdCalcS.Enabled = True
          txbCopies.BackColor = &H80000005
          txbCopies.Enabled = True
          copies_print = lstSpis.List(lstSpis.ListIndex, 3)
          If copies_print > 0 Then
             txbCopies.value = copies_print
           Else
             txbCopies.value = Null
          End If
    End Select
    cmdPRINT.Enabled = True
End Sub
 
Private Sub lstSpis_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    If lstSpis.ListIndex < 0 Then Exit Sub
    If lstSpis.ListCount = 0 Then Exit Sub
    If IsNull(lstSpis.List(lstSpis.ListIndex)) Then Exit Sub
    If lstSpis.List(0, 0) = "Все элементы удалены!" Then Exit Sub
    lstSpis.RemoveItem (lstSpis.ListIndex)
    If lstSpis.ListCount = 0 Then
        cmdPRINT.Enabled = False
        lblAdr.Caption = "Адрес выбранного файла..."
        lblName.Caption = "Выбранный файл..."
        lblAdr.Enabled = False
        lblName.Enabled = True
        lstSpis.AddItem "Все элементы удалены!"
        lstSpis.AddItem "Выберите другую часть задания"
        lstSpis.AddItem "или другое задание."
        lstSpis.BackColor = &H80000004
        cmdCalcS.Enabled = False
        txbCopies.BackColor = &H80000004
        txbCopies.Enabled = False
        txbCopies.value = Null
    End If
End Sub
 
Private Sub lstSpis_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Call ListRowMove(lstSpis, KeyCode, Shift)
End Sub
 
Private Sub lstViz_Click()
    If Nalich_VIZ < 0 Then Exit Sub
    Dim fName As String                   ' имя обрабатываемой визитки
    Dim FNameFull As String               ' имя PreView к обрабатываемой визитке с "путями"
    Dim TuFal As Boolean
     
    If lstViz.ListIndex > 0 Then
        fName = lstViz.List(lstViz.ListIndex, 4)
        FNameFull = lblVPath.Caption & Left(fName, Len(fName) - 4) & ".jpg"  ' задаем адрес поиска файла PreView
        If ProverNalichFiles(FNameFull) = False Then    ' если нет подготовленных к печати файлов, то
            FNameFull = ""
            MsgBox "У этой визитки нет PreView!", vbInformation, Me.Caption
        End If
        TuFal = True
    Else
        FNameFull = ""
        TuFal = False
    End If
    'CheckBox3.Enabled = TuFal
    'CheckBox3.Value = False               ' снимаем пометку о необходимости корекции количества копий
    cmdPRINT.Enabled = TuFal
    cmdArhiving.Enabled = TuFal
    Image1.PictureSizeMode = fmPictureSizeModeZoom
    Image1.Picture = LoadPicture(FNameFull)
    txbCopy.BackColor = &H80000004
    txbCopy.Enabled = False
    txbCopy.value = Null
End Sub
 
Private Sub lstViz_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ' ====== удаление записи из Задания по DblClick =
    Dim zadanie As String
    zadanie = lstViz.List(lstViz.ListIndex, 0)
    If zadanie = "" Then Exit Sub
    If zadanie = "Название задания:" Then Exit Sub
    If zadanie = "Нет файлов для печати..." Then Exit Sub
    lstLog.AddItem Format(Now, "hh:mm:ss") & "  ПРИНУДИТЕЛЬНОЕ УДАЛЕНИЕ задания: [" & zadanie & "]"
    lstLog.AddItem "---------------------------------------------------------------------------------------------------------"
    lstLog.ListIndex = lstLog.ListCount - 1          ' выделяем последнюю строку в отчёте
    lstViz.RemoveItem (lstViz.ListIndex)
End Sub
 
Private Sub MultiPage1_Change()          ' ========= "переход" по вкладкам =========
    WhatUserLuking = MultiPage1.SelectedItem.Name
    cmdPrinterProp.Enabled = False
    cmdPRINT.Enabled = False
    lstViz.ListIndex = 0
    Select Case WhatUserLuking
        Case Is = "pViz"                     ' если выбрана вкладка "Визитки"
            If PrinterViz = -1 Or _
                PrinterViz = PrinterBrosh Or _
                PrinterViz = PrinterSpisok Then
                cboPrinter.value = "Укажите принтер ..."
             Else
                cboPrinter.ListIndex = PrinterViz  ' указывем принтер, выбранный на этой владке
            End If
            cmdArhiving.Enabled = False
            MultiPage2.value = 0
        Case Is = "pBrosh"                    ' если выбрана вкладка "Брошюры и Буклеты"
            If cboFZad.value = "Нет файлов для обработки..." Or _
                cboFZad.value = "Выберите задание..." Or _
                cboFZad.value = "" Then
                cmdArhiving.Enabled = False
             Else
                cmdArhiving.Enabled = True
            End If
            If Nalich_CSV > 0 Then lstMain.ListIndex = 0
            If PrinterBrosh = -1 Or _
                PrinterBrosh = PrinterViz Or _
                PrinterBrosh = PrinterSpisok Then
                cboPrinter.value = "Укажите принтер ..."
             Else
                cboPrinter.ListIndex = PrinterBrosh  ' указывем принтер, выбранный на этой владке
            End If
            MultiPage2.value = 1
        Case Is = "pSpisok"                   ' если выбрана вкладка "Список"
            If cboFZSp.value = "Выберите задание..." Or _
                cboFZSp.value = "" Then
                cmdArhiving.Enabled = False
             Else
                cmdArhiving.Enabled = True
            End If
            If PrinterSpisok = -1 Or _
                PrinterSpisok = PrinterViz Or _
                PrinterSpisok = PrinterBrosh Then
                cboPrinter.value = "Укажите принтер ..."
             Else
                cboPrinter.ListIndex = PrinterSpisok    ' указывем принтер, выбранный на этой владке
            End If
            MultiPage2.value = 1
        Case Is = "pSettings"                    ' если выбрана вкладка "Переменные"
            cmdArhiving.Enabled = False
            cboPrinter.value = "Укажите принтер ..."
            MultiPage2.value = 1
    End Select
End Sub
 
Private Sub txbCopies_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 13 Then Call cmdPRINT_Click
End Sub
 
Private Sub txbPoisk_Change()
    Call LookForString(txbPoisk, lstSpis)
End Sub
 
Private Sub txbPoisk_Enter()
    If txbPoisk.value = "Поиск..." Then
        txbPoisk.value = ""
        txbPoisk.ForeColor = &H80000012
    End If
End Sub
 
Private Sub txbPoisk_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If txbPoisk.value = "" Then
        txbPoisk.ForeColor = &H80000010
        txbPoisk.value = "Поиск..."
    End If
End Sub
 
Private Sub txbPoisk_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = 40 Then lstSpis.SetFocus
End Sub
 
Private Sub UserForm_Initialize()        ' ========= инициализация формы =========
    ' наполнение спика:
    cboDoliaViz.AddItem "Текущая"
    cboDoliaViz.AddItem "Все"
    cboDoliaViz.AddItem "От"
    cboDoliaViz.AddItem "До"
    cboDoliaViz.AddItem "Коррекция числа копий:"
    cboDoliaViz.ListIndex = 0
    
    Call PrintersAdd    ' добавление списка принтеров
    If chkPrAbsent = False Then Call PrinterCheck   ' очистка списка принтеров от отсутствующих в системе
    If Nalich_PRINTER = 0 Then Exit Sub
    Call VizReload
    Call VizReloadArhiv
    Call FZReload
    Call FZReloadArhiv
    Call SpisReload
    If Nalich_CSV < 1 And Nalich_VIZ < 1 Then
        MsgBox "Не обнаружено файлов, готовых к обработке!" & Chr(13) _
            & "Воспользуйтесь Архивом или закройте программу!"
    End If
    cboDoliaSp.AddItem "Позиция"
    cboDoliaSp.AddItem "От и До"
    cboDoliaSp.AddItem "От..."
    cboDoliaSp.AddItem "...До"
    cboDoliaSp.AddItem "Заказанное"
    WhatUserLuking = MultiPage1.SelectedItem.Name
    PrinterViz = -1
    PrinterBrosh = -1
    PrinterSpisok = -1
End Sub
 
 
' ##################### ______ процедуры ____ #####################
 
Private Sub AnalizInReport()
    If Nalich_CSV < 1 Then Exit Sub
    If cboFZad.value = "" Then Exit Sub
    If cboFZad.value = "Выберите задание..." Then Exit Sub
    
    Dim for_case As String
    Dim fName As String         ' адрес *.info-файла
    Dim Frep As Long
    Dim MyText As String
    Dim name_info As String     ' адрес и имя *.info-файла
    Dim ShoudToAdd As Byte      ' признак добавлять/не добавлять
    
    name_info = lblFZPath.Caption & Left(cboFZad.value, Len(cboFZad.value) - 3) & ".info"
    If ProverNalichFiles(name_info) Then
        ShoudToAdd = 0
        Frep = FreeFile            ' добавляем автоматический счётчик открытых файлов
        Open name_info For Input As #Frep
        Do Until EOF(Frep)
            Line Input #Frep, MyText
            for_case = Left(MyText, InStr(MyText, ";") - 1)  ' получили признак напечатанного
            If for_case <> "текст" Then                      ' усли отпечатан не "текст", то...
                If ShoudToAdd = 0 Then
                    lstLog.AddItem "###############       УЖЕ НАПЕЧАТАНО       ##################"
                    ShoudToAdd = 1
                End If
                lstLog.AddItem MyText
            End If
        Loop            ' начать цикл заново
        Close #Frep     ' закрыть файл по выполнении цикла
        If ShoudToAdd = 1 Then
            lstLog.AddItem "##################################################"
        End If
        lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
    End If
End Sub
 
Private Sub FZAnaliz()            ' ========= процедура: анализ файла =========
    If Nalich_CSV < 1 Then Exit Sub
    If cboFZad.value = "" Then Exit Sub                        ' проверка: выбрано-ли задание
    If cboFZad.value = "Выберите задание..." Then Exit Sub     ' проверка: выбрано-ли задание
    
    Dim AllStrings() As String
    Dim copies_print As Long        ' количество копий файла, отправляемого на печать
    Dim count_f As Integer          ' счетчик файлов, отправляемых на печать
    Dim count_f_obl As Long         ' счетчик файлов, отправляемых на печать обложек
    Dim count_f_forz As Long        ' счетчик файлов, отправляемых на печать форзацев
    Dim count_f_vkl1 As Long        ' счетчик файлов, отправляемых на печать вкладышей 1-я сторона
    Dim count_f_vkl2 As Long        ' счетчик файлов, отправляемых на печать вкладышей 2-я сторона
    Dim count_f_bukl1 As Long       ' счетчик файлов, отправляемых на печать буклетов 1-я сторона
    Dim count_f_bukl2 As Long       ' счетчик файлов, отправляемых на печать буклетов 2-я сторона
    Dim count_f_cvetO As Long       ' счетчик файлов, отправляемых на печать полноцветов обложек
    Dim count_f_cvetF As Long       ' счетчик файлов, отправляемых на печать полноцветов форзацев
    Dim count_f_cvet1 As Long       ' счетчик файлов, отправляемых на печать полноцветов внутр.часть 1-я сторона
    Dim count_f_cvet2 As Long       ' счетчик файлов, отправляемых на печать полноцветов внутр.часть 2-я сторона
    Dim count_f_pap1 As Long        ' счетчик файлов, отправляемых на печать папок 1-я сторона
    Dim count_f_pap2 As Long        ' счетчик файлов, отправляемых на печать папок 2-я сторона
    Dim count_p As Long             ' общее количество страниц, отправляемых на печать
    Dim count_p_vkl1 As Long        ' счетчик страниц, отправляемых на печать вкладышей 1-я сторона
    Dim count_p_vkl2 As Long        ' счетчик страниц, отправляемых на печать вкладышей 2-я сторона
    Dim count_p_obl As Long         ' счетчик страниц, отправляемых на печать обложек
    Dim count_p_forz As Long        ' счетчик страниц, отправляемых на печать форзацев
    Dim count_p_bukl1 As Long       ' счетчик страниц, отправляемых на печать буклетов 1-я сторона
    Dim count_p_bukl2 As Long       ' счетчик страниц, отправляемых на печать буклетов 2-я сторона
    Dim count_p_cvetO As Long       ' счетчик страниц, отправляемых на печать полноцветов обложек
    Dim count_p_cvetF As Long       ' счетчик страниц, отправляемых на печать полноцветов форзацев
    Dim count_p_cvet1 As Long       ' счетчик страниц, отправляемых на печать полноцветов внутр.часть 1-я сторона
    Dim count_p_cvet2 As Long       ' счетчик страниц, отправляемых на печать полноцветов внутр.часть 2-я сторона
    Dim count_p_pap1 As Long        ' счетчик страниц, отправляемых на печать папок 1-я сторона
    Dim count_p_pap2 As Long        ' счетчик страниц, отправляемых на печать папок 2-я сторона
    Dim Fa As Long
    Dim Fl As Long
    Dim for_case As String             ' признак печати (текст, обложка, вкладышь и пр.)
    Dim MyText As String               ' строка из файла-задания по порядку целиком
    Dim name_csv As String             ' адрес и имя обрабатываемого файла-задания
    Dim name_log As String             ' адрес и имя *.log-файла
    Dim PrintedOrNot As Byte           ' признак (на/нена)печатано
    Dim printed_obl As Byte            ' признак (на/нена)печатано
    Dim printed_forz As Byte           ' признак (на/нена)печатано
    Dim printed_vkl1 As Byte           ' признак (на/нена)печатано
    Dim printed_vkl2 As Byte           ' признак (на/нена)печатано
    Dim printed_bukl1 As Byte          ' признак (на/нена)печатано
    Dim printed_bukl2 As Byte          ' признак (на/нена)печатано
    Dim printed_cvetO As Byte          ' признак (на/нена)печатано
    Dim printed_cvetF As Byte          ' признак (на/нена)печатано
    Dim printed_cvet1 As Byte          ' признак (на/нена)печатано
    Dim printed_cvet2 As Byte          ' признак (на/нена)печатано
    Dim printed_pap1 As Byte           ' признак (на/нена)печатано
    Dim printed_pap2 As Byte           ' признак (на/нена)печатано
    Dim second As Integer              ' времени печати одной страницы, в секундах
    Dim second_lost As Integer         ' переменна потери времени на загрузку одной страницы в принтер, в секундах
    Dim str As Byte                    ' переменная "номер строки" при добавлении заданий в очередь
    Dim time_chas As Integer           ' общее время печати, в часах
    Dim time_min As Long               ' общее время печати, в минутах
    Dim time_label As String           ' отображаемое время печати
    Dim time_lost As Integer           ' общие потери времени на загрузку в принтер файлов, поставленных в очередь
    
    name_csv = lblFZPath.Caption & cboFZad.value
    If ProverNalichFiles(name_csv) = False Then
      MsgBox "Файл-задание: " & cboFZad.value & Chr(13) & _
             "НЕ ОБНАРУЖЕН!!!" & Chr(13) & Chr(13) & _
             "Сейчас будет произведена перезагрузка списков." & Chr(13) & _
             "ПОВТОРИТЕ СВОЙ ВЫБОР.", _
             vbCritical, _
             "Ошибка: файл-задание не обнаружен/пропал."
      Call FZReload
      Call FZReloadArhiv
      Exit Sub
    End If
    count_f = 0
    lstMain.Clear               ' доп.функция очистки списка заданий
    lstMain.Enabled = True
    Fa = FreeFile
    Open name_csv For Input As #Fa      ' открываем файл для чтения построчно
        Do Until EOF(Fa)                ' цикл "пока не найдено окончание файла":
            Line Input #Fa, MyText      ' получили строку по порядку целиком для работы
            If MyText <> "" Then
                AllStrings = Split(MyText, Chr(9))
                for_case = AllStrings(0)
                copies_print = AllStrings(4)        ' получили количество КОПИЙ
                zadanie_info_program = for_case
                PrintedOrNot = 0
                Call InfoAnaliz
                If chkPrinted.value = False Then
                    If zadanie_info_file = "напечатано" Then for_case = "напечатано"
                 Else
                    If zadanie_info_file = "напечатано" Then
                       PrintedOrNot = 1
                     Else
                       PrintedOrNot = 0
                    End If
                End If
                zadanie_info_program = Null
                zadanie_info_file = Null
           
                ' процедура множественного ветвления для подсчёта количества страниц по заданиям
                Select Case for_case
                   Case Is = "обложка"                                    ' если "обложка", то
                        If copies_print > 0 Then
                           count_f_obl = count_f_obl + 1
                           count_p_obl = count_p_obl + copies_print       ' посчитали количество "обложка"
                           If printed_obl = 0 Then
                              printed_obl = PrintedOrNot
                           End If
                        End If
                   Case Is = "форзац"                                     ' если "форзац", то
                        If copies_print > 0 Then
                           count_f_forz = count_f_forz + 1
                           count_p_forz = count_p_forz + copies_print     ' посчитали количество "форзац"
                           If printed_forz = 0 Then
                              printed_forz = PrintedOrNot
                           End If
                        End If
                   Case Is = "вкладыш 1"                                  ' если "вкладыш 1", то
                        If copies_print > 0 Then
                           count_f_vkl1 = count_f_vkl1 + 1
                           count_p_vkl1 = count_p_vkl1 + copies_print     ' посчитали количество "вкладыш 1"
                           If printed_vkl1 = 0 Then
                              printed_vkl1 = PrintedOrNot
                           End If
                        End If
                   Case Is = "вкладыш 2"                                  ' если "вкладыш 2", то
                        If copies_print > 0 Then
                           count_f_vkl2 = count_f_vkl2 + 1
                           count_p_vkl2 = count_p_vkl2 + copies_print     ' посчитали количество "вкладыш 2"
                           If printed_vkl2 = 0 Then
                              printed_vkl2 = PrintedOrNot
                           End If
                        End If
                   Case Is = "буклеты 1"                                  ' если "буклеты 1", то
                        If copies_print > 0 Then
                           count_f_bukl1 = count_f_bukl1 + 1
                           count_p_bukl1 = count_p_bukl1 + copies_print   ' посчитали количество "буклеты 1"
                           If printed_bukl1 = 0 Then
                              printed_bukl1 = PrintedOrNot
                           End If
                        End If
                   Case Is = "буклеты 2"                                  ' если "буклеты 2", то
                        If copies_print > 0 Then
                           count_f_bukl2 = count_f_bukl2 + 1
                           count_p_bukl2 = count_p_bukl2 + copies_print   ' посчитали количество "буклеты 2"
                           If printed_bukl2 = 0 Then
                              printed_bukl2 = PrintedOrNot
                           End If
                        End If
                   Case Is = "полноцвет обложка"                          ' если "полноцвет обложка", то
                        If copies_print > 0 Then
                           count_f_cvetO = count_f_cvetO + 1
                           count_p_cvetO = count_p_cvetO + copies_print   ' посчитали количество "полноцвет обложка"
                           If printed_cvetO = 0 Then
                              printed_cvetO = PrintedOrNot
                           End If
                        End If
                   Case Is = "полноцвет форзац"                           ' если "полноцвет форзац", то
                        If copies_print > 0 Then
                           count_f_cvetF = count_f_cvetF + 1
                           count_p_cvetF = count_p_cvetF + copies_print   ' посчитали количество полноцвет форзац"
                           If printed_cvetF = 0 Then
                              printed_cvetF = PrintedOrNot
                           End If
                        End If
                   Case Is = "полноцвет середина 1"                       ' если "полноцвет середина 1", то
                        If copies_print > 0 Then
                           count_f_cvet1 = count_f_cvet1 + 1
                           count_p_cvet1 = count_p_cvet1 + copies_print   ' посчитали количество "полноцвет середина 1"
                           If printed_cvet1 = 0 Then
                              printed_cvet1 = PrintedOrNot
                           End If
                        End If
                   Case Is = "полноцвет середина 2"                       ' если "полноцвет середина 2", то
                        If copies_print > 0 Then
                           count_f_cvet2 = count_f_cvet2 + 1
                           count_p_cvet2 = count_p_cvet2 + copies_print   ' посчитали количество "полноцвет середина 2
                           If printed_cvet2 = 0 Then
                              printed_cvet2 = PrintedOrNot
                           End If
                        End If
                   Case Is = "папка 1"                                    ' если "папка 1", то
                        If copies_print > 0 Then
                           count_f_pap1 = count_f_pap1 + 1
                           count_p_pap1 = count_p_pap1 + copies_print     ' посчитали количество "папка 1"
                           If printed_pap1 = 0 Then
                              printed_pap1 = PrintedOrNot
                           End If
                        End If
                   Case Is = "папка 2"                                    ' если "папка 2", то
                        If copies_print > 0 Then
                           count_f_pap2 = count_f_pap2 + 1
                           count_p_pap2 = count_p_pap2 + copies_print     ' посчитали количество "папка 2"
                           If printed_pap2 = 0 Then
                              printed_pap2 = PrintedOrNot
                           End If
                        End If
                End Select
                copies_print = 0
           End If
        Loop            ' возврат к началу процедуры "пока не найдено окончание файла"
    Close #Fa           ' закрываем файл и освобождаем доступ к нему
  
    lstMain.ColumnCount = 6                          ' указываем количество столбцов
    lstMain.ColumnWidths = "150; 45; 40; 55; 0; 40"  ' устанавливаем ширину столбцов
    lstMain.AddItem "Название задания:"              ' добавляем заголовок "Название задания"
    lstMain.List(0, 1) = "Бумага:"                   ' добавляем заголовок "Бумага, г/м:"
    lstMain.List(0, 2) = "Листов:"                   ' добавляем заголовок "Листов, шт:"
    lstMain.List(0, 3) = "Время, мин:"               ' добавляем заголовок "Время, мин:"
    lstMain.List(0, 4) = 0                           ' устанавливаем признак (на/нена)печатано
    lstMain.List(0, 5) = "Файлов:"                   ' число файлов, отправляемых на печать
    
    If cboPrinter.value = "Укажите принтер ..." Then
        second = lstPrinter.List(1, 1)                          ' получаем время печати одной страницы
        second_lost = lstPrinter.List(1, 4)                     ' получаем время печати одной страницы
     Else
        second = cboPrinter.List(cboPrinter.ListIndex, 1)       ' получаем время печати одной страницы
        second_lost = cboPrinter.List(cboPrinter.ListIndex, 4)  ' получаем время печати одной страницы
    End If
    str = 0     ' переменная "номер строки"
    If count_p_vkl2 > 0 Then                   ' если 2-ю сторону вкладыша, то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "вкладыш 2"                 ' добавляем строку "вкладыш 2"
        lstMain.List(str, 1) = "100 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_vkl2         ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_vkl2 * second / 60)   ' высчитываем время печати
        lstMain.List(str, 4) = printed_vkl2         ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_vkl2         ' число файлов, отправляемых на печать
    End If
    If count_p_vkl1 > 0 Then                   ' если 1-ю сторону вкладыша, то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "вкладыш 1"                 ' добавляем строку "вкладыш 1"
        lstMain.List(str, 1) = "100 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_vkl1         ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_vkl1 * second / 60)   ' высчитываем время печати
        lstMain.List(str, 4) = printed_vkl1         ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_vkl1         ' число файлов, отправляемых на печать
    End If
    If count_p_forz > 0 Then                   ' если форзацы, то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "форзац"                    ' добавляем строку "форзац"
        lstMain.List(str, 1) = "160 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_forz         ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_forz * second / 60)   ' высчитываем время печати
        lstMain.List(str, 4) = printed_forz         ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_forz         ' число файлов, отправляемых на печать
    End If
    If count_p_obl > 0 Then                    ' если надо печатать обложки, то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "обложка"                   ' добавляем строку "обложка"
        lstMain.List(str, 1) = "160 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_obl          ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_obl * second / 60)    ' высчитываем время печати
        lstMain.List(str, 4) = printed_obl          ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_obl          ' число файлов, отправляемых на печать
    End If
    If count_p_bukl1 > 0 Then                  ' если 1-я сторона буклетов, то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "буклеты 1"                 ' добавляем строку "буклеты 1"
        lstMain.List(str, 1) = "100 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_bukl1        ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_bukl1 * second / 60)  ' высчитываем время печати
        lstMain.List(str, 4) = printed_bukl1        ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_bukl1        ' число файлов, отправляемых на печать
    End If
    If count_p_bukl2 > 0 Then                  ' если 2-я сторона буклетов, то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "буклеты 2"                 ' добавляем строку "буклеты 2"
        lstMain.List(str, 1) = "100 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_bukl2        ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_bukl2 * second / 60)  ' высчитываем время печати
        lstMain.List(str, 4) = printed_bukl2        ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_bukl2        ' число файлов, отправляемых на печать
    End If
    If count_p_cvetO > 0 Then                  ' если обложки полноцвета, то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "полноцвет обложка"         ' добавляем строку "полноцвет обложка"
        lstMain.List(str, 1) = "160 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_cvetO        ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_cvetO * second / 60)  ' высчитываем время печати
        lstMain.List(str, 4) = printed_cvetO        ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_cvetO        ' число файлов, отправляемых на печать
    End If
    If count_p_cvetF > 0 Then                  ' если форзацы полноцвета, то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "полноцвет форзац"          ' добавляем строку "полноцвет форзац"
        lstMain.List(str, 1) = "160 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_cvetF        ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_cvetF * second / 60)  ' высчитываем время печати
        lstMain.List(str, 4) = printed_cvetF        ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_cvetF        ' число файлов, отправляемых на печать
    End If
    If count_p_cvet1 > 0 Then                  ' если "полноцвет середина 1", то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "полноцвет середина 1"      ' добавляем строку "полноцвет середина 1"
        lstMain.List(str, 1) = "100 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_cvet1        ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_cvet1 * second / 60)  ' высчитываем время печати
        lstMain.List(str, 4) = printed_cvet1        ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_cvet1        ' число файлов, отправляемых на печать
    End If
    If count_p_cvet2 > 0 Then                  ' если "полноцвет середина 2", то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "полноцвет середина 2"      ' добавляем строку "полноцвет середина 2"
        lstMain.List(str, 1) = "100 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_cvet2        ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_cvet2 * second / 60)  ' высчитываем время печати
        lstMain.List(str, 4) = printed_cvet2        ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_cvet2        ' число файлов, отправляемых на печать
    End If
    If count_p_pap1 > 0 Then                   ' если "папка 1", то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "папка 1"                   ' добавляем строку "папка 1"
        lstMain.List(str, 1) = "100 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_pap1         ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_pap1 * second / 60)   ' высчитываем время печати
        lstMain.List(str, 4) = printed_pap1         ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_pap1         ' число файлов, отправляемых на печать
    End If
    If count_p_pap2 > 0 Then                   ' если "папка 2", то
        str = str + 1                               ' смещаемся на одну строку ниже
        lstMain.AddItem "папка 2"                   ' добавляем строку "папка 2"
        lstMain.List(str, 1) = "100 г/м"            ' добавляем параметр бумаги
        lstMain.List(str, 2) = count_p_pap2         ' записываем количество страниц
        lstMain.List(str, 3) = CLng(count_p_pap2 * second / 60)   ' высчитываем время печати
        lstMain.List(str, 4) = printed_pap2         ' устанавливаем признак (на/нена)печатано
        lstMain.List(str, 5) = count_f_pap2         ' число файлов, отправляемых на печать
    End If
    
    count_f = count_f_obl + count_f_forz + _
              count_f_vkl1 + count_f_vkl2 + _
              count_f_bukl1 + count_f_bukl2 + _
              count_f_cvetO + count_f_cvetF + _
              count_f_cvet1 + count_f_cvet2 + _
              count_f_pap1 + count_f_pap2               'счетчик файлов, отправляемых на печать
    count_p = count_p_vkl1 + count_p_vkl2 + _
              count_p_forz + count_p_obl + _
              count_p_pap1 + count_p_pap2 + _
              count_p_cvetO + count_p_cvetF + _
              count_p_cvet1 + count_p_cvet2 + _
              count_p_bukl1 + count_p_bukl2         'счетчик страниц, отправляемых на печать
    time_chas = 0
    time_min = CLng((CLng(count_p) * CLng(second)) / 60)
    
    If time_min < 60 Then
        time_label = time_min & " мин., "
     Else
        Do While time_min >= 60
            time_min = time_min - 60
            time_chas = time_chas + 1
        Loop
        time_label = time_chas & " ч. " & time_min & " мин., "
    End If
    time_lost = second_lost * count_f / 60            ' потери времени на загрузку файлов в принтер, в минутах
    lblVybor.Caption = "Общее время печати: " & time_label & "[" & time_lost & " мин.] " & " (" & count_p & " стр.)"
    
    If (lstMain.ListCount - 1) > 0 Then
        lstMain.ListIndex = 1
     Else
        lstMain.ListIndex = 0
    End If
    
    name_log = "d:\Raspechatka\.Автоматизация\" & "log\" & "Eps_" & Format(Now, "yyyy.mm.dd") & ".log"
    Fl = FreeFile
    Open name_log For Append As #Fl  'открываем файл для дабавления
        Print #Fl, ""
        Print #Fl, Now & "==========================================================="
        Print #Fl, Now & "Анализ файла: " & cboFZad.value
        Print #Fl, Now & "Общее время печати: " & time_label & count_p & " стр., " & count_f & " файлов."
        Print #Fl, Now & "Потери времени на загрузку файла в принтер: " & time_lost & " мин."
        Print #Fl, Now & "-----------------------------------------------------------"
    Close #Fl
    If count_p > 0 Then cmdPRINT.Enabled = True Else cmdPRINT.Enabled = False
End Sub
 
Private Sub FZFromArhiv()
    If cboZArhiv.value = "" Then Exit Sub
    If cboZArhiv.value = "Укажите файл для возврата из архива..." Then Exit Sub
    If cboZArhiv.value = "В архиве файлов нет..." Then Exit Sub
    
    Dim f_name As String
    Dim fName As String          ' адрес *.info-файла
    Dim i As Byte                ' счётчик циклов
    Dim dName As String          ' адрес и имя "конечного" файла сохранения
    Dim sName As String          ' адрес и имя обрабатываемого файла (он же исходный файл сохранения)
    
    fName = cboZArhiv.value
    f_name = fName
    i = 0
    For i = 0 To 1
        sName = lblFZArh.Caption & f_name
        If ProverNalichFiles(sName) Then
            f_name = Right(f_name, Len(f_name) - 11)
            dName = lblFZPath.Caption & f_name
            FileCopy Source:=sName, Destination:=dName
            Kill sName
            lstLog.AddItem "ВОЗВРАЩЕНО из архива: [" & f_name & "]"
         Else
            MsgBox "Сейчас будет произведена перезагрузка списков." & Chr(13) & _
                   "ПОВТОРИТЕ СВОЙ ВЫБОР.", _
                   , _
                   "Ошибка: указанный Вами файл не обнаружен!"
            Call FZReloadArhiv
            Exit For
        End If
        f_name = Left(fName, Len(fName) - 3) & ".info"
    Next i
    lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
End Sub
 
Private Sub FZReload( _
        Optional ByVal pLook As String _
        )                            '=== процедура перезагрузки списков файлов-заданий
    ' если список принтеров пуст, то пропускаем процедуру
    If Nalich_PRINTER < 1 Then Exit Sub
    
    Dim fDirName As String
    Dim fName As String         ' имя файла-задания
    Dim fzArr() As String       ' массив имён заданий
    Dim fzArrUB As Integer
    Dim fzCount As Byte         ' счётчик файлов-заданий
    Dim i As Integer            ' счетчик
    Dim rowCount As Integer     ' счетчик строк чекбокса
    Dim rowShow As Byte         ' число отоброжаемых строк чекбокса
    Dim TruFal As Boolean       ' признак раз/блокировки элементов
    
    If pLook = "" Or pLook = "pSpisok" Then cboFZSp.Clear   ' очищаем список заданий
    If pLook = "" Or pLook = "pBrosh" Then
        cboFZad.Clear    ' очищаем список заданий
        lstMain.Clear
    End If
    fDirName = lblFZPath.Caption & "*.fz"
    If ProverNalichFiles(fDirName) = False Then
        Nalich_CSV = 0
        TruFal = False
        cboFZad.value = "Нет файлов для обработки..."
        lstMain.AddItem "Нет файлов для обработки..."
        lstMain.BackColor = &H80000004
     Else
        Nalich_CSV = 1
        TruFal = True
        fName = Dir(lblFZPath.Caption & "*.fz")
        While fName <> ""
            If fName <> "Полный список.fz" Then
                ReDim Preserve fzArr(fzCount) As String
                fzArr(fzCount) = fName
                fzCount = fzCount + 1
            End If
            fName = Dir
        Wend
        If fzCount > 1 Then Call QuickSort(fzArr())     ' пересортировываем массив
        If fzCount > 0 Then fzArrUB = UBound(fzArr()) Else fzArrUB = -1
        For i = 0 To fzArrUB
            If pLook = "" Or pLook = "pSpisok" Then cboFZSp.AddItem fzArr(i)
            If pLook = "" Or pLook = "pBrosh" Then cboFZad.AddItem fzArr(i)
        Next i
        If Dir(lblFZPath.Caption & "Полный список.fz") <> "" _
            And (pLook = "" Or pLook = "pSpisok") Then cboFZSp.AddItem "Полный список.fz"
        fzCount = cboFZad.ListCount
        cboFZSp.ListRows = fzCount + 1
        cboFZad.ListRows = fzCount
        cboFZad.Text = "Выберите задание..."
        cboFZSp.Text = "Выберите задание..."
        lstMain.AddItem "Ожидают обработку: " & FilesCount & " файл(ов)."
        lstMain.AddItem "Выберите один из них."
        lstMain.BackColor = &H80000005
        lstLog.AddItem "Обнаружено: " & fzCount & " файл(ов)-заданий."
        
        rowCount = cboFZSp.ListCount
        Select Case rowCount
            Case Is < 15: rowShow = rowCount
            Case Is >= 15: rowShow = 15
        End Select
        cboFZSp.ListRows = rowShow
        rowCount = cboFZad.ListCount
        Select Case rowCount
            Case Is < 15: rowShow = rowCount
            Case Is >= 15: rowShow = 15
        End Select
        cboFZad.ListRows = rowShow
    End If
    chkArhiving.Enabled = TruFal
    cboFZad.Enabled = TruFal
    cboFZSp.Enabled = TruFal
    lstMain.Enabled = False
    MultiPage1.Pages("pSpisok").Enabled = TruFal
End Sub
 
Private Sub FZReloadArhiv()            ' ========= процедура: отобразить список архива =========
    Dim fName As String
    Dim count_f As Byte
    cboZArhiv.Clear
    count_f = 0
    fName = Dir(lblFZArh.Caption & "*.fz")
    While fName <> ""
        cboZArhiv.AddItem (fName)
        count_f = 1
        fName = Dir
    Wend
    If count_f = 1 Then
       cboZArhiv.Enabled = True
       cboZArhiv.value = "Укажите файл для возврата из архива..."
     Else
       cboZArhiv.Enabled = False
       cboZArhiv.value = "В архиве файлов нет..."
    End If
End Sub
 
Private Sub FZToArhiv( _
        fName As String _
        )
    If fName = "" Or fName = "Выберите задание..." Then Exit Sub
    
    Dim f_name As String
    Dim i As Byte           ' счётчик циклов
    Dim dName As String     ' адрес и имя "конечного" файла сохранения
    Dim sName As String     ' адрес и имя обрабатываемого файла (он же исходный файл сохранения)
    
    f_name = fName
    i = 0
    For i = 0 To 1
        sName = lblFZPath.Caption & f_name
        If ProverNalichFiles(sName) Then
           dName = lblFZArh.Caption & Format(Now, "yyyy.mm.dd") & "_" & f_name
           FileCopy Source:=sName, Destination:=dName
           Kill sName
           lstLog.AddItem "ВОЗВРАЩЕНО из архива: [" & f_name & "]"
         Else
           MsgBox "Сейчас будет произведена перезагрузка списков." & Chr(13) _
                & "ПОВТОРИТЕ СВОЙ ВЫБОР.", _
                , "Ошибка: указанный Вами файл не обнаружен!"
           Call FZReloadArhiv
           Exit For
        End If
        f_name = Left(fName, Len(fName) - 3) & ".info"
    Next i
    lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
    ' затираем название файла-задания, чтоб избавиться от ошибки перечитыватия
    ' удалённого файла, когда снимем пометку о необходимости архивации
    cboFZad.value = "Выберите задание..."
    chkArhiving.value = False                       ' снимаем пометку о необходимости архивации
End Sub
 
Private Sub InfoAnaliz()
    Dim f_info_exist As String          ' признак существования *.info-файла по указанному адресу
    Dim Fai As Long
    Dim for_case As String              ' ПРИЗНАК печати (текст, обложка, вкладышь и пр.)
    Dim fName As String                 ' адрес *.info-файла
    Dim IsPrinted As Byte               ' признак отпечатано/не отпечатано
    Dim MyText As String                ' строка из *.info-файла целиком
    Dim MyText_left As Integer
    Dim name_info As String             ' адрес и имя *.info-файла
    
    name_info = lblFZPath.Caption & Left(cboFZad.value, Len(cboFZad.value) - 3) & ".info"
    If ProverNalichFiles(name_info) Then
        Fai = FreeFile                      ' добавляем автоматический счётчик открытых файлов
        Open name_info For Input As #Fai
        Do Until EOF(Fai)
            Line Input #Fai, MyText
            MyText_left = InStr(MyText, ";")            ' нашли каким по счёту символом является ";" слева
            for_case = Left(MyText, MyText_left - 1)    ' получили признак напечатанного
            If zadanie_info_program = for_case Then     ' если задание совпадает с "файлом", то
                zadanie_info_file = "напечатано"
                If for_case <> "текст" Then
                    chkPrinted.Enabled = True           ' активируем возможность показать напечатанныйе части задания
                End If
            End If
        Loop        ' начать цикл заново
        Close #Fai  ' закрыть файл по выполнении цикла
    Else
    End If
End Sub
 
Private Sub NapolnenieSpiska()
    Dim kategor As String
    Dim TipSpiska As String            ' тип составляемого списка
    Dim fzadanie As String
    
    kategor = cboKatSp.value
    TipSpiska = cboDoliaSp.value
    fzadanie = cboFZSp.value
    
    If fzadanie = "" Or fzadanie = "Выберите задание..." Or _
       TipSpiska = "" Or TipSpiska = "Способ отображения..." Then Exit Sub
    
    Dim AllStrings() As String
    Dim adr As String                  ' адрес файла
    Dim book_name As String            ' название печатаемого элемента
    Dim copies_print As Integer        ' количество копий файлов, отправляемых на печать
    Dim F As Long                      ' уникольный номер файла в системе
    Dim for_case As String             ' признак печати (текст, обложка, вкладышь и пр.)
    Dim MyText As String               ' строка из файла-задания, взятая целиком
    Dim path_f As String               ' адрес расположения обрабатываемого файла-задания
    Dim str As Integer                 ' "номер" строки (индекс строки)
    
    If lblWellAdd.Caption = "=" Then
        lstSpis.Clear
        str = 0
    Else
        str = lstSpis.ListCount
    End If
    lstSpis.ColumnCount = 4                  ' указываем количество столбцов
    lstSpis.ColumnWidths = "225; 80; 0; 0"   ' устанавливаем ширину столбцов
    path_f = lblFZPath.Caption & fzadanie
    
    F = FreeFile
    Open path_f For Input As #F
    Do Until EOF(F)
        Line Input #F, MyText
        If MyText <> "" Then
            AllStrings = Split(MyText, Chr(9))
            for_case = AllStrings(0)
            book_name = Replace(Replace(AllStrings(1), Chr(10), " "), Chr(34) & Chr(34), Chr(34))
            If Left(book_name, 1) = Chr(34) Then
                book_name = Right(book_name, Len(book_name) - 1)
            End If
            If Right(book_name, 1) = Chr(34) Then
                book_name = Left(book_name, Len(book_name) - 1)
            End If
            adr = Replace(AllStrings(2), Chr(34), "")
            copies_print = AllStrings(4)
            If for_case <> "текст" Then
                Select Case TipSpiska
                    Case Is = "Позиция"
                        If kategor = for_case Or kategor = "Все категории" Then
                            lstSpis.AddItem book_name               ' добавляем название книги
                            lstSpis.List(str, 1) = for_case         ' добавляем признак печати
                            lstSpis.List(str, 2) = adr              ' добавляем адрес файла
                            lstSpis.List(str, 3) = copies_print     ' добавляем количество копий
                            str = str + 1   ' смещаемся на одну строку ниже
                        End If
                    Case Is = "Заказанное", "От и До", "От...", "...До"
                        If (kategor = for_case Or kategor = "Все категории") And copies_print > 0 Then
                            lstSpis.AddItem book_name               ' добавляем название книги
                            lstSpis.List(str, 1) = for_case         ' добавляем признак печати
                            lstSpis.List(str, 2) = adr              ' добавляем адрес файла
                            lstSpis.List(str, 3) = copies_print     ' добавляем количество копий
                            str = str + 1   ' смещаемся на одну строку ниже
                        End If
                End Select
            End If
        End If
    Loop
    Close #F
    txbPoisk.ForeColor = &H80000010
    txbPoisk.value = "Поиск..."
    If str > 0 Then
        lstSpis.Enabled = True
        lstSpis.BackColor = &H80000005
        txbPoisk.Enabled = True
     Else
        lstSpis.Enabled = False
        lstSpis.BackColor = &H80000004
        txbPoisk.Enabled = False
    End If
End Sub
 
Private Sub PrintersAdd()
    Dim name_print As String
    
    name_print = lblPrSetings.Caption
    If ProverNalichFiles(name_print) = False Then
        Nalich_PRINTER = 0
        cboZArhiv.Enabled = False
        cboVizArhiv.Enabled = False
        cmdLogClear.Enabled = False
        lstLog.AddItem "Работа программы аварийно заблокирована!"
        lstLog.Enabled = False
        lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
        lstPrinter.ColumnCount = 1                      ' указываем количество столбцов
        lstPrinter.AddItem "Не обнаружен файл для загрузки списка принтеров!"
        lstPrinter.AddItem "Для корректоной работы программы необходим указанный выше файл!"
        lstPrinter.AddItem "Восстановите указанный файл и нажмите кнопку перезагрузки списка!..."
        lstPrinter.AddItem "Или ОБРАТИТЕСЬ К АДМИНИСТРАТОРУ!"
        MsgBox "Не обнаружен файл для загрузки списка принтеров!" & Chr(13) & _
               "Дальнейшая работа не возможна!" & Chr(13) & _
               "ЗАКРОЙТЕ пожалуйста программу.", _
               vbCritical, _
               "Ошибка: файл параметров принтеров не обнаружен."
        Exit Sub
     Else
        Nalich_PRINTER = 1
        cmdLogClear.Enabled = True
        lstLog.Enabled = True
    End If
    
    Dim colum_printer As String      ' название принтера
    Dim colum_obl As Variant         ' продолжительности печати одной страницы обложек
    Dim colum_bukl As Variant        ' продолжительности печати одной страницы буклетов
    Dim colum_vizitka As Variant     ' продолжительности печати одной страницы визиток
    Dim colum_zaderzh As Variant     ' время загрузки файла в принтер (время задержки)
    Dim colum_aktiv As Variant       ' признак активности принтера (использовать при печати или нет)
    Dim for_case As Variant          ' признак принтера относятся или нет к мастеру цветной печати
    Dim Fpr As Long                  ' свободный номер в системе
    Dim MassivStrok() As String      ' массив переменных, полученный из строки
    Dim MyText As String             ' строка, полученная из файла
    Dim str As Byte                  ' переменная "номер строки"
    Dim Str_Cb As Byte               ' переменная "номер строки"
    
    str = 0
    Str_Cb = 0
    lstPrinter.ColumnCount = 6                           ' указываем количество столбцов
    lstPrinter.ColumnWidths = "120; 55; 40; 40; 35; 35"  ' устанавливаем ширину столбцов
    cboPrinter.ColumnCount = 5                          ' указываем количество столбцов
    cboPrinter.ColumnWidths = "130; 0; 0; 0; 0"         ' устанавливаем ширину столбцов
    Fpr = FreeFile
    Open name_print For Input As #Fpr
    Do Until EOF(Fpr)
        Line Input #Fpr, MyText
        MassivStrok = Split(MyText, ";")    ' получили массив подстрок из основной строки
        for_case = MassivStrok(0)
        If for_case < 3 Then                ' если значения относятся к мастеру цветной печати
            colum_printer = MassivStrok(1)
            colum_obl = MassivStrok(2)
            colum_bukl = MassivStrok(3)
            colum_vizitka = MassivStrok(4)
            colum_zaderzh = MassivStrok(5)
            colum_aktiv = MassivStrok(6)
            lstPrinter.AddItem colum_printer    ' добавили принтер в список
            lstPrinter.List(str, 1) = colum_obl
            lstPrinter.List(str, 2) = colum_bukl
            lstPrinter.List(str, 3) = colum_vizitka
            lstPrinter.List(str, 4) = colum_zaderzh
            lstPrinter.List(str, 5) = colum_aktiv
            If str > 1 And colum_aktiv = 1 Then
                cboPrinter.AddItem colum_printer    ' добавили принтер в меню печати
                cboPrinter.List(Str_Cb, 1) = CSng(colum_obl)        ' добавляем параметр скорости печати обложек
                cboPrinter.List(Str_Cb, 2) = CSng(colum_bukl)       ' добавляем параметр скорости печати буклетов
                cboPrinter.List(Str_Cb, 3) = CSng(colum_vizitka)    ' добавляем параметр скорости печати визиток
                cboPrinter.List(Str_Cb, 4) = CSng(colum_zaderzh)    ' добавляем параметр скорости загрузки файлов в принтер
                Str_Cb = Str_Cb + 1
            End If
            str = str + 1   ' переменная "номер строки"
        End If
    Loop        ' начать цикл заново
    Close #Fpr  ' закрыть файл по выполнении цикла
End Sub
 
Private Sub PrinterCheck()
    Dim i As Long, j As Integer ' индексы циклов
    Dim prExist As Boolean      ' признак наличия принтера
    Dim prName As String        ' имя принтера
    For j = CInt(cboPrinter.ListCount - 1) To 0 Step -1
        prName = cboPrinter.List(j, 0)
        prExist = False
        For i = 1 To Application.Printers.Count
            If Application.Printers.Item(i).Name = prName Then prExist = True
        Next i
        If prExist = False Then cboPrinter.RemoveItem (j)
    Next j
End Sub
 
Private Sub ProverNalichViz()       ' ========= проверка наличия готовых к печати визиток =========
    Dim TuFal As Boolean
    Dim fDirName As String
    fDirName = lblVPath.Caption & "*.tif"   ' задаем адрес поиска файлов визиток, готовых к печати
    If ProverNalichFiles(fDirName) Then     ' если есть подготовленные к печати файлы, то
        lstViz.BackColor = &H80000005
        Nalich_VIZ = 1
        TuFal = True
     Else       ' если нет подготовленных к печати файлов, то
        lblTime.Caption = ""
        lstViz.Clear                                ' очистка списка заданий
        lstViz.AddItem "Нет файлов для печати..."   ' добавляем заголовок "Название задания"
        lstViz.BackColor = &H80000004
        Nalich_VIZ = 0
        TuFal = False
    End If
    cboDoliaViz.Enabled = TuFal
    chkVizToArh.Enabled = TuFal
    lstViz.Enabled = TuFal
End Sub
 
Private Sub ReloadPrinter()       ' ========= процедура: перезагрузка списка принтеров =========
    cboPrinter.Clear
    cboPrinter.value = "Укажите принтер ..."
    cmdPrinterProp.Enabled = False
    lstPrinter.Clear
    Call PrintersAdd    ' добавление списка принтеров
    If chkPrAbsent = False Then Call PrinterCheck   ' очистка списка принтеров от отсутствующих в системе
    If cboPrinter.ListCount = 1 Then cboPrinter.ListIndex = 0
End Sub
 
Private Sub SeparatorSpiska()
    If Nalich_CSV < 1 Then Exit Sub
    If cboFZSp.value = "Выберите задание..." Then Exit Sub
    
    Dim book_adr_str As String         ' остатки строки с названием, адресом и количеством страниц в макете
    Dim book_adr_str_len As Integer
    Dim book_adr_str_left As Integer
    Dim book_name As String
    Dim copies_print As Integer     ' количество копий файлов, отправляемых на печать
    Dim F As Long                   ' уникольный номер файла в системе
    Dim for_case As String          ' признак печати (текст, обложка, вкладышь и пр.)
    Dim kategCount As Byte
    Dim line_name As String
    Dim MyText As String            ' строка из файла-задания, взятая целиком
    Dim MyText_len As Integer       ' посчитали количество символов во всей строке, полученной из файла-задания
    Dim MyText_left As Integer
    Dim MyText_right As Integer
    Dim path_f As String            ' адрес расположения обрабатываемого файла-задания
    Dim priznak As String
    Dim str As Integer              ' "номер строки" (индекс строки)
    Dim zadanie As String           ' искомый признак строки для отправки файла на печать
    
    cboKatSp.Clear
    'cboKatSp.ColumnCount = 2            ' указываем количество столбцов
    'cboKatSp.ColumnWidths = "150; 0"    ' устанавливаем ширину столбцов
    path_f = lblFZPath.Caption & cboFZSp.value
    F = FreeFile
    Open path_f For Input As #F
    Do Until EOF(F)
        Line Input #F, MyText
        If MyText <> "" Then
            MyText_len = Len(MyText)
            MyText_left = InStr(1, MyText, Chr(9))  ' нашли каким слева по счёту символом является "разделитель"
            for_case = Left(MyText, MyText_left - 1)
            If for_case <> "текст" Then
                str = cboKatSp.ListCount
                priznak = ""                ' обнулили значение признака наличия
                Do While str > 0
                    str = str - 1
                    line_name = cboKatSp.List(str, 0)
                    If line_name = for_case Then
                        priznak = "есть"    ' если задание совпадает с "файлом", то
                        Exit Do
                    End If
                Loop
                If priznak <> "есть" Then cboKatSp.AddItem for_case   ' добавили новую категорию
            End If
        End If
    Loop
    Close #F
    cboKatSp.AddItem "Все категории"    ' добавили "объединительную" категорию
    kategCount = cboKatSp.ListCount
    If kategCount > 20 Then kategCount = 20
    cboKatSp.ListRows = kategCount
End Sub
 
Private Sub SpisReload()             ' ====== процедура: перезагрузка "списка" (вклвдка "Список")
    lblAdr.Caption = "Адрес выбранного файла..."
    lblAdr.Enabled = False
    lblName.Caption = "Выбранный файл..."
    lblName.Enabled = False
    lstSpis.Clear
    lstSpis.Enabled = False
    PrintDo = 0
    PrintOt = 0
    cmdCalcS.Enabled = False
    txbCopies.BackColor = &H80000004
    txbCopies.Enabled = False
    txbCopies.value = Null
End Sub
 
Private Sub SpisViewReload()    ' процедура: обновление внешнего вида вкладки "Список"
    Dim for_case As String   ' тип составляемого списка
    cboOtDoSp.Clear
    for_case = cboDoliaSp.value
    If for_case = "От и До" Then
        cboOtDoSp.AddItem "От..."
        cboOtDoSp.AddItem "...До"
        cboOtDoSp.ListIndex = 0
        cboOtDoSp.Visible = True
        lblName.Caption = "Начало печати..."
        lblAdr.Caption = "Окончание печати..."
        lblAdr.Enabled = True
     Else
        cboOtDoSp.Visible = False
        If for_case = "От..." Or for_case = "...До" Then
            lblName.Caption = "Начало печати..."
            lblAdr.Caption = "Окончание печати..."
            lblAdr.Enabled = True
         Else
            lblName.Caption = "Выбранный файл..."
            lblAdr.Caption = "Адрес выбранного файла..."
            lblAdr.Enabled = False
        End If
    End If
    lblName.Enabled = True
    cmdCalcS.Enabled = False
    txbCopies.BackColor = &H80000004
    txbCopies.Enabled = False
    txbCopies.value = Null
End Sub
 
Private Sub VizFromArhiv()
    If cboVizArhiv.value = "Укажите файл для возврата из архива..." Then Exit Sub
    If cboVizArhiv.value = "" Then Exit Sub
    If cboVizArhiv.value = "В архиве файлов нет..." Then Exit Sub
    
    Dim f_name As String
    Dim f_name_big As String
    Dim f_name_smal As String
    Dim j_right_v As Integer
    Dim pechat_len As Integer
    Dim pechat_v1 As String
    Dim pechat_v2 As String
    Dim sName As String           ' старое имя файла и его распложение
    Dim dName As String           ' новое имя файла и его расположение
    Dim WFName As String          ' имя не найденного файла
    
    f_name_big = cboVizArhiv.value
    f_name = lblVArh.Caption & f_name_big
    If ProverNalichFiles(f_name) Then
        f_name_smal = Right(f_name_big, Len(f_name_big) - 12)
        sName = f_name
        dName = lblVPath.Caption & f_name_smal
        FileCopy Source:=sName, Destination:=dName
        Kill sName
        
        j_right_v = InStrRev(f_name_big, ",")               ' нашли каким справа по счёту символом является ","
        pechat_v1 = Left(f_name_big, (j_right_v - 1))       ' получили промежуточное имя для отчета
        pechat_len = Len(pechat_v1)                         ' посчитали оставшееся количество символов в строке
        pechat_v2 = Right(pechat_v1, (pechat_len - 24))     ' получили конечное имя для отчета
        lstLog.AddItem "ВОЗВРАЩЕНО из архива: [" & pechat_v2 & "]"
     Else
        WFName = f_name_big
        MsgBox "Указанный Вами файл (*.tif):" & Chr(13) & _
               WFName & Chr(13) & _
               "не обнаружен!" & Chr(13) & _
               "Сейчас будет произведена перезагрузка списков." & Chr(13) & _
               "ПОВТОРИТЕ СВОЙ ВЫБОР.", vbExclamation
        Call VizReloadArhiv
    End If
    
    f_name_big = Left(f_name_big, Len(f_name_big) - 4) & ".jpg"
    f_name = lblVArh.Caption & f_name_big
    If ProverNalichFiles(f_name) Then
        f_name_smal = Right(f_name_big, Len(f_name_big) - 12)
        sName = f_name
        dName = lblVPath.Caption & f_name_smal
        FileCopy Source:=sName, Destination:=dName
        Kill sName
     Else
        WFName = f_name_big
        MsgBox "Искомый файл PreView:" & Chr(13) & WFName & Chr(13) & "не обнаружен!", vbExclamation
    End If
    
    lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
End Sub
 
Private Sub VizLoadSpis()
    If Nalich_VIZ < 0 Then Exit Sub
    
    Dim count_fv As Integer             ' счетчик файлов, в штуках
    Dim pPrint As Integer               ' необходимое количество визиток
    Dim pCount As Integer               ' общее количество копий на печать
    Dim FVizName As String              ' адрес и именя файла к печати
    Dim j_right_t As Integer
    Dim j_right_v As Integer
    Dim lost_time_v As Integer          ' совокупная потеря времени при загрузке печатаемых страниц в принтер, в минутах
    Dim name_STif As String             ' имя файла целиком (c .tif)
    Dim name_BezTif As String           ' имя файла без хвоста (без .tif)
    Dim name_len_v As Integer
    Dim pechat_len As Integer
    Dim pechat_v1 As String
    Dim pechat_v2 As String
    Dim second_v As Integer             ' временя печати одной страницы, в секундах
    Dim second_lost_v As Integer
    Dim str_v As Byte                   ' "номер строки" при добавлении заданий в список
    Dim time_chas As Byte
    Dim time_chas_v As Byte             ' общее время печати, в часах
    Dim time_min_v As Long              ' общее время печати, в минутах
    Dim time_v_label As String
    Dim time_lost_v_label As String
    Dim time_label As String            ' отображаемое время
    
    lstViz.Enabled = True
    lstViz.Clear                                ' доп.функция очистки списка заданий: очищаем lstViz.Clear
    lstViz.ColumnCount = 4                      ' указываем количество столбцов
    lstViz.ColumnWidths = "150; 55; 55; 55; 0"  ' устанавливаем ширину столбцов
    lstViz.AddItem "Название задания:"          ' добавляем заголовок "Название задания"
    lstViz.List(0, 1) = "Бумага, г/м:"          ' добавляем заголовок "Бумага, г/м:"
    lstViz.List(0, 2) = "Листов, шт:"           ' добавляем заголовок "Листов, шт:"
    lstViz.List(0, 3) = "Время, мин:"           ' добавляем заголовок "Время, мин:"
    lstViz.List(str_v, 4) = FVizName            ' сохраняем имя файла
    str_v = 0                                   ' переменная "номер строки", индекс строки
    count_fv = 0
    pPrint = 0
    pCount = 0
    If cboPrinter.value = "Укажите принтер ..." Then
       second_v = lstPrinter.List(1, 1)                     ' получаем время печати одной страницы
     Else
       second_v = cboPrinter.List(cboPrinter.ListIndex, 1)  ' получаем время печати одной страницы
    End If
    
    FVizName = Dir(lblVPath.Caption & "*.tif")  ' указываем адрес поиска файлов
    While FVizName <> ""                        ' цикл наполнения списка визиток (подготовка задания на печать)
        str_v = str_v + 1                       ' смещаемся на одну строку ниже
        name_STif = FVizName                    ' получили имя файла целиком
        j_right_t = InStrRev(name_STif, ".")    ' нашли каким справа по счёту символом является "."
        name_BezTif = Left(name_STif, (j_right_t - 1))      ' получили имя файла без ".tif"
        name_len_v = Len(name_BezTif)                       ' посчитали оставшееся количество символов в строке
        j_right_v = InStrRev(name_BezTif, ",")              ' нашли каким справа по счёту символом является ","
        pPrint = CInt(Right(name_BezTif, (name_len_v - (j_right_v + 1)))) ' получили количество печатаемых визиток
        pechat_v1 = Left(name_BezTif, (j_right_v - 1))      ' получили промежуточное имя задания на печать
        pechat_len = Len(pechat_v1)                         ' посчитали оставшееся количество символов в строке
        pechat_v2 = Right(pechat_v1, (pechat_len - 12))     ' получили конечное имя задания на печать
        lstViz.AddItem pechat_v2                            ' добавляем имя задания
        lstViz.List(str_v, 1) = "280 г/м"                   ' добавляем параметр бумаги
        lstViz.List(str_v, 2) = pPrint                      ' записываем количество печатаемых страниц
        lstViz.List(str_v, 3) = Fix(CDbl(pPrint) * CDbl(second_v) / CDbl(60))    ' высчитываем время печати
        lstViz.List(str_v, 4) = FVizName                    ' записываем имя файла
        count_fv = count_fv + 1                             ' счетчик найденных файлов
        pCount = pCount + pPrint    ' получили общее количество печатаемых листов
        FVizName = Dir
    Wend         ' конец цикла наполнения
    
    time_min_v = CLng(Fix(CLng(pCount) * CLng(second_v) / CLng(60)))         ' вычислили общее время печати, в минутах
    time_chas_v = 0
    If time_min_v < 60 Then
       time_v_label = CInt(time_min_v) & " мин. "
      Else
        Do While time_min_v > 60
           time_min_v = time_min_v - 60
           time_chas_v = time_chas + 1
        Loop
        time_v_label = time_chas_v & " ч. " & time_min_v & " мин. "
    End If
    If second_lost_v < 60 Then       ' вычислили общие потери времени на загрузку страниц в принтер
       time_lost_v_label = "[" & CInt(second_lost_v) & " сек.] "
      Else
       time_lost_v_label = "[" & (second_lost_v * count_fv / 60) & " мин.] "
    End If
    lblTime.Caption = "Общее время печати: " & time_v_label & time_lost_v_label & " (" & pCount & " стр.)"
      
    lstViz.ListIndex = 0
End Sub
 
Private Sub VizReload()     ' ========= процедура: перезагрузка списка визиток =========
    Dim FNameFull As String                       ' имя PreView к обрабатываемой визитке с "путями"
    FNameFull = ""
    Image1.PictureSizeMode = fmPictureSizeModeZoom
    Image1.Picture = LoadPicture(FNameFull)
    If Nalich_PRINTER < 1 Then Exit Sub ' если список принтеров пуст, то пропускаем процедуру
    Call ProverNalichViz
    If Nalich_VIZ < 1 Then Exit Sub     ' если визиток нет, то прерываем процедуру
    Call VizLoadSpis                    ' загрузка списка визиток
    'CheckBox3.Value = False            ' снимаем пометку о необходимости корекции количества копий
    chkVizToArh.value = True            ' включаем автоматическую архивацию
    cmdPRINT.Enabled = False
    cmdArhiving.Enabled = False
    txbCopy.Enabled = True
    txbCopy.BackColor = &H80000004
    txbCopy.value = Null
    txbCopy.Enabled = False
End Sub
 
Private Sub VizReloadArhiv()            ' ========= процедура: отобразить список архива =========
    Dim FVizName As String
    Dim count_f As Integer           ' счетчик найденных файлов
    count_f = 0
    cboVizArhiv.Clear
    FVizName = Dir(lblVArh.Caption & "*.tif")
    While FVizName <> ""
        cboVizArhiv.AddItem (FVizName)
        count_f = count_f + 1
        FVizName = Dir
    Wend
    If count_f > 0 Then
       cboVizArhiv.value = "Укажите файл для возврата из архива..."
       cboVizArhiv.Enabled = True
     Else
       cboVizArhiv.value = "В архиве файлов нет..."
       cboVizArhiv.Enabled = False
    End If
End Sub
 
Private Sub VizToArhiv()        ' ====== процедура: архивация визиток ======
    If lstViz.value = "Название задания:" Then Exit Sub ' защита от ошибочного архивирования "шапки" (это не возможно)
    
    Dim fDirName As String
    Dim FVizName As String      ' имя обрабатываемой группы файлов
    Dim sName As String         ' старое имя файла и его распложение
    Dim dName As String         ' новое имя файла и его расположение
    Dim WFName As String        ' имя не найденного файла
    
    FVizName = lstViz.List(lstViz.ListIndex, 4)
    fDirName = lblVPath.Caption & FVizName      ' задаем адрес поиска файлов визиток, готовых к печати
    If ProverNalichFiles(fDirName) Then                               ' если нет подготовленных к печати файлов, то
        sName = lblVPath.Caption & FVizName                           ' помещаем в архив "печатаемый файл"
        dName = lblVArh.Caption & Format(Now, "yyyy.mm.dd") & "_ " & FVizName
        FileCopy Source:=sName, Destination:=dName
        Kill sName
     Else                                               ' если нет подготовленных к печати файлов, то
        WFName = FVizName
        MsgBox "Искомый файл (*.tif):" & Chr(13) & WFName & Chr(13) & "не обнаружен!", vbExclamation
    End If
    
    ' задаем адрес поиска файлов визиток, готовых к печати
    fDirName = lblVPath.Caption & Left(FVizName, Len(FVizName) - 4) & ".jpg"
    If ProverNalichFiles(fDirName) Then                             ' если нет подготовленных к печати файлов, то
        sName = lblVPath.Caption & Left(FVizName, Len(FVizName) - 4) & ".jpg"   ' помещаем в архив PreView
        dName = lblVArh.Caption & Format(Now, "yyyy.mm.dd") & "_ " & Left(FVizName, Len(FVizName) - 4) & ".jpg"
        FileCopy Source:=sName, Destination:=dName
        Kill sName
     Else                                               ' если нет подготовленных к печати файлов, то
        WFName = Left(FVizName, Len(FVizName) - 4) & ".jpg"
        MsgBox "Искомый файл PreView:" & Chr(13) & WFName & Chr(13) & "не обнаружен!", vbExclamation
    End If
    
    lstLog.AddItem "помещено в АРХИВ: [" & FVizName & "]"
    lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
End Sub
 
 
 
 
 
 
 
 
 
' ##################### ______ функции ______ #####################
Private Function PrintBrosh( _
        printer_selected As String _
        ) As String                        ' ========= ПЕЧАТЬ буклетов=========
    Dim AllStrings() As String
    Dim adr As String               ' адрес и имя печатаемого файла
    Dim count_copies As Long        ' счётчик отправленых на печать страниц
    Dim count_f As Integer          ' счётчик оставшихся файлов
    Dim count_fp As Integer         ' счётчик отправленых файлов
    Dim copies_print As Integer     ' количество копий файла для печати
    Dim count_p As Integer          ' счётчик оставшихся страниц
    Dim doc1 As Document
    Dim for_case As String          ' ПРИЗНАК печати (текст, обложка, вкладышь и пр.) обрабатываемой строки
    Dim Fp As Long                  ' счётчик открытых файлов
    Dim Fi As Long                  ' счётчик открытых файлов
    Dim Fn As Long                  ' счётчик открытых файлов
    Dim MyText As String
    Dim MsgText As String           ' сообщение о окончании печати.
    Dim name_csv As String          ' адрес и имя файла-задания
    Dim name_info As String         ' адрес и имя *.info-файла
    Dim name_log As String          ' адрес и имя файла отчета
    Dim second As Integer           ' время печати одной страницы
    Dim second_lost As Byte         ' потери времени на загрузку файла в принтер
    Dim str As Byte                 ' номер строки
    Dim time_chas As Byte           ' общее время печати, в часах
    Dim time_min As Long            ' общее время печати, в минутах
    Dim time_label As String        ' отображаемое время печати
    Dim time_logIn As Date
    Dim time_logOut As Date
    Dim time_lost As Integer        ' общие потери времени на загрузку в принтер файлов, поставленных в очередь
    Dim time_post As Integer        ' время, за которое файлы отправлены на печать
    Dim zadanie As String           ' требуемый ПРИЗНАК печати (текст, обложка, вкладышь и пр.)
    Dim WhatCsv As String           ' имя обрабатываемого файла-задания
    Dim work_in As Double           ' продолжительность (время) "занятости" принтера
    Dim wait_for As Double
    
    time_logIn = Now                ' засекаем время начала отправки на печать
    
    WhatCsv = cboFZad.value
    name_csv = lblFZPath.Caption & WhatCsv
    If ProverNalichFiles(name_csv) = False Then
        MsgBox "Файл-задание: " & cboFZad.value & Chr(13) _
            & "НЕ ОБНАРУЖЕН!!!" & Chr(13) & Chr(13) _
            & "Сейчас будет произведена перезагрузка списков." & Chr(13) _
            & "Затем, ПОВТОРИТЕ СВОЙ ВЫБОР." _
            , vbCritical _
            , "Ошибка: файл-задание не обнаружен."
        Call FZReload
        Call FZReloadArhiv
        Exit Function
    End If
    count_fp = 0                      ' счётчик отправленых файлов
    count_copies = 0                  ' счётчик отправленых копий (страниц) на печать
    zadanie = lstMain.value          ' получаем ТРЕБУЕМЫ ПРИЗНАК печати (текст, обложка, вкладышь и пр.)
    
    Fp = FreeFile
    Open name_csv For Input As #Fp
    Do Until EOF(Fp)
        Line Input #Fp, MyText
        If MyText <> "" Then
            AllStrings = Split(MyText, Chr(9))
            for_case = AllStrings(0)
            If zadanie = for_case Then                  ' если задание совпадает с "файлом", то
                copies_print = AllStrings(4)            ' получили количество КОПИЙ
                If copies_print > 0 Then                ' если количество копий не 0, то
                    adr = Replace(AllStrings(2), Chr(34), "")
                    Set doc1 = OpenDocument(adr)        ' открыть документ
                    With doc1.PrintSettings
                             .SelectPrinter printer_selected    ' указать принтер для печати
                             .Collate = True                    ' разобрать по копиям
                             .Copies = copies_print             ' количество копий для печати
                    End With
                    doc1.PrintOut           ' печать документа
                    doc1.Close              ' закрыть документ
                    Set doc1 = Nothing      ' освободили переменную
                    count_fp = count_fp + 1 ' "счётчик файлов"
                    count_copies = count_copies + copies_print  ' "счётчик копий"
                End If
            End If
        End If
    Loop             ' начать цикл заново
    Close #Fp        ' закрыть файл по выполнении цикла
    
    ' ----------- отчёт в программу -----------
    time_logOut = Now                                     ' засекаем время окончания отправки на печать
    second = cboPrinter.List(cboPrinter.ListIndex, 1)       ' получаем время печати одной страницы
    second_lost = cboPrinter.List(cboPrinter.ListIndex, 4)  ' получаем "потери" времени
    ' секунда - 1/86400 дня
    ' посчитали work_in = "время печати" + "время потери", в сек.
    work_in = CDec((count_copies * second + count_fp * second_lost) / 86400)
    wait_for = CDec(time_logIn) + work_in        ' посчитали wait_for = "время начала печати" + work_in, в сек.
    lstLog.AddItem Format(time_logIn, "hh:mm:ss") & "  ЗАДАНИЕ : [" & zadanie _
                     & "], (" & count_copies & " стр.;  " & Format(work_in, "hh:mm:ss") & " мин.)"
    lstLog.AddItem "                 принтер: " & printer_selected _
                   & ";   занят до: " & Format(wait_for, "hh:mm:ss")
    lstLog.AddItem "---------------------------------------------------------------------------------------------------------"
    lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
    
    ' ----------- отчёт в файл ОТПРАВЛЕНЫХ ЗАДАНИЙ -----------
    ' "собираем" путь для файл-отчёта
    name_info = lblFZPath.Caption & Left(WhatCsv, Len(WhatCsv) - 3) & ".info"
    
    Fi = FreeFile   ' добавляем автоматический счётчик открытых файлов
    Open name_info For Append As #Fi            'открываем файл для дабавления
        ' добавляем строку в файл-отчет
        Print #Fi, zadanie & "; напечатано: " & Format(Now, "yyyy.mm.dd hh:mm:ss")
    Close #Fi
    
    ' ----------- отчёт в файл СТАТИСТИКА -----------
    ' "собираем" путь для файл-отчёта
    name_log = "d:\Raspechatka\.Автоматизация\" & "log\" & "EpsPrint_" & Format(Now, "yyyy.mm.dd") & ".log"
    Fn = FreeFile                                             ' добавляем автоматический счётчик открытых файлов
    time_post = CInt((time_logOut - time_logIn) * 100000)     ' высчитываем время отправки на печать, в секундах
    Open name_log For Append As #Fn                           ' открываем файл для дабавления
        ' добавляем строку в файл-отчет
        Print #Fn, Now & printer_selected & ";" & zadanie & ";" & count_copies & ";" _
                      & count_fp & ";" & time_post & ";" & CInt(time_post / count_fp) _
                      & ";" & second & ";" & second_lost
    Close #Fn   ' закрываем файл-отчёт и сохраняем
    
    chkPrinted.Enabled = True
    MsgText = "Отправка (" & zadanie & ") на печать завершена!"
    count_f = 0
    str = lstMain.ListCount - 1
    count_p = 0
    If str > 0 Then
        Do While str > 0
            count_f = count_f + lstMain.List(str, 5)
            count_p = count_p + lstMain.List(str, 2)
            str = str - 1
        Loop
    Else
        lstMain.ListIndex = 0
    End If
    time_min = CLng((CLng(count_p) * CLng(second)) / 60)
    
    If time_min < 60 Then
        time_label = time_min & " мин., "
    Else
        time_chas = 0
        Do While time_min >= 60
            time_min = time_min - 60
            time_chas = time_chas + 1
        Loop
        time_label = time_chas & " ч. " & time_min & " мин., "
    End If
    time_lost = second_lost * count_f / 60            ' потери времени на загрузку файлов в принтер, в минутах
    lblVybor.Caption = "Общее время печати: " & time_label & "[" & time_lost & " мин.] " & " (" & count_p & " стр.)"
    
    lstMain.RemoveItem (lstMain.ListIndex)         ' удаляем выполненное задание из списка заданий
    lstMain.SetFocus                                ' вернули фокус
    
    ' проверяем выбрана ли процедура архивирования
    If chkArhiving.value = True And lstMain.ListCount < 2 Then
        Call cmdArhiving_Click                   ' отправляем файл в архив
        chkArhiving.value = False                       ' сняли пометку на архивирование
    End If
    PrintBrosh = MsgText
End Function
 
Private Function PrintBroshOtDo( _
        printer_selected As String _
        ) As String                       ' ========= ПЕЧАТЬ буклетов=========
    If PrintDo < PrintOt Then Exit Function  ' проверка на корректность старта печати
    
    Dim adr As String                       ' адрес и имя печатаемого файла
    Dim count_f As Integer                  ' счётчик отправленых файлов
    Dim count_copies As Integer             ' счётчик отправленых на печать страниц
    Dim copies_print As Integer             ' количество копий файла для печати
    Dim doc1 As Document
    Dim Fn As Long                          ' счётчик открытых файлов
    Dim name_log As String                  ' адрес и имя файла отчета
    Dim second As Integer                   ' время печати одной страницы
    Dim second_lost As Byte                 ' потери времени на загрузку файла в принтер
    Dim time_post As Integer                ' время, за которое файлы отправлены на печать
    Dim time_logIn As Date
    Dim time_logOut As Date
    Dim str As Long                         ' индекс стоки в списке печати
    Dim work_in As Double                   ' продолжительность (время) "занятости" принтера
    Dim wait_for As Double
    Dim zadanie As String
    
    time_logIn = Now                        ' засекаем время начала отправки на печать
    count_f = 0                             ' счётчик отправленых файлов
    count_copies = 0                        ' счётчик отправленых копий (страниц) на печать
    zadanie = cboKatSp.value
    For str = PrintOt To PrintDo
        adr = lstSpis.List(str, 2)                      ' получаем адрес файла
        copies_print = lstSpis.List(str, 3)             ' получаем количество копий
        Set doc1 = OpenDocument(adr)                    ' открыть документ
        With doc1.PrintSettings
                 .SelectPrinter printer_selected        ' указать принтер для печати
                 .Collate = True                        ' разобрать по копиям
                 .Copies = copies_print                 ' количество копий для печати
        End With
        doc1.PrintOut                                   ' распечатать
        doc1.Close                                      ' закрыть документ
        Set doc1 = Nothing                              ' оболили переменную
        count_f = count_f + 1                           ' "счётчик файлов" = сч.файлов + 1
        count_copies = count_copies + copies_print      ' "счётчик копий" = "счётчик копий" + "количество копий"
    Next str                 ' начать цикл заново
    
    ' ----------- отчёт в программу -----------
    time_logOut = Now                                       ' засекаем время окончания отправки на печать
    second = cboPrinter.List(cboPrinter.ListIndex, 1)         ' получаем время печати одной страницы
    second_lost = cboPrinter.List(cboPrinter.ListIndex, 4)    ' получаем "потери" времени
    ' секунда - 1/86400 дня
    ' посчитали work_in = "время печати" + "время потери", в сек.
    work_in = CDec((count_copies * second + count_f * second_lost) / 86400)
    wait_for = CDec(time_logIn) + work_in        ' посчитали wait_for = "время начала печати" + work_in, в сек.
    lstLog.AddItem Format(time_logIn, "hh:mm:ss") & "  ЗАДАНИЕ : [" & zadanie _
                     & "], (" & count_copies & " стр.;  " & Format(work_in, "hh:mm:ss") & " мин.)"
    lstLog.AddItem "                 принтер: " & printer_selected _
                   & ";   занят до: " & Format(wait_for, "hh:mm:ss")
    lstLog.AddItem "---------------------------------------------------------------------------------------------------------"
    lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
    
    ' ----------- отчёт в файл СТАТИСТИКА -----------
    ' "собираем" путь для файл-отчёта
    name_log = "d:\Raspechatka\.Автоматизация\" & "log\" & "EpsPrint_" & Format(Now, "yyyy.mm.dd") & ".log"
    Fn = FreeFile                                             ' добавляем автоматический счётчик открытых файлов
    time_post = CInt((time_logOut - time_logIn) * 100000)     ' высчитываем время отправки на печать, в секундах
    Open name_log For Append As #Fn                           ' открываем файл для дабавления
         ' добавляем строку в файл-отчет
         Print #Fn, Now & printer_selected & ";" & zadanie & ";" & count_copies & ";" _
                        & count_f & ";" & time_post & ";" & CInt(time_post / count_f) _
                        & ";" & second & ";" & second_lost
    Close #Fn   ' закрываем файл-отчёт и сохраняем
    
    cmdPRINT.Enabled = False
    lblName.Caption = "Начало печати..."
    lblAdr.Caption = "Окончание печати..."
      
    PrintBroshOtDo = "Отправка на печать завершена!"
End Function

Private Function PrintBroshSpisok( _
        printer_selected As String _
        ) As String                        ' ========= ПЕЧАТЬ из "списка" =========
    If txbCopies.value = "" Then
        MsgBox "Укажите количество копий, отправляемых на печать." _
                , vbQuestion _
                , "Ошибка: количество копий не указано."
        Exit Function
    End If
    If txbCopies.value < 1 Then
       MsgBox "Количество копий, отправляемых на печать, не может быть меньше или равно нолю." & Chr(13) _
            & "Уточните данный параметр." _
            , vbQuestion _
            , "Ошибка: количество копий указано не верно."
       Exit Function
    End If
    
    Dim adr As String                       ' адрес и имя печатаемого файла
    Dim count_f As Byte                     ' счётчик файлов, отправляемых на печать
    Dim copies_print As Integer             ' количество копий файла для печати
    Dim doc1 As Document
    Dim Fn As Long                          ' счётчик открытых файлов
    Dim name_a As String                    ' что печатается
    Dim name_log As String                  ' адрес и имя файла отчета
    Dim second As Integer                   ' время печати одной страницы
    Dim second_lost As Byte                 ' потери времени на загрузку файла в принтер
    Dim time_post As Integer                ' время, за которое файлы отправлены на печать
    Dim time_logIn As Date
    Dim time_logOut As Date
    Dim zadanie As String                   ' требуемый ПРИЗНАК печати (текст, обложка, вкладышь и пр.)
    Dim work_in As Double                   ' продолжительность (время) "занятости" принтера
    Dim wait_for As Double
      
    time_logIn = Now                        ' засекаем время начала отправки на печать
    adr = lstSpis.List(lstSpis.ListIndex, 2)        ' указываем адрес файла
    copies_print = txbCopies.value
    count_f = 1
    name_a = lstSpis.List(lstSpis.ListIndex, 0)     ' указываем что печатаем (название)
    zadanie = lstSpis.List(lstSpis.ListIndex, 1)    ' указываем тип печатаемого
    Set doc1 = OpenDocument(adr)                    ' открыть документ
    With doc1.PrintSettings
             .SelectPrinter printer_selected        ' указать принтер для печати
             .Collate = True                        ' разобрать по копиям
             .Copies = copies_print                 ' количество копий для печати
    End With
    doc1.PrintOut           ' распечатать
    doc1.Close              ' закрыть документ
    Set doc1 = Nothing      ' освободили переменную
    ' ----------- отчёт в программу -----------
    time_logOut = Now                              ' засекаем время окончания отправки на печать
    second = cboPrinter.List(cboPrinter.ListIndex, 1)         ' получаем время печати одной страницы
    second_lost = cboPrinter.List(cboPrinter.ListIndex, 4)    ' получаем "потери" времени
    
    ' секунда - 1/86400 дня
    ' посчитали work_in = "время печати" + "время потери", в сек.
    work_in = CDbl((copies_print * second + count_f * second_lost) / 86400)
    wait_for = CDbl(time_logIn) + work_in        ' посчитали wait_for = "время начала печати" + work_in, в сек.
    lstLog.AddItem Format(time_logIn, "hh:mm:ss") & "  ЗАДАНИЕ : [" & zadanie _
                     & "], (" & copies_print & " стр.;  " & Format(work_in, "hh:mm:ss") & " мин.)"
    lstLog.AddItem "                 принтер: " & printer_selected _
                   & ";   занят до: " & Format(wait_for, "hh:mm:ss")
    lstLog.AddItem "---------------------------------------------------------------------------------------------------------"
    lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
    
    ' ----------- отчёт в файл СТАТИСТИКА -----------
    ' "собираем" путь для файл-отчёта
    name_log = "d:\Raspechatka\.Автоматизация\" & "log\" & "EpsPrint_" & Format(Now, "yyyy.mm.dd") & ".log"
    Fn = FreeFile                                             ' добавляем автоматический счётчик открытых файлов
    time_post = CInt((time_logOut - time_logIn) * 100000)     ' высчитываем время отправки на печать, в секундах
    Open name_log For Append As #Fn                           ' открываем файл для дабавления
        ' добавляем строку в файл-отчет
         Print #Fn, Now & printer_selected & ";" & zadanie & ";" & copies_print & ";" _
                        & count_f & ";" & time_post & ";" & time_post _
                        & ";" & second & ";" & second_lost
    Close #Fn   ' закрываем файл-отчёт и сохраняем
    PrintBroshSpisok = "Отправлено на печать (" & copies_print & " шт.):" & Chr(13) & name_a
    txbCopies.value = Null
End Function
 
Private Sub PrintVizitka( _
        printer_selected As String _
        )       ' ========= ПЕЧАТЬ визиток =========
    If lstViz.value = "Название задания:" Then
        MsgBox "Укажите ЗАДАНИЕ для печати!", vbQuestion, "Ошибка: не выбрано задание."
        Exit Sub
    End If
    
    Dim count_fv As Integer            ' количество файлов, в штуках
    Dim copies_list As Integer         ' количество печатуемых листов
    Dim doc1 As Document
    Dim Fn As Long
    Dim FVizName As String             ' адрес и именя файла к печати
    Dim lost_time_v As Integer         ' совокупная потеря времени при загрузке печатаемых страниц в принтер, в минутах
    Dim name_log As String             ' путь и имя файла-отчёта
    Dim second_v As Integer            ' временя печати одной страницы, в секундах
    Dim second_lost_v As Integer       ' потери времени при загрузке печатаемой страницы в принтер, в секундах
    Dim time_chas_v As Byte            ' общее время печати, в часах
    Dim time_logIn As Date
    Dim time_logOut As Date
    Dim time_min_v As Integer          ' общее время печати, в минутах
    Dim time_post As Integer           ' время, за которое файлы отправлены на печать
    Dim wait_for As Double
    Dim work_in As Double
    Dim zadanie As String              ' ПРИЗНАК печати (текст, обложка, вкладышь и пр.)
    
    zadanie = lstViz.List(lstViz.ListIndex, 0)
    time_logIn = Now                         ' получили время начала отправки на печать
    
    ' проверяем необходимость коррекции количества откравляемых копий
    If cboDoliaViz.value = "Коррекция числа копий:" Then
        copies_list = CInt(txbCopy.value)    ' задали новое количество печатаемых копий
    Else
        copies_list = lstViz.List(lstViz.ListIndex, 2)
    End If
    If copies_list > 0 Then
        FVizName = lstViz.List(lstViz.ListIndex, 4)
        Dim fPathName As String
        fPathName = lblVPath.Caption & FVizName
        Set doc1 = OpenDocument(fPathName)      ' открыть документ
        With doc1
            With .PrintSettings
                 .SelectPrinter printer_selected  ' указать принтер для печати
                 .Collate = True                  ' разобрать по копиям
                 .Copies = copies_list            ' количество копий для печати
            End With
            .PrintOut     ' отправили на принтер
            .Close        ' закрыли документ
        End With
        Set doc1 = Nothing
    Else
        MsgBox "Уточните количество копий, отправляемых на печать." & Chr(13) & _
               "Оно не может быть меньше или равно 0.", _
               , _
               "Ошибка: количество копий указано не верно."
        Exit Sub
    End If
    
    ' ----------- отчёт в программу -----------
    second_v = cboPrinter.List(cboPrinter.ListIndex, 1)       ' получаем время печати одной страницы
    second_lost_v = cboPrinter.List(cboPrinter.ListIndex, 4)  ' получаем "потери" времени
    ' секунда - 1/86400 дня
    ' посчитали work_in = "время печати" + "время потери", в сек.
    work_in = CDec((copies_list * second_v + second_lost_v) / 86400)
    ' посчитали wait_for = "время окончания отправки" + work_in, в сек.
    time_logOut = Now                             ' засекаем время окончания отправки
    wait_for = CDec(time_logOut) + work_in        ' высчитываем восколько освободится принтер
    lstLog.AddItem Format(time_logIn, "hh:mm:ss") & "  ЗАДАНИЕ : [" & zadanie _
                & "], " & copies_list & " стр.; отпечатается за: " & Format(work_in, "hh:mm:ss")
    lstLog.AddItem "                 принтер: " & printer_selected _
                & ";   занят до: " & Format(wait_for, "hh:mm:ss")
    lstLog.AddItem "---------------------------------------------------------------------------------------------------------"
    lstLog.ListIndex = lstLog.ListCount - 1   ' выделяем последнюю строку в отчёте
    
    ' ----------- отчёт в файл СТАТИСТИКА -----------
    ' "собираем" путь для файл-отчёта
    name_log = "d:\Raspechatka\.Автоматизация\" & "log\" & "EpsPrint_" & Format(Now, "yyyy.mm.dd") & ".log"
    
    Fn = FreeFile   ' добавляем автоматический счётчик открытых файлов
    time_post = CInt((time_logOut - time_logIn) * 100000)    ' высчитываем время отправки на печать, в секундах
    Open name_log For Append As #Fn    'открываем файл для дабавления
        ' добавляем строку в файл-отчет
         Print #Fn, Now & printer_selected & ";" _
                        & "визитка " & zadanie & ";" _
                        & copies_list & ";" _
                        & "1;" _
                        & time_post & ";" _
                        & time_post & ";" _
                        & second_v & ";" _
                        & second_lost_v
    Close #Fn   ' закрываем файл-отчёт и сохраняем
    'CheckBox3.Value = False
End Sub
 
Private Function ProverNalichFiles( _
        ByRef fDirName As String _
        ) As Boolean    ' ===== проверка на существование искомого файла
    Dim fExist As Boolean
    Dim fName As String
    
    fExist = False
    fName = Dir(fDirName)
    Do While fName <> ""
        ProverNalichFiles = True
        fExist = True
        fName = Dir
        Exit Do
    Loop
    ProverNalichFiles = fExist
End Function
 
Private Function RemoveExcess( _
        ByVal strSearchIn As String, _
        ByVal strSearchFor As String, _
        ByVal KeepInLine As Boolean _
        ) As String             '=== функция: очистка строки от набора символов
    Dim i As Integer
    Dim strNew As String        ' "очищенная" строка
    Dim siMid As String * 1     ' выделенный символ
    Dim siLen As Integer        ' длинна очищаемой строки
    
    strNew = strSearchIn
    siLen = Len(strNew)
    For i = 1 To siLen
        siMid = Mid(strSearchIn, i, 1)  ' получили символ из строки
        Select Case KeepInLine
            Case Is = False
                If InStr(strSearchFor, siMid) > 0 Then strNew = Replace(strNew, siMid, "")
            Case Is = True
                If InStr(strSearchFor, siMid) < 1 Then strNew = Replace(strNew, siMid, "")
        End Select
    Next i
    RemoveExcess = strNew
End Function

' глобальные константы
Public Const numbRazriad As Byte = 15   ' разрядность числа
 
' глобальные переменные
Public numbListMem() As Double  ' массив запомненных чисел
Public objAscker As Object      ' объект, запрашивающий калькулятор

Public Sub ListRowMove( _
        ByRef objList As Object, _
        ByVal KeyCode As Integer, _
        ByVal Shift As Integer _
        )
    Dim blnMove As Boolean
    Dim i As Integer
    Dim lisCount As Integer, lisInd As Integer, lisColumn As Integer
    Dim rowFrom As Integer, rowTo As Integer
    Dim strFrom As String, strTo As String
    Dim userAns As Integer
    
    ' Shift = 4 => "Alt"
    lisCount = objList.ListCount
    lisInd = objList.ListIndex
    If lisInd < 0 Or lisInd > (lisCount - 1) Then Exit Sub
    lisColumn = objList.ColumnCount - 1
    blnMove = False
    Select Case KeyCode
        Case Is = 38 And Shift = 4  ' Up
            userAns = MsgBox("Переместить выделенную строку?" _
                            , vbQuestion + vbYesNo _
                            , CStr(frmPrintPP.Caption))
            If userAns <> vbYes Then Exit Sub
            rowFrom = lisInd
            rowTo = lisInd - 1
            If rowTo < 0 Then Exit Sub
            blnMove = True
        Case Is = 40 And Shift = 4  ' Doun
            userAns = MsgBox("Переместить выделенную строку?" _
                            , vbQuestion + vbYesNo _
                            , CStr(frmPrintPP.Caption))
            If userAns <> vbYes Then Exit Sub
            rowFrom = lisInd
            rowTo = lisInd + 1
            If rowTo >= lisCount Then Exit Sub
            blnMove = True
        Case Is = 46    ' Delete
            objList.RemoveItem (lisInd)
            If lisInd = (lisCount - 1) Then MsgBox "Удалена последняя позиция."
    End Select
    If blnMove = True Then  ' "Alt"
        For i = 0 To lisColumn
            strFrom = CStr(objList.List(rowFrom, i))
            strTo = CStr(objList.List(rowTo, i))
            objList.List(rowFrom, i) = strTo
            objList.List(rowTo, i) = strFrom
        Next i
        objList.ListIndex = rowTo
    End If
End Sub
 
Public Sub QuickSort( _
        ByRef arr As Variant, _
        Optional numEls As Variant, _
        Optional descending As Boolean _
        )
    ' QuickSort an array of any type
    ' QuickSort is especially convenient with large arrays (>1,000
    ' items) that contains items in random order. Its performance
    ' quickly degrades if the array is already almost sorted. (There are
    ' variations of the QuickSort algorithm that work good with
    ' nearly-sorted arrays, though, but this routine doesn't use them.)
    '
    ' NUMELS is the index of the last item to be sorted, and is
    ' useful if the array is only partially filled.
    '
    ' Works with any kind of array, except UDTs and fixed-length
    ' strings, and including objects if your are sorting on their
    ' default property. String are sorted in case-sensitive mode.
    '
    ' You can write faster procedures if you modify the first two lines
    ' to account for a specific data type, eg.
    ' Sub QuickSortS(arr() As Single, Optional numEls As Variant,
    '  '     Optional descending As Boolean)
    '   Dim value As Single, temp As Single
    
    Dim value As Variant, temp As Variant
    Dim sp As Integer
    Dim leftStk(32) As Long, rightStk(32) As Long
    Dim leftNdx As Long, rightNdx As Long
    Dim i As Long, j As Long
 
    ' account for optional arguments
    If IsMissing(numEls) Then numEls = UBound(arr)
    ' init pointers
    leftNdx = LBound(arr)
    rightNdx = numEls
    ' init stack
    Dim asd As String
    asd = CStr(arr(1))
    sp = 1
    leftStk(sp) = leftNdx
    rightStk(sp) = rightNdx
 
    Do
        If rightNdx > leftNdx Then
            value = arr(rightNdx)
            i = leftNdx - 1
            j = rightNdx
            ' find the pivot item
            If descending Then
                Do
                    Do: i = i + 1: Loop Until arr(i) <= value
                    Do: j = j - 1: Loop Until j = leftNdx Or arr(j) >= value
                    temp = arr(i)
                    arr(i) = arr(j)
                    arr(j) = temp
                Loop Until j <= i
            Else
                Do
                    Do: i = i + 1: Loop Until arr(i) >= value
                    Do: j = j - 1: Loop Until j = leftNdx Or arr(j) <= value
                    temp = arr(i)
                    arr(i) = arr(j)
                    arr(j) = temp
                Loop Until j <= i
            End If
            ' swap found items
            temp = arr(j)
            arr(j) = arr(i)
            arr(i) = arr(rightNdx)
            arr(rightNdx) = temp
            ' push on the stack the pair of pointers that differ most
            sp = sp + 1
            If (i - leftNdx) > (rightNdx - i) Then
                leftStk(sp) = leftNdx
                rightStk(sp) = i - 1
                leftNdx = i + 1
            Else
                leftStk(sp) = i + 1
                rightStk(sp) = rightNdx
                rightNdx = i - 1
            End If
        Else
            ' pop a new pair of pointers off the stacks
            leftNdx = leftStk(sp)
            rightNdx = rightStk(sp)
            sp = sp - 1
            If sp = 0 Then Exit Do
        End If
    Loop
End Sub
 
 
 
Public Function SpecSimvOchist( _
        ByVal strSearchIn As String, _
        Optional ByVal boolTrim As Boolean = False, _
        Optional ByVal boolSpaseDelete As Boolean = False _
        ) As String             '=== функция: очистка строки от спец. символов
    Dim i As Integer
    Dim strNew As String        ' "очищенная" строка
    Dim siAsc As Integer        ' ANCI код символа
    Dim siMid As String * 1     ' выделенный символ
    Dim siLen As Integer        ' длинна очищаемой строки
    
    strNew = strSearchIn
    siLen = Len(strNew)
    For i = 1 To siLen
        siMid = Mid(strSearchIn, i, 1)  ' получили символ из строки
        siAsc = Asc(siMid)              ' преобразовали полученный символ в ANCII код
        If siAsc < 32 Then strNew = Replace(strNew, siMid, "")    ' удалили спец.символ
    Next i
    If boolTrim = True Then strNew = Trim(strNew)
    If boolSpaseDelete = True Then strNew = Replace(strNew, " ", "")
    SpecSimvOchist = strNew
End Function
 
Public Function WordEnding1(numb As Integer) As String
    Dim strEnding As String
    Select Case numb
    Case Is = 0, Is > 4:    strEnding = "й"
    Case Is = 1:            strEnding = "е"
    Case Is > 1, Is < 5:    strEnding = "я"
    End Select
    WordEnding1 = strEnding
End Function

Option Explicit
 
' ##################### ______ процедуры ____ #####################
 
Public Sub LookForString( _
        ByRef searchTxtBox As Object, _
        ByRef searchListBox As Object, _
        Optional maxLen As Integer = 0 _
        )
    Dim i, j As Integer                ' индекс цикла
    Dim isFinedInt As Integer       ' признак не/найдена искомая строка
    Dim isLong As Boolean           ' признак превышения ограничения по длинне искомой строки
    Dim LookStr As String           ' анализируемая строка
    Dim rowEnd As Long              ' число заполненных строк
    Dim rowStart As Long            ' номер выделенной строки с записями
    Dim searchFor As String         ' искомое значение
    Dim sfLen As Integer            ' длинна искомой строки
    Dim searchNext As String        ' новая искомая строка
    
    searchFor = SpecSimvOchist(searchTxtBox.value)    ' получение строки для анализа и очистка её от спец. символов
    If searchFor = "" Or searchFor = "Поиск..." Or Replace(searchFor, " ", "") = "" Then Exit Sub
    If maxLen > 0 Then
        isLong = False
        searchFor = sfLean(searchFor, maxLen, isLong)  ' приведение длинны строки к норме
        If isLong = True Then searchTxtBox.value = searchFor
    End If
    'If searchListBox.ListIndex < 0 Then rowStart = 0 Else rowStart = searchListBox.ListIndex
    isFinedInt = 0
    LookStr = ""
    rowStart = 0
    rowEnd = searchListBox.ListCount - 1    ' получение номера последней заполненной строки
    sfLen = Len(searchFor)                  ' рассчитали длинну искомой строки
    searchNext = LCase(searchFor)           ' передали искомую строку в новую переменную
    For i = 1 To sfLen
        For j = rowStart To rowEnd
            LookStr = searchListBox.List(j, 0)
            LookStr = SpecSimvOchist(LookStr)   ' очистка анализируемой строки от спец. символов
            isFinedInt = InStr(1, LookStr, searchNext, vbTextCompare)   ' поиск совпадения строк
            If isFinedInt > 0 Then
                searchListBox.ListIndex = j     ' выделяем строку с найденным совпадением
                Exit For
            End If
        Next j
        If isFinedInt > 0 Then Exit For
        searchNext = Left(searchNext, sfLen - i)
    Next i
    If searchFor <> searchNext Then searchTxtBox.value = searchNext
    If isFinedInt < 1 Then
        MsgBox "Поиск введенных вами данных результатов не дал. Исходный запрос: " & Chr(13) _
            & searchFor _
            , vbExclamation _
            , "Поиск строки."
    End If
End Sub
 
 
 
 
' ##################### ______ Функции ______ #####################
 
Private Function sfLean( _
        ByVal searchFor As String, _
        ByVal maxLen As Byte, _
        ByRef strLong As Boolean _
        ) As String                  ' проверка длинны строки
    Dim sfLen As Integer             ' длинна строки
    Dim sfRTrim As String            ' искомая строка без символов "пробел" справа
    
    sfRTrim = RTrim(searchFor)
    sfLen = Len(sfRTrim)
    If sfLen > maxLen Then
        searchFor = Left(searchFor, maxLen)
        MsgBox "Размер искомой строки не должен превышать " & maxLen & "-и символов," & _
            " за исключением крайних пробелов (обрезаются автоматически)." & _
            "Строка обрезана до нужной длинны." _
            , , "Автоматическая коррекция длинны строки."
        strLong = True
        sfLean = searchFor
      Else
        strLong = False
        sfLean = sfRTrim
    End If
End Function

Option Explicit
 
' локальные переменные
Dim flagDoing As String     ' флаг: тип вычислений (/*-+)
Dim flagFirstArr As Boolean ' флаг: осуществлена запись в массив
Dim flagExt As Boolean      ' флаг: передача данных и закрытие формы
Dim flagKeyCode As Integer  ' флаг: нажатая клавиша
Dim flagCalc As Boolean    ' флаг: нажатия клавиша
Dim flagNext As Boolean     ' флаг: набор следующего числа
Dim numbForCalc As Double   ' вычисляемое значение
Dim numbMem As Double       ' "память" для числа
 
 
 
 
'########## _____ Реакции _______ ##########
 
Private Sub cmdBckspc_Click()
    Dim sNumb As String         ' строковое представление набранного числа
    sNumb = txbNumber.value     ' получили строковое представление числа
    If sNumb = "" Then Beep: sNumb = "0": GoTo ExitSub
    sNumb = Left(sNumb, Len(sNumb) - 1)     ' укоротили число на один символ
    If sNumb = "" Then Beep: sNumb = "0"    ' пискнули на ноль
ExitSub:
    txbNumber.value = sNumb     ' вернули остатки числа
    txbNumber.SetFocus          ' установили фокус на обработчик
End Sub
 
Private Sub cmdCalc_Click()
    Dim dblNumb As Double       ' число, набранное в поле
    Dim dblRezult As Double     ' результат вычислений (число)
    Dim nMax As Double          ' максимальное разрешённое число
    Dim pointPosition As Byte   ' позиция разделителя доробной и целой части числа
    Dim sRezult As String       ' результат вычислений (строка)
    Dim sLen As Byte            ' длинна строкового представления числа
    Dim sFormat As String       ' формат числа
    
    flagCalc = True
    If flagDoing = "" Then txbNumber.SetFocus: Exit Sub
    dblNumb = CDbl(Val(Replace(txbNumber.value, ",", ".")))
    Select Case flagDoing
        Case Is = "+":  dblRezult = numbForCalc + dblNumb
        Case Is = "-":  dblRezult = numbForCalc - dblNumb
        Case Is = "*":  dblRezult = numbForCalc * dblNumb
        Case Is = "/"
            If dblNumb > 0 Then
                dblRezult = numbForCalc / dblNumb
              Else
                MsgBox "Деление на ноль запрещено!" _
                    , vbCritical _
                    , "Калькулятор: Ошибка вычислений!"
                txbNumber.value = Replace(CStr(numbForCalc), ".", ",")
                Exit Sub
            End If
    End Select
    nMax = CDbl(String(numbRazriad, "9"))   ' получили максимальное разрешённое число
    If dblRezult > nMax Then
        MsgBox "Превышено допустимое значение числа (" & CStr(nMax) & ")." _
            , vbCritical _
            , "Калькулятор: Ошибка вычислений!"
        txbNumber.value = Replace(CStr(numbForCalc), ".", ",")
        Exit Sub
    End If
    sRezult = CStr(dblRezult)   ' получили строковое представление результата вычисления
    sLen = Len(sRezult)         ' получили длинну строкового представления
    pointPosition = InStr(1, sRezult, ",", vbTextCompare)
    If pointPosition > 0 Then
        If dblRezult < 1 Then sFormat = "0." Else sFormat = String(pointPosition - 1, "#") & "."
        sFormat = sFormat & String(numbRazriad - pointPosition, "#")    ' задали формат числа
        sRezult = Replace(Format(sRezult, sFormat), ".", ",")   ' отформатировали число
    End If
    txbNumber.value = sRezult   ' вернули пользователю результат вычислений
    If IsEmpty(objAscker) = False And (objAscker Is Nothing) = False Then cmdHome.Enabled = True
    flagDoing = ""      ' обнулили флаг действий
    flagNext = True     ' флаг: набор следующего числа
    cmdCalc.Enabled = False
    txbNumber.SetFocus  ' установили фокус на обработчик
End Sub
 
Private Sub cmdDel_Click()
    flagDoing = ""      ' обнулили флаг действий
    flagNext = True     ' флаг: набор следующего числа
    txbNumber.value = "0"
    txbNumber.SetFocus  ' установили фокус на обработчик
End Sub
 
Private Sub cmdDivision_Click()
    Call PreservCalc("/")   '=== процедура: подготовка к вычислениям
End Sub
 
Private Sub cmdHome_Click()
    If IsEmpty(objAscker) Or (objAscker Is Nothing) Then
        MsgBox "Данные не будут сохранены." & Chr(13) _
            & "Не указан объект, вызвавший калькулятор!" _
            , vbCritical _
            , "Калькулятор: Ошибка передачи данных!"
        cmdHome.Enabled = False
        txbNumber.SetFocus  ' установили фокус на обработчик
        Exit Sub
    End If
    objAscker.value = Replace(txbNumber.value, ".", ",")
    flagExt = True      ' флаг: передача данных и закрытие формы
    Unload frmCalc      ' закрываем форму
End Sub
 
Private Sub cmdMC_Click()
    flagNext = True             ' флаг: набор следующего числа
    numbMem = 0
    ReDim numbListMem(0) As Double  ' очищаем массив
    cmdMC.Enabled = False
    cmdMR.Enabled = False
    Unload frmCalcMem           ' закрыли форму "Память калькулятора"
    cmdMemShow.Visible = False
    txbNumber.SetFocus          ' установили фокус на обработчик
End Sub
 
Private Sub cmdMemShow_Click()
    frmCalcMem.Show
    txbNumber.SetFocus  ' установили фокус на обработчик
End Sub
 
Private Sub cmdMinus_Click()
    Call PreservCalc("-")   '=== процедура: подготовка к вычислениям
End Sub
 
Private Sub cmdMR_Click()
    flagNext = True             ' флаг: набор следующего числа
    txbNumber.value = numbMem   ' возвращаем число из памяти
    txbNumber.SetFocus          ' установили фокус на обработчик
End Sub
 
Private Sub cmdMS_Click()
    Dim arrLB, arrUB, arrInd As Integer ' индексы массива
    numbMem = CDbl(Val(Replace(txbNumber.value, ",", "."))) ' сохраняем число "в память"
    If flagFirstArr = False Then
        arrInd = 0
        flagFirstArr = True
      Else
        arrLB = LBound(numbListMem())
        arrUB = UBound(numbListMem())
        arrInd = arrUB + 1
    End If
    ReDim Preserve numbListMem(arrInd) As Double    ' переопределили размер массива
    numbListMem(arrInd) = numbMem   ' сохранили число
    flagNext = True                 ' флаг: набор следующего числа
    If numbMem <> 0 Then
        cmdMC.Enabled = True
        cmdMR.Enabled = True
    End If
    cmdMemShow.Visible = True
    txbNumber.SetFocus  ' установили фокус на обработчик
End Sub
 
Private Sub cmdMultiplication_Click()
    Call PreservCalc("*")   '=== процедура: подготовка к вычислениям
End Sub
 
Private Sub cmdN0_Click()
    Call PrintNumb(0)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdN1_Click()
    Call PrintNumb(1)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdN2_Click()
    Call PrintNumb(2)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdN3_Click()
    Call PrintNumb(3)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdN4_Click()
    Call PrintNumb(4)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdN5_Click()
    Call PrintNumb(5)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdN6_Click()
    Call PrintNumb(6)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdN7_Click()
    Call PrintNumb(7)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdN8_Click()
    Call PrintNumb(8)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdN9_Click()
    Call PrintNumb(9)   '=== процедура: добавление числа в строку
End Sub
 
Private Sub cmdPlus_Click()
    Call PreservCalc("+")   '=== процедура: подготовка к вычислениям
End Sub
 
Private Sub cmdPoint_Click()
    Call PrintNumb(, True)  '=== процедура: добавление числа в строку
End Sub
 
Private Sub txbNumber_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    Select Case flagKeyCode
        Case Is = 9, 40
        Case Is = 13:   If flagCalc = True Then Cancel = True
        Case Else:      If flagCalc = True Then Cancel = True
    End Select
    flagCalc = False
End Sub
 
Private Sub txbNumber_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'    MsgBox KeyCode, , "KeyDown"
    flagKeyCode = KeyCode
    flagCalc = True
    Select Case KeyCode
        Case Is = 8:    cmdBckspc_Click ' backspace
        Case Is = 9:    If cmdN5.Enabled = True Then cmdN5.SetFocus     ' tab
        Case Is = 13:   If cmdCalc.Enabled = True Then cmdCalc_Click    ' enter
        Case Is = 27    ' Esc
            Select Case Shift
                Case Is = 0:    Unload frmCalc  'nothing was pressed
                Case Is = 1:    If cmdHome.Enabled = True Then cmdHome_Click    'SHIFT was pressed.
                Case Is = 2:    'CTRL was pressed
                Case Is = 4:    'ALT was pressed.
            End Select
        Case Is = 46:   cmdDel_Click    ' delete
        Case Is = 83:   If Shift = 2 Then cmdMS_Click   ' сохранить значение
    End Select
End Sub
 
Private Sub txbNumber_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    Dim sNumb As String
    On Error Resume Next
    sNumb = CStr(Chr(KeyAscii))
    Select Case sNumb
        Case Is = ""
        Case Is = "1":  cmdN1_Click
        Case Is = "2":  cmdN2_Click
        Case Is = "3":  cmdN3_Click
        Case Is = "4":  cmdN4_Click
        Case Is = "5":  cmdN5_Click
        Case Is = "6":  cmdN6_Click
        Case Is = "7":  cmdN7_Click
        Case Is = "8":  cmdN8_Click
        Case Is = "9":  cmdN9_Click
        Case Is = "0":  cmdN0_Click
        Case Is = ",", ".": cmdPoint_Click
        Case Is = "+":  cmdPlus_Click
        Case Is = "-":  cmdMinus_Click
        Case Is = "*":  cmdMultiplication_Click
        Case Is = "/":  cmdDivision_Click
    End Select
End Sub
 
Private Sub txbNumber_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode <> 9 Then txbNumber.SetFocus ' установили фокус на обработчик
End Sub
 
Private Sub UserForm_Initialize()
    Dim sNumb As String
    
    ' инициация "общих" переменных
    flagDoing = ""          ' флаг: тип вычислений (/*-+)
    flagFirstArr = False    ' флаг: осуществлена запись в массив
    flagExt = False         ' флаг: передача данных и закрытие формы
    flagCalc = False       ' флаг: нажатия клавиша
    flagNext = False        ' флаг: факт совершения вычислений
    numbForCalc = 0     ' вычисляемое значение
    numbMem = 0         ' "память" для числа
    
    ' подготовка формы
    txbNumber.TabKeyBehavior = True ' отключили перевод вокуса по нажатии "Tab"
    If IsEmpty(objAscker) = False And (objAscker Is Nothing) = False Then
        sNumb = Replace(objAscker.value, ",", ".")
        sNumb = Replace(CStr(Val(sNumb)), ".", ",")
        txbNumber.value = sNumb
        cmdHome.Enabled = True
    End If
    txbNumber.SetFocus  ' установили фокус на обработчик
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If flagExt = False And cmdHome.Enabled Then
        Dim usrAsver As Integer
        usrAsver = MsgBox("Вы действительно хотите закрыть калькулятор без сохранения вычислений?" _
                        , vbYesNo + vbDefaultButton2 + vbInformation _
                        , "Калькулятор: Выключение.")
        If usrAsver = vbNo Then Cancel = True
    End If
    txbNumber.SetFocus  ' установили фокус на обработчик
End Sub
 
Private Sub UserForm_Terminate()
    Set objAscker = Nothing         ' освобождаем переменую - адрес возврата результатов
    ReDim numbListMem(0) As Double  ' очищаем массив сохраненных данных и освобождаем память
End Sub
 
 
 
 
 
'########## _____ Процедуры _____ ##########
 
Private Sub PreservCalc( _
        ByVal sFlag As String _
        )              '=== процедура: подготовка к вычислениям
    numbForCalc = CDbl(Val(Replace(txbNumber.value, ",", "."))) ' сохраняем число для вычислений
    flagDoing = sFlag       ' флаг: тип вычислений (/*-+)
    flagNext = True         ' флаг: набор следующего числа
    cmdCalc.Enabled = True
    txbNumber.SetFocus  ' установили фокус на обработчик
End Sub
 
Private Sub PrintNumb( _
        Optional ByRef sNumbAdd As String = "", _
        Optional ByRef blPoint As Boolean = False _
        )                   '=== процедура: добавление символа в строку
    Dim nLen As Byte            ' длинна числа
    Dim sNumbLast As String     ' строковыое представление набранного числа
    Dim sNumbPrint As String
    
    If flagNext = False Then
        sNumbLast = txbNumber.value
        nLen = Len(sNumbLast)
        If nLen >= numbRazriad Then GoTo ExitSub
        If sNumbLast = "0" Then GoTo startNumb
        sNumbPrint = sNumbLast & sNumbAdd
        If blPoint = True _
            And InStr(1, sNumbPrint, ",", vbTextCompare) = 0 _
            Then sNumbPrint = sNumbPrint & ","
    Else
startNumb:
        sNumbPrint = sNumbAdd
        If blPoint = True Then sNumbPrint = "0," & sNumbPrint
        flagNext = False    ' флаг: факт совершения вычислений
    End If
    txbNumber.value = sNumbPrint
ExitSub:
    txbNumber.SetFocus  ' установили фокус на обработчик
End Sub

Private Sub lstCalcMem_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    sRezult = lstCalcMem.List(lstCalcMem.ListIndex)
    sLen = Len(sRezult)
    pointPosition = InStr(1, sRezult, ",", vbTextCompare)
    If pointPosition > 0 Then
        If dblRezult < 1 Then sFormat = "0." Else sFormat = String(pointPosition - 1, "#") & "."
        sFormat = sFormat & String(numbRazriad - pointPosition, "#")
        sRezult = Replace(Format(sRezult, sFormat), ".", ",")
    End If
    frmCalc.txbNumber.value = sRezult
    Unload frmCalcMem   ' закрываем форму
End Sub
Private Sub UserForm_Initialize()
    Dim arrLB, arrUB, arrInd As Integer ' индексы массива
    Dim i As Byte
    arrLB = LBound(numbListMem())
    arrUB = UBound(numbListMem())
    For arrInd = arrUB To arrLB Step -1
        If numbListMem(arrInd) <> 0 Then
            lstCalcMem.AddItem Replace(CStr(numbListMem(arrInd)), ".", ",")
            i = i + 1
            If i >= 100 Then Exit For
        End If
    Next arrInd
    frmCalcMem.Caption = "Последние " & i & " сохраненных значений."
End Sub

Sub TestShowDialog()
    Dim ldDocument As Document
    Dim lcFolder As String
    Dim lcFileName As String
    Dim lcFullName As String
    Dim Prn As PHOTOPAINT.Printer
    Dim nCopies As Long
    Dim bFirst As Boolean
    
    lcFolder = "d:\Raspechatka\Макеты\Буклеты\"
    lcFileName$ = Dir(lcFolder & "*.tif")
    bFirst = True
    
    While lcFileName$ <> ""
        lcFullName = lcFolder & lcFileName
        Set ldDocument = PHOTOPAINT.OpenDocument(lcFullName)
        
        With ldDocument
            With .PrintSettings
                If bFirst Then
                    If Not .ShowDialog Then Exit Sub
                    Set Prn = .Printer
                    nCopies = .Copies
                    bFirst = False
                Else
                    Set .Printer = Prn
                    .Copies = nCopies
                End If
            End With
            
            .PrintOut
            
            Debug.Print .PrintSettings.Copies
            
            .Close
        End With
        
        lcFileName$ = Dir()
    Wend
End Sub