'\\StatusBar - Отображение ProgressBar

'StatusBar - Отображение ProgressBar

'http://msa.polarcom.ru/st/s0000265.htm

Private Sub PGInStatusBarTest()

'Очистка

    SysCmd acSysCmdClearStatus

'Задание заголовка и масштаба (100 ед. = 100%)

    SysCmd acSysCmdInitMeter, "Фунциклирую ...", 100

'Установка "бегунка" на 20 %

    SysCmd acSysCmdUpdateMeter, 1

    '... некие действия ...

    SysCmd acSysCmdUpdateMeter, 20

    '... некие действия ...

 

'Установка "бегунка" на 40 % и т.д.

    SysCmd acSysCmdUpdateMeter, 40

    '... некие действия ...

    

    SysCmd acSysCmdUpdateMeter, 60

    '... некие действия ...

   

    SysCmd acSysCmdUpdateMeter, 80

    '... некие действия ...

   

    SysCmd acSysCmdUpdateMeter, 100

 

    MsgBox "Готово!", vbInformation, "Progress Bar in Status Bar ..."

 

'Очистка

    SysCmd acSysCmdClearStatus

 

End Sub

 

'\\StatusBar - Отображение Информации (текста)

Sub StatusBarTxt()

'Отображение инфы в Status Bar

    SysCmd acSysCmdSetStatus, "Обрабатываю Запрос ..."

'Очистка

    SysCmd acSysCmdClearStatus

End Sub

 

 

'\\StatusBar - скрыть или отобразить

Sub StatusBarHide()

'StatusBar - скрыть или отобразить

Dim str As String

On Error Resume Next

 

    str = CurrentDb.Name

    str = Right(str, 3) 'берём 5 символов из имени файла справа (рассширение)

 

    If str = "mdb" Then  'Работает Пользователь

        Application.SetOption "Show Status Bar", False    'Скрыть статус БАР

    Else   'Работает разработчик

        Application.SetOption "Show Status Bar", True     'Показать статус БАР

    End If

 

 

'Просто показать (если был скрыт)

'Печатаем в Immediate окне (Ctrl+G) строку:

Application.SetOption "Show Status Bar", True

'... и нажимем ENTER - StatusBar появится.

End Sub

 

'\\Запретить или разрешить прорисовку окна приложения

'''Системные предупреждения - Отключить | Включить

''DoCmd.SetWarnings False

'''...

''DoCmd.SetWarnings True ' ... и включили обратно на случай если понадобятся.

 

'Окно MS Access - Запретить или разрешить прорисовку окна приложения

'По материалам: https://msdn.microsoft.com/en-us/library/office/ff834500.aspx

Public Sub EchoOff1()

 ' Open the Employees form minimized.

    Application.Echo False

    DoCmd.Hourglass True

    DoCmd.OpenForm "Form1", acNormal

    DoCmd.Minimize

    Application.Echo True

    DoCmd.Hourglass False

 

End Sub

 

'Или так:

Public Sub EchoOff2()

' Остановка обновления экрана приложения с  сообщением в StatusBar

    Application.Echo False, "Подождите пожалуйста - я делаю  ..."

    ' длинные процедуры ...

    ' ещё длинные процедуры ...

    Application.Echo True

End Sub

 

'\\Иконка и Заголовок Приложения

'Иконка и Заголовок Приложения

Private Sub Test_App_Icon_and_Title()

Dim str As String

Dim i As Integer

On Error Resume Next

'Путь к файлу иконки

    str = CurrentProject.Path & "\Application.ico"

 

'Установка иконки

    AddAppProperty "AppIcon", dbText, str

    Application.RefreshTitleBar

    Err.Clear

'Установка названия приложения

'    str = "Пример НАЗВАНИЕ"

    str = "MS Access Кирпичики"

    i = AddAppProperty("AppTitle", dbText, str)

    Application.RefreshTitleBar

End Sub

 

 

Private Function AddAppProperty(strName As String, vType As Variant, val As Variant) As Integer

'Вспомогательная функция "AddAppProperty" изменяет - добавляет свойства БД

Dim dbs As Database, prp As Property

Const conPropNotFoundError = 3270

'--------------------------------------------------------------------

On Error GoTo AddAppPropertyErr

    Set dbs = CurrentDb

    dbs.Properties(strName) = val

    AddAppProperty = True

 

AddAppPropertyBye:

    Exit Function

 

AddAppPropertyErr:

    If Err.Number = conPropNotFoundError Then

        Set prp = dbs.CreateProperty(strName, vType, val)

        dbs.Properties.Append prp

    Else

        AddAppProperty = False

        MsgBox Err

    End If

    Err.Clear

    Resume AddAppPropertyBye

End Function