|
| | | |
 • II.2. VBA - Okna formularzy [1] •
- 2.1 Jak pobrać uchwyt aktywnego okna na formularzu ?
- 2.2 Jak pobrać uchwyty sekcji formularza ?
- 2.3 Jak pobrać uchwyt formantu TextBox lub ComboBox (mającego fokus), podczas zdarzenia OnLoad formularza lub OnEnter formantu ?
- 2.4 Jak rozpoznać, czy kliknięto strzałkę formantu ComboBox ?
- 2.5 Jak ustawić formularz w/m wolnej dostępnej przestrzeni w oknie Accessa ?
- 2.6 Jak zmienić wartość aktywnego formantu bez natychmiastowego wywoływania zdarzeń txtTest_BeforeUpdate i txtTest_AfterUpdate ?
- 2.7 Jak sprawdzić, czy formularz został otwarty poprzez kliknięcie w oknie bazy ?
- 2.8 Jak sprawdzić czy formularz jest podformularzem ?
- 2.9 Jak otworzyć formularz PopUp i ustawić go w/m przycisku otwierającego ?
- <<• idź do str. 2 •>>
| | | | |
 |
| | |
|
2.1 Jak pobrać uchwyt okna mającego fokus i znajdującego się na formularzu ?
' Teoretycznie mozemy zadeklarować jedną funkcję API i korzystać z jej dobrodziejstw ;-)
Private Declare Function GetFocus Lib "user32" () As Long
' przykładowe wywołanie:
Private Sub btnTest0_Click()
Dim hBtn As Long, hTxt As Long
' fokus ma przycisk Me.btnTest (został kliknięty)
hBtn = GetFocus
' ustaw fokus na polu tekstowym
Me.Text0.SetFocus
hTxt = GetFocus
' zobaczmy jakie uzyskaliśmy uchwyty
MsgBox "hBtn= " & hBtn & vbNewLine & _
"hTxt= " & hTxt & vbNewLine & _
"hFrm = " & Me.hwnd
' jak widzimy uchwyt przycisku hBtn jest taki sam jak uchwyt formularza - Me.hwnd. Czyli w tym przypadku coś jest nie tak ?
End Sub
' spróbujmy zabezpieczyć się przed powyższym błędem
Private Sub btnTest1_Click()
Dim hBtn As Long, hTxt As Long
hBtn = zbGetHwnd(Me.btnTest1)
hTxt = zbGetHwnd(Me.Text0)
' zobaczmy jakie uzyskaliśmy uchwyty
MsgBox "hBtn= " & IIf(hBtn = 0, "Error", hBtn) & vbNewLine & _
"hTxt= " & IIf(hTxt = 0, "Error", hTxt) & vbNewLine & _
"hFrm = " & Me.hwnd
' jak widzimy teoretycznie wszystko w zbGetHwnd jest OK. Przestrzegam jednak przed bezkrytycznym stosowaniem zbGetHwnd(...), ponieważ funkcja ta może zwrócić uchwyt zupełnie innego okna, niż by to wynikało z kodu procedury !
End Sub
' zwraca uchwyt formantu formularza, przy błędzie zwraca 0
Private Function zbGetHwnd(ctl As Control) As Long
Dim hWind As Long
If ctl.Enabled = False Then Exit Function
ctl.SetFocus
hWind = GetFocus
' porównajmy uzyskany uchwyt hWind z uchwytem formularza, gdyż dla większości kontrolek funkcja GetFocus zwraca uchwyt formularza
If hWind = Me.hwnd Then hWind = 0
zbGetHwnd = hWind
End Function
ΔΔΔ | | | | |
|
|
| | |
|
| 2.2 Jak pobrać uchwyty sekcji formularza ?
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
' w tablicy ByRef arrRet() zwraca uchwyty sekcji formularza
' acDetail = 0; acHeader = 1; acFooter = 2
Private Sub zbHwndSections(frm As Form, arrRet() As Long)
' uchwyt sekcji Header
arrRet(1) = FindWindowEx(frm.hwnd, 0&, _
"OFormSub", vbNullString)
' uchwyt sekcji Detail
If arrRet(1) > 0 Then
arrRet(0) = FindWindowEx(frm.hwnd, arrRet(1), _
"OFormSub", vbNullString)
End If
' uchwyt sekcji Footer
If arrRet(0) > 0 Then
arrRet(2) = FindWindowEx(frm.hwnd, arrRet(0), _
"OFormSub", vbNullString)
End If
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim arrHwind(0 To 2) As Long
Call zbHwndSections(Me, arrHwind())
MsgBox "Uchwyty sekcji:" & vbNewLine & vbNewLine & _
"1. Nagłówek: " & arrHwind(1) & vbNewLine & _
"2. Szczegóły: " & arrHwind(0) & vbNewLine & _
"3. Stopka: " & arrHwind(2)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.3 Jak pobrać uchwyt formantu TextBox lub ComboBox (mającego fokus), podczas zdarzenia OnLoad formularza lub OnEnter formantu ?
Private Declare Function GetFocus Lib "user32" () As Long
' formant TextBox lub ComboBox musi być on włączony (ctl.Enabled = True) i uzyskać fokus poprzez ctl.SetFokus.
' Teoretycznie, funkcja GetFocus powinna zwrócić nam w zdarzeniu Form_Load lub w zdarzeniu On_Enter przykładowego formantu prawidłowy uchwyt:
Private Sub Form_Load()
Dim hOKttbx As Long
Me.txtTest.SetFocus
hOKttbx = GetFocus
' w celach testowych
Me.Caption = "Test1_OnLoad | hOKttbx = " & _
hOKttbx & " | Me.hwnd = " & Me.hwnd
End Sub
Private Sub txtTest_Enter()
Dim hOKttbx As Long
hOKttbx = GetFocus
' w celach testowych
Me.Caption = "Test1_OnEnter | hOKttbx = " & _
hOKttbx & " | Me.hwnd = " & Me.hwnd
End Sub
' Niestety, ani w Form_Load, ani w txtTest_Enter (przy pierwszym wejściu zachodzącym podczas ładowania formularza) nie uzyskamy prawidłowego uchwytu ! Będzie to uchwyt okna mającego fokus bezpośrednio przed otwarciem formularza.
' Jeżeli będziemy próbować pobierać uchwyt okna każdorazowo w zdarzeniu On_Enter kontrolki to także nie mamy 100% pewności że uzyskamy prawidłowy uchwyt! Jeżeli nawigacja odbywa się za pomocą klawisza {TAB} lub {F6} (pomiędzy sekcjami) to w On_Enter uzyskamy prawidłowy uchwyt. W przypadku kliknięcia na formant, w zdarzeniu On_Enter uzyskamy uchwyt formularza, a dopiero w zdarzeniu On_Click uzyskamy prawidłowy uchwyt.
' Spróbujmy inaczej:
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 hOKttbx As Long
' przeszukuje wszystkie sekcje formularza w poszukiwaniu okna klasy OKttbx, zwraca uchwyt formantu TextBox lub ComboBox mającego fokus, przy niepowodzeniu zwraca 0.
Private Function zbGetOKttbx(ctl As Control) As Long
Dim arrHwind(0 To 2) As Long
Dim hTmp As Long
Dim i As Integer
If ctl.Enabled = False Then Exit Function
If (TypeOf ctl Is TextBox) = True Or _
(TypeOf ctl Is ComboBox) = True Then
Call zbHwndSections(Me, arrHwind())
' szukaj okna klasy OKttbx
For i = 0 To 2
hTmp = FindWindowEx(arrHwind(i), 0&, _
"OKttbx", vbNullString)
If hTmp > 0 Then
zbGetOKttbx = hTmp
Exit Function
End If
Next
End If
End Function
Private Sub Form_Load()
' ustaw fokus na formancie, uchwyt zostanie odczytany w zdarzeniu OnEnter
Me.txtTest.SetFocus
' jeżeli uchwyt nie został pobrany w zdarzeniu OnEnter, to odczytaj uchwyt
If hOKttbx = 0 Then
hOKttbx = zbGetOKttbx(Me.txtTest)
Me.Caption = "Form_Load | hOKttbx = " & _
hOKttbx & " | Me.hwnd = " & Me.hwnd
End If
End Sub
Private Sub txtTest_Enter()
If hOKttbx = 0 Then hOKttbx = zbGetOKttbx(Me.txtTest)
Me.Caption = "OnEnter | hOKttbx = " & _
hOKttbx & " | Me.hwnd = " & Me.hwnd
End Sub
Private Sub txtTest_Exit(Cancel As Integer)
Me.Caption = " "
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.4 Jak rozpoznać, czy kliknięto strzałkę formantu ComboBox ?
' po kliknięciu na strzałke ComboBox'a lista nie rozwija się,
' ale niestety nie jest widoczny efekt 3D strzałki. Jest ona "martwa".
' A w jakim celu - patrz: Jak zrobić kombi bez listy rozwijajnej, czyli ListRows=0 ?
Private Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" _
(lpPoint As POINTAPI) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub cboTest_MouseDown(Button As Integer, _
Shift As Integer, _
X As Single, Y As Single)
Dim papi As POINTAPI
Dim hCbo As Long
GetCursorPos papi
hCbo = WindowFromPoint(papi.X, papi.Y)
With Me.cboTest
If hCbo = Me.hwnd Then
DoCmd.CancelEvent
.Value = "Kliknięto strzałkę"
.ForeColor = vbBlue
.SelStart = 0
Else
.Value = "Kliknięto pole tekstowe"
.ForeColor = vbRed
.Dropdown
End If
End With
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.5 Jak ustawić formularz w/m wolnej dostępnej przestrzeni w oknie Accessa ?
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 GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const SM_CXVSCROLL = 2&
Private Const SM_CYHSCROLL = 3&
Private Const SM_CXEDGE = 45&
Private Const SM_CYEDGE = 46&
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 Const MY_CLASS_MDI As String = "MDIClient"
' Ustawia formularz w oknie MDI Accessa, zostawiając z lewej strony i na górze określony procent dostępnej wolnej przestrzeni okna MDI Acessa. Działa także dla okna Accessa, które nie jest zmaksymalizowane.
Public Sub zbCenterForm( _
hWind As Long, _
lWidthInPix As Long, _
lHeightInPix As Long, _
bPercentFreeAreaLeft As Byte, _
bPercentFreeAreaTop As Byte)
Dim rct As RECT
Dim hMdi As Long
Dim lMdiW As Long
Dim lMdiH As Long
Dim lSM As Long
Dim lStyle As Long
hMdi = FindWindowEx(Application.hWndAccessApp, _
ByVal 0&, MY_CLASS_MDI, vbNullString)
' pobierz wymiary okna MDI
GetWindowRect hMdi, rct
lMdiW = (rct.Right - rct.Left)
lMdiH = (rct.Bottom - rct.Top)
' pobierz styl okna
lStyle = GetWindowLong(hMdi, GWL_STYLE)
' oblicz dostępną szerokość
If bPercentFreeAreaLeft = 0 Then
lMdiW = 0
Else
' Tylko 100%
If bPercentFreeAreaLeft > 100 Then
bPercentFreeAreaLeft = 100
End If
' pobierz poprawke na szerokość scrollbara
' i szerokość obramowania okna
If ((lStyle And WS_VSCROLL) = WS_VSCROLL) Then
' widoczny pionowy scrollbar
lSM = GetSystemMetrics(SM_CXVSCROLL) + _
GetSystemMetrics(SM_CXEDGE) * 2
Else
lSM = GetSystemMetrics(SM_CXEDGE) * 2
End If
lMdiW = (lMdiW - lSM - lWidthInPix) * _
(bPercentFreeAreaLeft / 100)
End If
' formularz jest za szeroki
If lWidthInPix >= (rct.Right - rct.Left) - lSM Then
lMdiW = 0
End If
' oblicz dostępną wysokość
If bPercentFreeAreaTop = 0 Then
lMdiH = 0
Else
' Tylko 100%
If bPercentFreeAreaTop > 100 Then
bPercentFreeAreaTop = 100
End If
' pobierz poprawke na wysokość scrollbara
' i szerokość obramowania okna
If ((lStyle And WS_HSCROLL) = WS_HSCROLL) Then
lSM = GetSystemMetrics(SM_CYHSCROLL) + _
GetSystemMetrics(SM_CYEDGE) * 2
Else
lSM = GetSystemMetrics(SM_CYEDGE) * 2
End If
lMdiH = (lMdiH - lSM - lHeightInPix) * _
(bPercentFreeAreaTop / 100)
End If
' formularz jest za wysoki
If lHeightInPix >= (rct.Bottom - rct.Top) - lSM Then lMdiH = 0
' przesuń formularz
MoveWindow hWind, lMdiW, _
lMdiH, lWidthInPix, lHeightInPix, True
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Call zbCenterForm (Me.hwnd, 300, 200, 20, 20)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.6 Jak zmienić wartość aktywnego formantu bez natychmiastowego wywływania zdarzeń txtTest_BeforeUpdate i txtTest_AfterUpdate ?
Private Declare Function GetFocus Lib "user32" () 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_SETTEXT = &HC
Private Sub btnTest_Click()
Dim sNewValue As String
sNewValue = "Ala ma Asa"
Me.txtTest.SetFocus
' najprościej to przypisać bezpośrednio,
' Me.txtTest.Text = "Moja wartość"
' ale taki typowy sposób niestety od razu wywołuje zdarzenia BeforeUpdate i AfterUpdate
' jeżeli tekst aktywnego okna zmienimy w poniższy sposób:
SendMessage GetFocus, WM_SETTEXT, _
ByVal 0&, ByVal sNewValue
' to w/w zdarzenia wystąpią w naturalny sposób
End Sub
Private Sub txtTest_AfterUpdate()
MsgBox "txtTest_AfterUpdate"
End Sub
Private Sub txtTest_BeforeUpdate(Cancel As Integer)
MsgBox "txtTest_BeforeUpdate"
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.7 Jak sprawdzić, czy formularz został otwarty poprzez kliknięcie w oknie bazy ?
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
' zadziała prawidłowo jedynie wtedy, gdy podczas ładowania formularza aktywnym oknem jest (staje się) okno Bazy
Private Sub Form_Load()
If zbGetClassName(GetParent(GetFocus)) = "ODb" Then
MsgBox "Podczas otwarcia formularza aktywne było okno bazy"
End If
End Sub
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
ΔΔΔ | | | | |
|
|
| | |
|
2.8 Jak sprawdzić czy formularz jest podformularzem ?
<cyt>
Public Function kpIsSubForm(frm As Access.Form) As Boolean
Dim f As Access.Form
For Each f In Forms
If f.hwnd = frm.hwnd Then
kpIsSubForm = True
Exit For
End If
Next
kpIsSubForm = Not kpIsSubForm
End Function
</cyt>
ΔΔΔ | | | | |
|
|
| | |
|
2.9 Jak otworzyć formularz PopUp i ustawić go w/m przycisku otwierającego ?
<cyt>
Mam podformularz ciągły, na którym obok każdego rekordu znajduje się przycisk otwierający inny (modalny) formularzyk.
Otwierany w ten sposób formularzyk chciałbym przykleić do przycisku, który go otwiera ......
</cyt>
' Ograniczymy się do formularza PopUp (PopUp + Modal) otwieranego z podformularza, lub do formularza PopUp lub Modal, który będzie otwierany z poziomu formularza.
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 GetFocus Lib "user32" () As Long
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
' utwórz dodatkowy (b.mały i zlewający się z tłem) formant tekstowy "txtFocus" obok przycisku "btnTest", który otwiera formularz frmPopUp
Private Sub Form_Load()
Me.txtFocus.Width = 0: Me.txtFocus.Height = 0
Me.txtFocus.Left = Me.btnTest.Left
Me.txtFocus.Top = Me.btnTest.Top + Me.btnTest.Height
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
zbPosFrmPopUp "frmPopUp", Me.txtFocus, Me.btnTest
End Sub
' • sFrmPopUpName - nazwa formularza otwieranego,
' • ctlPos - dodatkowy formant pozycjonujący (txtFocus),
' • ctlButton - przycisk otwierający formularz PopUp => powrót fokusu na przycisk,
Public Sub zbPosFrmPopUp( _
sFrmPopUpName As String, _
ctlPos As Access.TextBox, _
Optional ctlButton As Access.CommandButton)
Dim hOkttbx As Long
Dim hModal As Long
Dim rctMDI As RECT
Dim rctModal As RECT
Dim rctOkttbx As RECT
Dim frmPopUp As Access.Form
GetWindowRect GetParent(ctlPos.Parent.hwnd), rctMDI
ctlPos.SetFocus
hOkttbx = GetFocus
GetWindowRect hOkttbx, rctOkttbx
' przywróć fokus przyciskowi (opcjonalny arg.)
If Not (ctlButton Is Nothing) Then ctlButton.SetFocus
DoCmd.OpenForm sFrmPopUpName, , , , , acHidden
Set frmPopUp = Forms(sFrmPopUpName)
With frmPopUp
hModal = .hwnd
GetWindowRect hModal, rctModal
If .PopUp Then
MoveWindow hModal, _
(rctOkttbx.Left - 0), _
rctOkttbx.Top - 0, _
rctModal.Right - rctModal.Left, _
rctModal.Bottom - rctModal.Top, True
Else
' nie zadziała dla otwieranego formularza Modal
' z poziomu podformularza
If kpIsSubForm(Me) = True Then
MsgBox "Podformularz obsługuje tylko PopUp'y"
Else
MoveWindow hModal, _
(rctOkttbx.Left - rctMDI.Left), _
rctOkttbx.Top - rctMDI.Top, _
rctModal.Right - rctModal.Left, _
rctModal.Bottom - rctModal.Top, True
End If
End If
.Visible = True
End With
Set frmPopUp = Nothing
End Sub
ΔΔΔ | | | | |
|
| |
