VBA, MS Access MS Access в примерах

Текстовое Поле (TextBox) - Отображение информации (отчёта) о проделанной работе

Часто приходиться проделывать "длинные" оперециии с даннымми:
    - Сначала импортировать (подключать)
    - Потом, обрабатывать и модифицировать
    - Затем импортировать с согласованием ...
    - и т.д.
(Бывало на 7 - 14 минут ...)
Вот для информативности, и что бы клиент понимал что происходит, пишу ЭТУ статью.
Осталось только между:

    NewStringToTextBox Me!txtReport, "Приступаю к работе ..."    'Первая строка

... написать промедуточные процедуры с отчётом ...

Пример использования (пишем в Me!txtReport):

Private Sub cmd01_Click()
Dim i As Integer
    
'Отменяем автокоррекцию данных в поле отчёта
    Me!txtReport.AllowAutoCorrect = False
    
    NewStringToTextBox Me!txtReport, "Приступаю к работе ...", True 'Первая строка
    NewStringToTextBox Me!txtReport, "01. Делаю раз ... "           'Вторая строка (с новой строки)
    NewStringToTextBox Me!txtReport, " - Готово!", True
    NewStringToTextBox Me!txtReport, "02. Делаю два ... "
    NewStringToTextBox Me!txtReport, " - Готово!", True
    NewStringToTextBox Me!txtReport, "03. Делаю три: "    
'Начало "Псевдо ProgressBar-a" (с новой строки)
    NewStringToTextBox Me!txtReport, "|"
    
'Продолжение "Псевдо ProgressBar-a" (100 "палок")
    For i = 1 To 100
        'Некие действия ....
        NewStringToTextBox Me!txtReport, "|", True
    Next i
    
    NewStringToTextBox Me!txtReport, "Готово!"
    NewStringToTextBox Me!txtReport, "--------------------------------------"
    NewStringToTextBox Me!txtReport, "Работу завершил."

'Перевод фокуса на кнопку выхода
    Me!cmdClose.SetFocus
End Sub


Напишет ЭТО:

Picture



Собственно процедура:

Public Sub NewStringToTextBox(objTextBox As TextBox, strText As Variant, _
                            Optional bNoNewString As Boolean = False)
'es - 10.03.2013 LE 18.03.2020 v003
'Вывод строк в мультистрочный TextBox
'--------------------------------------------------------------------
'Аргументы:
'   objTextBox      : TextBox
'   strText         : Добавляемый Текст
'   bNoNewString    : Текст НЕ должен быть с новой строки
'--------------------------------------------------------------------
Dim strTemp As String
Dim strAll As String
Dim i As Integer
'--------------------------------------------------------------------
On Error GoTo NewStringToTextBoxErr
    
    objTextBox.Parent.Form.Painting = False 'Отмена прорисовки формы
    
    If objTextBox.Parent.Form.ActiveControl.Name <> objTextBox.Name Then
        objTextBox.SetFocus
    End If


    If bNoNewString = True Then
        strTemp = strText
    Else
        strTemp = vbCrLf & strText
    End If
    
    strAll = objTextBox.Value & strTemp
    i = Len(strAll)

    
    objTextBox.Value = strAll
    objTextBox.SelStart = i
    objTextBox.SelLength = 0


    If i > 32400 Then ' MAX  Длина приблю = 32775
        MsgBox "Слишком много данных для отображения в окне отчёта!" & vbCrLf _
            & "Текст отчёта будет сокращён до предыдущего состояния.", _
            vbExclamation, "Слишком много данных!"
        'Обрезаем до 20 000  символов сразу!
        objTextBox.Value = Mid(objTextBox.Value, 1, 20000) & vbCrLf & "... - Данные удалены ..."
    End If
    
NewStringToTextBoxBye:
    Err.Clear
    objTextBox.Parent.Form = True '+ прорисовка формы ON
    Exit Sub

NewStringToTextBoxErr:
    If Err.Number = 6 Then 'OverFlow! (Не поместилось ...)
        'Debug.Print "Длина = " & Len(Me!txtReport)
        MsgBox "Слишком много данных для отображения в окне отчёта!" & vbCrLf _
            & "Текст отчёта будет сокращён до предыдущего состояния.", _
            vbExclamation, "Слишком много данных!"
        strAll = Mid(objTextBox.Value, 1, 20000) & vbCrLf & "... - Данные удалены ..."
        objTextBox.Value = strAll
        'Me!txtReport = strReport 'то что запоминали раньше
    Else
        MsgBox "Error " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
        "in procedure NewStringToTextBox", vbCritical, "Error!"
    End If
    
    Resume NewStringToTextBoxBye

End Sub



Назад ToTop
L.E. 18.03.2020
Рейтинг@Mail.ru