|
| | | |
 • II.1. VBA - Okna MS Access [1] •
- 1.1 Jak pobrać uchwyty, klasę, tytuł oraz ID wszystkich okien MS Access ?
- 1.2 Jak pokazać (ukryć) okno bazy danych przy pomocy API ?
- 1.3 Jak zdezaktwować okno bazy danych ?
- 1.4 Jak sprawdzić, czy okno bazy danych jest widoczne ?
- 1.5 Jak zdezaktywować (ukryć) menu systemowe oraz przyciski Min, Max oraz X ?
- 1.6 Jak zdezaktywować przycisk X na pasku tytułowym okna MS Access ?
- 1.7 Jak uruchomić wbudowany pasek postępu MS Access ?
- 1.8 Jak powiększyć wbudowany wskaźnik postępu MS Access ?
- 1.9 Jak zmienić kolor tła aplikacji Access ?
- <<• idź do str. 2 •>>
| | | | |
 |
| | |
|
1.1 Jak pobrać uchwyty, klasę, tytuł oraz ID wszystkich okien MS Access ?
Private Declare Function GetWindowText Lib "user32" _
Alias "GetWindowTextA" _
(ByVal hwnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_GETTEXT = &HD
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function GetDlgCtrlID Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal wCmd As Long) As Long
Private Const GW_HWNDNEXT = 2
Private Const GW_CHILD = 5
' • Tworzy listę wszystkich okien i okien potomnych (dzieci) począwszy od okna hWind.
' • korzysta z funkcji z przykładów ze strony "Praca z oknami"
' • Funkcja wywoływana jest rekurencyjnie.
' • f As Byte, j As Integer - utworzono dla potrzeb prawidłowego wyświetlania danych.
Private Function zbInfoChild(hWind As Long, sSep As String, _
f As Byte, j As Integer) As String
Dim sHwnd As String * 5
Dim sClass As String * 40
Dim sTxtWnd As String * 25
Dim sID As String * 10
Dim hNext As Long
Dim lRet As Long
Dim i As Integer
Static sRet As String
If f = False Then
' drukuj nagłówek tabelki
sRet = String(94, Asc("=")) & vbNewLine
sHwnd = " hwnd"
sClass = Space(13) & "Klasa okna"
sTxtWnd = Space(7) & "Tekst okna"
sID = " ID "
sRet = sRet & "| Lp." & " |" & _
sHwnd & " |" & _
sClass & "|" & _
sTxtWnd & "|" & _
sID & " |" & vbNewLine
sRet = sRet & String(94, Asc("=")) & vbNewLine
sHwnd = hWind
sClass = zbGetClassName(hWind)
sTxtWnd = zbGetTextWind_2(hWind)
sID = zbGetIDWind(hWind)
sClass = sSep & Format(i, "00") & ". " & sClass
sRet = sRet & "| " & Format(j, "000") & " | " & _
sHwnd & "|" & _
sClass & "|" & _
sTxtWnd & "| " & _
sID & " |" & vbNewLine
End If
f = True
' pobierz uchwyt pierwszego dziecka
hNext = GetWindow(hWind, GW_CHILD)
' wykonaj dla wszystkich dzieci
Do Until hNext = 0
i = i + 1 ' pomocniczy licznik okien Child
j = j + 1 ' Lp.
sHwnd = hNext
sClass = zbGetClassName(hNext)
sTxtWnd = zbGetTextWind_2(hNext)
sID = zbGetIDWind(hNext)
sClass = sSep & Format(i, "00") & ". " & sClass
sRet = sRet & "| " & Format(j, "000") & " | " & _
sHwnd & "|" & _
sClass & "|" & _
sTxtWnd & "| " & _
sID & " |" & vbNewLine
' nie ma okna Child
If GetWindow(hNext, GW_CHILD) = 0 Then
Else
Call zbInfoChild(hNext, sSep & " ", f, j)
End If
' pobierz uchwyt następnego dziecka
hNext = GetWindow(hNext, GW_HWNDNEXT)
Loop
zbInfoChild = sRet
End Function
' zwraca tytuł (tekst) okna
Private Function zbGetTextWind_2(hWind As Long) As String
Dim sBff As String
Dim lLen As Long
Dim lRet As Long
' pobierz długość tekstu
lLen = SendMessage(hWind, WM_GETTEXTLENGTH, _
ByVal 0&, ByVal 0&) + 1&
' przygotuj buffor na tekst
sBff = String(lLen, vbNullChar)
' pobierz tytuł i zwróć długość pobranego tekstu
lRet = SendMessage(hWind, WM_GETTEXT, _
ByVal lLen, ByVal sBff)
zbGetTextWind_2 = Left$(sBff, lRet)
End Function
' zwraca nazwę klasy okna
Private Function zbGetClassName(hWind As Long) As String
Dim lRet As Long
Dim sBff As String
Const MY_SIZEBUFFER As Long = 256
sBff = String(MY_SIZEBUFFER, vbNullChar)
lRet = GetClassName(hWind, sBff, MY_SIZEBUFFER)
zbGetClassName = Left$(sBff, lRet)
End Function
' zwraca Identyfikator okna o uchwycie hWind, lub ZERO
Private Function zbGetIDWind(hWind As Long) As Long
zbGetIDWind = GetDlgCtrlID(hWind)
End Function
' przykładowe wywołanie:
Private Sub btnTest_Click()
Debug.Print zbInfoChild(Application.hWndAccessApp, "", _
False, 0); String(94, Asc("="))
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.2 Jak pokazać (ukryć) okno bazy danych przy pomocy API ?
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function BringWindowToTop Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const SW_HIDE = 0&
Private Const SW_SHOWNORMAL = 1&
Private Const MY_CLASS_DB As String = "ODb"
Private Const MY_CLASS_MDI As String = "MDIClient"
Private Sub zbShowDbAPI(fVisible As Boolean)
Dim hDB As Long
hDB = FindWindowEx(Application.hWndAccessApp, 0&, _
MY_CLASS_MDI, vbNullString)
If hDB = 0 Then Exit Sub
hDB = FindWindowEx(hDB, 0&, MY_CLASS_DB, vbNullString)
If hDB = 0 Then Exit Sub
If fVisible = True Then
Call ShowWindow(hDB, SW_SHOWNORMAL)
Call BringWindowToTop(hDB)
Else
Call ShowWindow(hDB, SW_HIDE)
End If
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.3 Jak zdeaktywować okno bazy danych ?
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function EnableWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal fEnable As Long) As Long
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const MY_CLASS_DB As String = "ODb"
Private Sub zbEnableDB(fEnable As Boolean)
Dim hDB As Long
Dim hTmp As Long
hDB = FindWindowEx(GetParent(Me.hwnd), 0&, _
MY_CLASS_DB, vbNullString)
If hDB = 0 Then Exit Sub
EnableWindow hDB, fEnable
Application.CommandBars("Database TitleBar").Enabled = fEnable
' ponieważ wywołanie np. okna MsgBox powoduje odblokowanie okna bazy, musimy zdeaktywować wszystkie potomne okna (dzieci) właściwego okna bazy, aby uczynić nasze okno bazy niedostępnym dla użytkownika
Do
hTmp = FindWindowEx(hDB, hTmp, vbNullString, vbNullString)
If hTmp = 0 Then Exit Do
EnableWindow hTmp, fEnable
Loop
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.4 Jak sprawdzić, czy okno bazy danych jest widoczne ?
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function IsWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const MY_CLASS_DB As String = "ODb"
Private Function zbIsVisibleDB() As Boolean
zbIsVisibleDB = IsWindowVisible( _
FindWindowEx(GetParent(Me.hwnd), _
0&, MY_CLASS_DB, vbNullString))
End Function
ΔΔΔ | | | | |
|
|
| | |
|
1.5 Jak zdeaktywować (ukryć) menu systemowe oraz przyciski Min, Max oraz X ?
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
Private Const WM_NCPAINT As Long = &H85
' pierwotny styl okna Access'a
Private lOldStyle As Long
' wartości parametru lBox procedury zbHideSysBox (...)
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const MY_MAXMINBOX = _
(WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Sub zbHideSysBox(lBox As Long, hWind As Long, fHide As Boolean)
Select Case lBox
Case WS_SYSMENU ' ukryj (pokaż) menu systemowe
zbRemoveSysBox lBox, hWind, fHide
Case WS_MINIMIZEBOX 'ukryj (pokaż) przycisk MIN
zbRemoveSysBox lBox, hWind, fHide
Case WS_MAXIMIZEBOX ' ukryj (pokaż) przycisk MAX
zbRemoveSysBox lBox, hWind, fHide
Case MY_MAXMINBOX ' ukryj (pokaż) przycisk MIN i MAX
zbRemoveSysBox lBox, hWind, fHide
End Select
End Sub
Private Sub zbRemoveSysBox(lBox As Long, _
ByVal hWind As Long, _
fRemove As Boolean)
Dim lNewStyle As Long
' zapamiętaj styl okna Access'a
If lOldStyle = 0 Then
lOldStyle = GetWindowLong(hWind, GWL_STYLE)
End If
If fRemove Then
lNewStyle = SetWindowLong(hWind, GWL_STYLE, _
lOldStyle And (Not lBox))
Else
lNewStyle = SetWindowLong(hWind, GWL_STYLE, _
lOldStyle Or lBox)
End If
SendMessage hWind, WM_NCPAINT, ByVal 1&, ByVal 0&
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
' ukryj (deaktywuj)
zbHideSysBox WS_SYSMENU, Application.hWndAccessApp, True
' pokaż (aktywuj)
' zbHideSysBox WS_SYSMENU, Application.hWndAccessApp, False
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.6 Jak zdeaktywować przycisk X na pasku tytułowym okna MS Access ?
• Niestety deaktywacja przycisku X nie zabezpiecza nas przed zamknięciem bazy kombinacją klawiszy Alt+F4
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, _
ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" _
(ByVal hAcc As Long) As Long
Private Declare Function EnableMenuItem Lib "user32" _
(ByVal hAcc As Long, _
ByVal wIDEnableItem As Long, _
ByVal wEnable As Long) As Long
Private Const MF_BYPOSITION = &H400
Private Const MF_DISABLED = &H2
Private Const MF_GRAYED = &H1
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_FRAMECHANGED = &H20
Private Sub zbEnableX(hWind As Long, fEnabled As Boolean)
Dim hSysMnu As Long
Dim lCountMnu As Long
Const MY_POS As Long = 1
hSysMnu = GetSystemMenu(hWind, False)
If hSysMnu <> 0 Then
lCountMnu = GetMenuItemCount(hSysMnu)
If fEnabled Then
EnableMenuItem hSysMnu, lCountMnu - MY_POS, _
MF_BYPOSITION And Not _
(MF_DISABLED Or MF_GRAYED)
Else
EnableMenuItem hSysMnu, lCountMnu - MY_POS, _
MF_BYPOSITION Or _
(MF_DISABLED Or MF_GRAYED)
End If
DrawMenuBar hSysMnu
End If
' wymuś odswieżenie okna
Call SetWindowPos(hWind, 0&, 0&, 0&, 0&, 0&, _
SWP_NOSIZE Or SWP_NOMOVE Or _
SWP_FRAMECHANGED Or SWP_NOZORDER)
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
' deaktywuj przycisk X
zbEnableX Application.hWndAccessApp, False
' ew. tylko dla formularza PopUp
' zbEnableX Me.hwnd, False
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.7 Jak uruchomić wbudowany pasek postępu MS Access ?
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private Sub zbAccProgBar(sTextStatBar As String, _
lStart As Long, lEnd As Long)
Dim fStatBarVisible As Boolean
Dim i As Long
' pobierz stan paska stanu (czy jest widoczny)
fStatBarVisible = Application.GetOption("Show Status Bar")
' pokaż pasek stanu
If Not fStatBarVisible Then
Application.SetOption ("Show Status Bar"), True
End If
' zainicjuj wskaźnik postępu
Application.SysCmd acSysCmdInitMeter, sTextStatBar, lEnd
For i = lStart + 1 To lEnd
' aktualizuj wskaźnik postępu
Application.SysCmd acSysCmdUpdateMeter, i
' opóźnij w celach poglądowych
Sleep 10&
DoEvents
Next
' usuń wskaźnik postępu
Application.SysCmd acSysCmdRemoveMeter
' przywróć początkowy stan paska stanu
Application.SetOption ("Show Status Bar"), fStatBarVisible
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Call zbAccProgBar("Standard ProgressBar", 0, 250)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.8 Jak powiększyć wbudowany wskaźnik postępu MS Access ?
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Const SW_RESTORE = 9
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
Private hStatProg As Long
Private rctStatProg As RECT
Private fStatBarVisible As Boolean
' inicjalizacja wskaźnika postępu,
' minimalna wielkość wskaźnika = 16 pix, maksymalna ~ 62 pix
Private Sub zbIniProgBar(ByVal sTitleProgBar As String, _
lMax As Long, lSizeProgBar As Long)
Dim hStaBar As Long
Dim rctTmp As RECT
Dim i As Long
Dim lWidth As Long
' pobierz stan paska stanu (czy jest widoczny)
fStatBarVisible = Application.GetOption("Show Status Bar")
' pokaż pasek stanu jeśli nie jest widoczny
If Not fStatBarVisible Then
Application.SetOption ("Show Status Bar"), True
End If
' szukaj wskaźnika postępu
hStaBar = FindWindowEx(Application.hWndAccessApp, _
ByVal 0&, "OStatbar", vbNullString)
ShowWindow hStaBar, SW_RESTORE
hStatProg = FindWindowEx(hStaBar, ByVal 0&, _
"OStatProg", vbNullString)
' pobierz wymiary wskaźnika postępu
GetWindowRect hStatProg, rctStatProg
' minimalna wysokość wskaźnika postępu = 16
If lSizeProgBar < 26 Then
If lSizeProgBar < 16 Then lSizeProgBar = 16
rctTmp = rctStatProg
lWidth = rctStatProg.Right - rctStatProg.Left
Else
'przy wielkości > 26 tekst nie będzie widoczny
sTitleProgBar = " "
' sprawdź, czy długość paska nie będzie większa
' od szerokości okna Accessa
GetWindowRect Application.hWndAccessApp, rctTmp
lWidth = rctTmp.Right - rctTmp.Left
' doświadczalne współczynniki powiększania
If 20 * (lSizeProgBar - 14) + 65 > lWidth Then
lSizeProgBar = (14 + (lWidth - 65) / 20) - 1
End If
End If
Application.SysCmd acSysCmdInitMeter, sTitleProgBar, lMax
' ustaw wielkość i położenie wskaźnika postępu
MoveWindow hStatProg, 0&, 0&, lWidth, lSizeProgBar, True
End Sub
' aktualizuj pasek postępu
Private Sub zbUpdateProgBar(lValueProgBar As Long)
Application.SysCmd acSysCmdUpdateMeter, lValueProgBar
End Sub
' usuń pasek postępu i przywróć jego oryginalne parametry
Private Sub zbRemoveProgBar()
' przywróć wielkość i położenie wskaźnika postępu
With rctStatProg
MoveWindow hStatProg, 0, 0, .Right - .Left, .Bottom - .Top, True
End With
' usuń wskaźnik postępu
Application.SysCmd acSysCmdRemoveMeter
' przywróć początkowy stan paska stanu
Application.SetOption ("Show Status Bar"), fStatBarVisible
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim i As Long
Const MY_MAX_FOR As Long = 250
Const MY_SIZE_1 As Long = 25
Const MY_SIZE_2 As Long = 62
' dowolny argument lSizeProgBar
' - w zbProgBar wartość zostanie poprawiona
Call zbIniProgBar("Pasek postępu: 25 pix", _
MY_MAX_FOR, MY_SIZE_1)
For i = 0 To MY_MAX_FOR
SysCmd acSysCmdUpdateMeter, i
' opóźnij w celach poglądowych
Sleep 10&
DoEvents
Next
Call zbRemoveProgBar
Call zbIniProgBar("Duży rozmiar - tekst będzie niewidoczny", _
MY_MAX_FOR, MY_SIZE_2)
For i = 0 To MY_MAX_FOR
Call zbUpdateProgBar(i)
' opóźnij w celach poglądowych
Sleep 10&
DoEvents
Next
Call zbRemoveProgBar
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
1.9 Jak zmienić kolor tła aplikacji Access ?
Private Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT) As Long
Private Declare Function InvalidateRect Lib "user32" _
(ByVal hwnd As Long, _
lpRect As RECT, _
ByVal bErase As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" _
(ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function SetClassLong Lib "user32" _
Alias "SetClassLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Const GCL_HBRBACKGROUND = (-10)
Private Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const COLOR_APPWORKSPACE = 12
Private Sub zbSetMDIBackColor(ByVal lBkgColor As Long)
Dim hBrushNew As Long
Dim hBrushOld As Long
Dim hMDI As Long
Dim rct As RECT
' utwórz nowy pędzel
hBrushNew = CreateSolidBrush(lBkgColor)
' pobierz uchwyt okna MDI
hMDI = GetParent(Me.hwnd)
' pobierz wymiary okna MDI
Call GetWindowRect(hMDI, rct)
rct.Top = 0: rct.Left = 0
' ustaw nowy pędzel tła dla okna MDI
hBrushOld = SetClassLong(hMDI, _
GCL_HBRBACKGROUND, hBrushNew)
' wymuś odświeżanie
Call InvalidateRect(hMDI, rct, 1&)
' usuń stary pędzel
Call DeleteObject(hBrushOld)
End Sub
Private Sub btnTest_Click()
' ustaw kolor tła aplikcji
Call zbSetMDIBackColor(vbRed)
' przywróć systemowy kolor tła aplikcji
' Call zbSetMDIBackColor(GetSysColor( _
COLOR_APPWORKSPACE))
End Sub
ΔΔΔ | | | | |
|
| |
