MyTetra Share
Делитесь знаниями!
StatusBar
27.03.2020
16:12
Текстовые метки: VBA_Acces, StatusBar
Раздел: !Закладки - VBA - Access

'\\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



Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования