|
| | | |
 • II.2. VBA - Okna formularzy [2] •
- 2.10 Jak można zablokować przyciski nawigacyjne na formularzu ?
- 2.11 Mój formularz (sekcja Detale) ma kolor tła (BackColor) = -2147483633. Co to za kolor ?
- 2.12 Jak zrobić, by użytkownik mógł wpisywać tekst do formantu TextBox tylko dużymi (małymi) literami ?
- 2.13 Jak zrobić, by wpisywany tekst nie przekroczył szerokości formantu TextBox ?
- 2.14 Jak zrobić formularz bez paska tytułowego i uniemożliwić jego zamknięcie ?
- 2.15 Jak ustawić jeden formularz pod drugim i wyśrodkować (w poziomie) dolny formularz w/m górnego ?
- 2.16 Jak zablokować dostęp do formularza otwierającego drugi formularz ?
- 2.17 Jak we wszystkich formularzach w bazie dopisać w procedurze
Private Sub Form_Load() wywołanie własnej funkcji, a jeżeli takiej procedury nie ma, to jak ją utworzyć ?
- 2.18 Jak zrobić menu na formularzu ?
- 2.19 Jak sprawdzić który formularz otrzymuje fokus (staje się w danym momencie oknem aktywnym) ?
- <<• idź do str. 1 •>>
| | | | |
 |
| | |
|
2.10 Jak można zablokować przyciski nawigacyjne na formularzu ?
<cyt>
Jak można zablokować przyciski nawigacyjne ?
Chciałbym aby użytkownik widział przyciski nawigacyjne, ale nie miał
możliwości sterowania nimi ....
</cyt>
' Nie jest to pełne rozwiązanie, a raczej tylko zasygnalizowanie możliwości rozwiązania, przyciski nawigacyjne nie reagują na kliknięcie, ale nie są szare, przez co sprawiają wrażenie aktywnych,
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 hOSUI As Long
' wprowadź duże opóźnienie, ponieważ nie następuje dezaktywacja przycisków
' dla pierwszego rekordu, musi być opóźnienie po OnLoad
Private Sub Form_Load()
' brak efektu !!!
' hOSUI = FindWindowEx(Me.hwnd, ByVal 0&, _
"OSUI", vbNullString)
' EnableWindow hOSUI, False
' wprowadź duże opóźnienie i wykonaj w Timerze formularza
Me.TimerInterval = 1000
End Sub
Private Sub Form_Current()
If hOSUI = 0 Then
hOSUI = FindWindowEx(Me.hwnd, ByVal 0&, _
"OSUI", vbNullString)
End If
' ponów dezaktywacje, ponieważ przy OnCurrent następuje aktywacja okna
' z "Przyciskami nawigacyjnymi"
EnableWindow hOSUI, False
Private Sub Form_Timer()
Me.TimerInterval = 0
' znajdź okno z "Przyciskami nawigacyjnymi"
hOSUI = FindWindowEx(Me.hwnd, ByVal 0&, _
"OSUI", vbNullString)
EnableWindow hOSUI, False
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.11 Mój formularz (sekcja Detale) ma kolor tła (BackColor) = -2147483633. Co to za kolor ?
' Wartość koloru tła sekcji BackColor = -2147483633 jest domyślnie ustawiana przez Access. Aby dowiedzieć się, co znaczy ta liczba rozłóżmy ją na poszczególne bajty.
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const COLOR_BTNFACE = 15
' zwraca kolor sekcji formularza, przy błędzie zwraca -1
Private Function zbGetColorSection( _
frm As Access.Form, _
lSection As Long) As Long
Dim aRGB(0 To 3) As Byte
If lSection < 0 Or lSection > 2 Then
zbGetColorSection = -1
Exit Function
End If
' kopiuj kolor tła sekcji do tablicy bajtów
CopyMemory aRGB(0), frm.Section(acDetail).BackColor, 4
If aRGB(3) = 128 Then ' If aRGB(3) <> 0 Then
' kolor sekcji formularza określony jest jako kolor systemowy o nIndex = aRGB(0) - najprawdopodobniej aRGB(0)= COLOR_BTNFACE = 15, czyli kolor przycisku
zbGetColorSection = GetSysColor(aRGB(0))
Else
' kolor ustawiony przez użytkownika
zbGetColorSection = RGB(aRGB(0), aRGB(1), aRGB(2))
End If
End Function
Private Sub btnTest_Click()
' 0 acDetail Sekcja szczegółów formularza lub raportu
' 1 acHeader Sekcja nagłówka formularza lub raportu
' 2 acFooter Sekcja stopki formularza lub raportu
Debug.Print "Kolor sekcji = "; zbGetColorSection(Me, acDetail)
DoCmd.RunCommand acCmdDebugWindow
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.12 Jak zrobić, by użytkownik mógł wpisywać tekst do formantu TextBox tylko dużymi (małymi) literami ?
' w trakcie wpisywania tekstu (gdy formant klasy TextBox ma fokus) będziemy po prostu podmieniać przekonwertowany tekst
Private Sub txtTest_Change()
Dim lCurSel As Long
Dim sStrTmp As String
Const MY_UCASE As Boolean = True
If Len(Me.txtTest.Text) = 0 Then Exit Sub
' w zależności od opcji zamień wielkość znaków
If MY_UCASE Then
sStrTmp = UCase$(Me.txtTest.Text)
Else
sStrTmp = LCase$(Me.txtTest.Text)
End If
' jeżeli ciągi znaków są różne, to zamień
If StrComp(Me.txtTest.Text, sStrTmp, _
vbBinaryCompare) <> 0 Then
' pobierz miejsce wstawienia kursora
lCurSel = txtTest.SelStart
' zamień tekst
Me.txtTest.Text = sStrTmp
' wstaw kursor na stare miejsce
txtTest.SelStart = lCurSel
Else
Exit Sub
End If
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.13 Jak zrobić, by wpisywany tekst nie przekroczył szerokości formantu TextBox ?
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Declare Function GetCharWidth Lib "gdi32" _
Alias "GetCharWidthA" _
(ByVal hDC As Long, _
ByVal wFirstChar As Long, _
ByVal wLastChar As Long, _
lpBuffer As Long) As Long
Private Declare Function GetTextExtentPoint Lib "gdi32" _
Alias "GetTextExtentPointA" _
(ByVal hDC As Long, _
ByVal lpszString As String, _
ByVal cbString As Long, _
lpSize As SIZE) As Long
Private Type SIZE
cx As Long
cy As Long
End Type
Private hOKttbx As Long
Private lPrevSel As Long
Private sTxtOld As String
Private hDC As Long
Private snTwipToPixX As Single
' moim zdaniem poniższa funkcja jest zdecydowanie lepsza i dokładniejsza od zbGetCharWidth
Private Function zbGetTextExtentPoint( _
ByVal sStr As String) As Long
Dim typeSize As SIZE
Dim i As Long
' pobierz szerokość ciągu znaków
GetTextExtentPoint hDC, sStr, Len(sStr), typeSize
' zwróć szerokość tekstu
zbGetTextExtentPoint = typeSize.cx
End Function
Private Function zbGetCharWidth( _
ByVal sStr As String) As Long
Dim lRet As Long
Dim lBff As Long
Dim i As Integer
Dim lAsc As Long
Dim lCharPixW As Long
' sumuj szerokość kolejnych znaków w stringu
For i = 1 To Len(sStr)
lAsc = Asc(Mid$(sStr, i, 1))
lRet = GetCharWidth(hDC, lAsc, lAsc, lBff)
lCharPixW = lCharPixW + lBff
Next
zbGetCharWidth = lCharPixW
End Function
Private Sub Form_Timer()
Me.TimerInterval = 0
If hOKttbx = 0 Then
hOKttbx = GetFocus
hDC = GetDC(hOKttbx)
' pobierz przelicznik Twip na Piksel
snTwipToPixX = GetDeviceCaps(hDC, _
LOGPIXELSX) / 1440
ReleaseDC hOKttbx, hDC
End If
End Sub
' przy wejściu do formantu, w Form_Timer (<= dla uproszczenia kodu) pobierz uchwyt okna OKttbx patrz Uwagi o pobieraniu uchwytu okna OKttbx
Private Sub txtTest_Enter()
Me.TimerInterval = 40
Me.txtTest.SelStart = 0
' zapamiętaj tekst jaki jest w Me.txtTest
sTxtOld = Nz(Me.txtTest.Text, "")
End Sub
Private Sub txtTest_Change()
Dim sStrTxt As String
Dim lStringW As Long
sStrTxt = Me.txtTest.Text
' sprawdź, czy w ciągu znaków nie ma vbNewLine,
' jeśli jest wytnij vbNewLine lub cały wklejony tekst
If InStr(sStrTxt, vbNewLine) > 0 Then
MsgBox "Wielolinijkowego tekstu" & vbNewLine & _
"procedura nie obsługuje !"
' przywróć stary tekst
Me.txtTest.Text = sTxtOld
Else
lStringW = zbGetTextExtentPoint(sStrTxt)
' przytnij za długi ciąg znaków
Call zbFitString(lStringW, sStrTxt)
End If
End Sub
' zapamiętaj położenie kursora
Private Sub txtTest_KeyDown( _
KeyCode As Integer, Shift As Integer)
lPrevSel = Me.txtTest.SelStart
End Sub
Private Sub zbFitString(lWidthString As Long, sStr As String)
' własna poprawka = 3pix
If lWidthString + 3 >= _
CLng(snTwipToPixX * Me.txtTest.Width) Then
' przywróć stary tekst
Me.txtTest.Text = sTxtOld
Me.txtTest.SelStart = lPrevSel
Else
' zapamiętaj nowy tekst
sTxtOld = sStr
End If
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.14 Jak zrobić formularz bez paska tytułowego i uniemożliwić jego zamknięcie ?
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)
' WS_CAPTION - okno z paskiem tytulowym, (zawiera WS_BORDER)
Private Const WS_CAPTION = &HC00000
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 Const SWP_SHOWWINDOW = &H40
Private Const MY_FLAGS As Long = _
SWP_SHOWWINDOW Or _
SWP_FRAMECHANGED Or _
SWP_NOMOVE Or _
SWP_NOSIZE Or _
SWP_NOZORDER
Private lOldStyle As Long
Private lNewStyle As Long
Private Sub Form_Load()
' włącz podgląd klawiszy i nie pokazuj menu podręcznego
Me.KeyPreview = True
Me.ShortcutMenu = False
' pobierz aktualny styl okna
lOldStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
lNewStyle = lOldStyle And Not WS_CAPTION ' WS_SYSMENU
' ustaw nowy styl okna
SetWindowLong Me.hwnd, GWL_STYLE, lNewStyle
' wymuś odświeżenie okna
SetWindowPos Me.hwnd, 0&, 0&, 0&, 0&, 0&, MY_FLAGS
End Sub
' nie pozwól na zamknięcie formularza kombinacją klawiszy Ctrl+F4
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If Shift = acCtrlMask And KeyCode = vbKeyF4 Then
MsgBox "Nie wolno Ci zamknąć formularza " & _
Me.Name & " !"
KeyCode = 0
End If
End Sub
' przycisk przywracający stary styl formularza
Private Sub btnTest_Click
' przywróć stary styl okna
SetWindowLong Me.hwnd, GWL_STYLE, lOldStyle
' wymuś odświeżenie okna
SetWindowPos Me.hwnd, 0&, 0&, 0&, 0&, 0&, MY_FLAGS
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.15 Jak ustawić jeden formularz pod drugim i wyśrodkować (w poziomie) dolny formularz w/m górnego ?
Private Declare Function GetParent Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Private Const SM_CXBORDER = 5&
Private Const SM_CYBORDER = 6&
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
' ustawia jeden formularz pod drugim i wyśrodkowuje w poziomie dolny formularz,
' • lDistance - odstęp w pionie pomiędzy formularzami,
Public Sub zbFormBottomForm( _
sFrmTopName As String, _
sFrmBottomName As String, _
Optional lDistance As Long = 10)
On Error GoTo ErrHandler
Dim rctT As RECT
Dim rctB As RECT
Dim rctMDI As RECT
Dim lBorderX As Long
Dim lBorderY As Long
Dim frmTop As Form
Dim frmBottom As Form
On Error Resume Next
' sprawdź, czy formularze są otwarte
If Forms(sFrmTopName).hwnd = 0 Then
DoCmd.OpenForm sFrmTopName
End If
If Forms(sFrmBottomName).hwnd = 0 Then
DoCmd.OpenForm sFrmBottomName
End If
On Error GoTo 0
Set frmTop = Forms(sFrmTopName)
Set frmBottom = Forms(sFrmBottomName)
Call GetWindowRect(frmTop.hwnd, rctT)
Call GetWindowRect(frmBottom.hwnd, rctB)
Call GetWindowRect(GetParent(frmTop.hwnd), rctMDI)
lBorderX = GetSystemMetrics(SM_CXBORDER) + 1
lBorderY = GetSystemMetrics(SM_CYBORDER) + 1
With rctB
MoveWindow frmBottom.hwnd, _
rctT.Left + ((rctT.Right - rctT.Left) - _
(.Right - .Left)) / 2 - rctMDI.Left, _
rctT.Bottom + lDistance - rctMDI.Top, _
.Right - .Left, _
.Bottom - .Top, True
End With
DoEvents
Exit_Here:
On Error Resume Next
Set frmTop = Nothing
Set frmBottom = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume Exit_Here
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
DoCmd.OpenForm "frmBottom"
Call zbFormBottomForm(Me.Name, "frmBottom", 15)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.16 Jak zablokować dostęp do formularza otwierającego drugi formularz ?
grupa: pl.comp.bazy-danych.msaccess
wątek: Blokada formularza
przedstawił: Krzysztof Naworyta i Zbigniew Bratko
' Metoda I
' • otworzyć formularz "frm2" w trybie Dialog, nie mamy wtedy dostępu do żadnych elementów Accessa (menu, innych obiektów itp.) aż do chwili zamknięcia formularza "frm2".
' Dodatkowo jeżeli formularz "frm2" ma ustawione AutoCenter = True to otwiera się on w tym trybie nieco wyżej, niż przy otwarciu w trybie acWindowNormal
Private Sub btnFrmDialog_Click()
DoCmd.OpenForm "frm2", , , , , acDialog
End Sub
' Metoda II
' • otworzyć formularz "frm2" w trybie acWindowNormal i ustawić jego właściwość Modal = True, nie mamy wtedy dostępu do innych obiektów Accessa, aż do do chwili zamknięcia formularza "frm2"
Private Sub btnFrmModal_Click()
DoCmd.OpenForm "frm2"
Forms("frm2").Modal = True
End Sub
' Metoda IIa
' • Ustawić w projekcie formularza otwieranego "frm2", właściwośc Modal = True
' Metoda III
' • zdeaktywować bieżący formularz wywołując publiczną procedurę zbEnableFrm(...), a następnie otworzyć formularz "frm2" w trybie acWindowNormal, nie mamy wtedy dostępu tylko do formularza otwierającego "frm1"
Private Declare Function EnableWindow Lib "user32" _
(ByVal hwnd As Long, _
ByVal fEnable As Long) As Long
Private Sub btnEnableFrm_Click()
Call zbEnableFrm(Me.Name, False)
' w argumencie OpenArgs przekaż nazwę bieżącego formularza
DoCmd.OpenForm "frm2", , , , , , Me.Name
End Sub
' deaktywuj (aktywuj) okno formularza sFrmName
Public Sub zbEnableFrm(sFrmName As String, fEnable As Boolean)
Call EnableWindow(Forms(sFrmName).hwnd, fEnable)
End Sub
' a w formularzu otwieranym "frm2" przy zdarzeniu Form_Unload(...) musimy aktywować formularz otwierający, którego nazwę przekazaliśmy w OpenArgs
Private Sub Form_Unload(Cancel As Integer)
Forms(OpenArgs).zbEnableFrm OpenArgs, True
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.17 Jak we wszystkich formularzach w bazie dopisać w procedurze Private Sub Form_Load() wywołanie własnej funkcji, a jeżeli takiej procedury nie ma, to jak ją utworzyć ?
Private Const MY_FORM As Long = -32768
' przykładowe wywołanie:
Private Sub btnTest_Click()
Dim sDirTmp As String
Dim aFormsName() As String
Dim aFormsSaved() As String
Dim sFrmTextRet As String
Dim sCallFunction As String
Dim lInStr As Long
Dim lLB As Long
Dim lUB As Long
Dim fRet As Boolean
Dim ff As Long
Dim i As Long
Const MY_EVENT_ON_LOAD As String = _
"OnLoad =" & """" & _
"[Event Procedure]" & """" & _
vbNewLine
Const MY_BEGIN_FORM As String = _
vbNewLine & "Begin Form" & _
vbNewLine
Const MY_CODE_BEHIND_FORM As String = _
vbNewLine & "CodeBehindForm" & _
vbNewLine
Const MY_SUB_ON_LOAD_PRIVATE As String = _
vbNewLine & "Private Sub Form_Load()" & _
vbNewLine
' Const MY_SUB_ON_LOAD_PUBLIC As String = _
vbNewLine & "Public Sub Form_Load()" & _
vbNewLine
Const MY_EXT As String = ".frm"
' Zakładam, że Sub Form_Load() jest tylko funkcją typu Private.
' Co prawda można ją zadeklarować jako Public, ale jeżeli to zrobiłeś, to sam oprogramuj dopisanie nowej funkcji w procedurze Sub Form_Load()
sDirTmp = Environ$("TEMP")
fRet = zbListObjectInDB(MY_FORM, aFormsName())
If fRet = False Then Exit Sub
lLB = LBound(aFormsName)
lUB = UBound(aFormsName)
ReDim aFormsSaved(lLB To lUB)
' zapisz formularze jako pliki tekstowe
For i = lLB To lUB
aFormsSaved(i) = sDirTmp & _
"/" & aFormsName(i) & MY_EXT
Application.SaveAsText acForm, _
aFormsName(i), aFormsSaved(i)
Next
For i = lLB To lUB
If zbFileToString(aFormsSaved(i), sFrmTextRet) > 0 Then
' 1. sprawdź, czy formularz ma ustawioną obsługę zdarzenia: Private Sub Form_Load()
lInStr = InStr(1, sFrmTextRet, _
MY_EVENT_ON_LOAD, vbTextCompare)
If lInStr = 0 Then
' brak obsługi zdarzenia Form_Load, dopisz obsługę zdarzenia
sFrmTextRet = zbReplace(sFrmTextRet, _
MY_BEGIN_FORM, _
MY_BEGIN_FORM & _
MY_EVENT_ON_LOAD, , , _
vbTextCompare)
End If
' 2. sprawdź, czy formularz posiada modułu klasy
lInStr = InStr(1, sFrmTextRet, _
MY_CODE_BEHIND_FORM, vbTextCompare)
If lInStr = 0 Then
' formularz nie posiada modułu klasy, dopisz moduł
sFrmTextRet = sFrmTextRet & _
MY_CODE_BEHIND_FORM & _
"Option Compare Database" & vbNewLine & _
"Option Explicit" & vbNewLine
End If
' 3. sprawdź, czy formularz posiada funkcję obsługującą zdarzenie: Private Sub Form_Load()
lInStr = InStr(1, sFrmTextRet, _
MY_SUB_ON_LOAD_PRIVATE, vbTextCompare)
If lInStr = 0 Then
' formularz nie posiada funkcji Private Sub Form_Load()
sFrmTextRet = sFrmTextRet & _
MY_SUB_ON_LOAD_PRIVATE & _
" MsgBox zbNewFunction(" & _
"""" & "Dzisiejsza data:" & _
"""" & ")" & vbNewLine & _
"End Sub" & vbNewLine
Else
' formularz posiada funkcję Private Sub Form_Load(), dopisz bezpośrednio pod nazwą funkcji wywołanie nowej funkcji
sFrmTextRet = zbReplace(sFrmTextRet, _
MY_SUB_ON_LOAD_PRIVATE, _
MY_SUB_ON_LOAD_PRIVATE & _
" MsgBox zbNewFunction(" & _
"""" & "Dzisiejsza data:" & _
"""" & ")" & vbNewLine)
End If
' zapisz kolejno zmienione pliki formularzy
ff = FreeFile
Open aFormsSaved(i) For _
Binary Access Write As #ff
Put #ff, , sFrmTextRet
Close #ff
' wczytaj kolejno pliki formularzy za wyjątkiem bieżącego formularza
If StrComp(Me.Name, aFormsName(i), _
vbBinaryCompare) <> 0 Then
Call Application.LoadFromText(acForm, _
aFormsName(i), aFormsSaved(i))
End If
End If
Next
ff = FreeFile
Open sDirTmp & "/basNewFunction.bas" For _
Binary Access Write As #ff
sFrmTextRet = _
"Option Compare Database" & vbNewLine & _
"Option Explicit" & vbNewLine & _
"Public Function zbNewFunction" & _
"(sStr As String) As String" & vbNewLine & _
" zbNewFunction = sStr & " & "Now()" & _
vbNewLine & "End Function"
Put #ff, , sFrmTextRet
Close #ff
DoEvents
Call Application.LoadFromText( _
acModule, _
"basNewFunction", _
sDirTmp & _
"/basNewFunction.bas")
' skasuj wszystkie pliki tymczasowe
For i = LBound(aFormsSaved) To UBound(aFormsSaved)
Kill aFormsSaved(i)
DoEvents
Next
Kill sDirTmp & "/basNewFunction.bas"
DoEvents
' zakładam, że formularz aFormsName(0) istnieje
DoCmd.OpenForm aFormsName(0)
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
2.18 Jak zrobić menu na formularzu ?
• 02.01.2009 r. •
Zmiany w stosunku do wersji z 28.11.2007 r.
- Z kodu tworzącego i obsługującego menu w module formularza utworzyłem klasę clsMenu, dzięki czemu te same menu można tworzyć w wielu formularzach.
- Zmieniłem sposób ładowania bitmap menu. Obecnie ładowane są jednorazowo, a ich uchwyty przechowywane są w kolekcji uchwytów.
- Zmieniłem sposób odwoływania się do menu z odwoływania się poprzez nazwę, na odwoływanie się poprzez numer.
ΔΔΔ | | | | |
|
|
| | |
|
2.19 Jak sprawdzić który formularz otrzymuje fokus (staje się w danym momencie oknem aktywnym) ?
Metoda ta opiera sie na przechwycie komunikatu HCBT_SETFOCUS jakie wysyła okno otrzymujące fokus.
Komunikat ten generowany jest każdorazowo po zmianie fokusu dla każdego okna dziecka w każdym oknie rodzicu.
W przypadku formularza dotyczy to każdego formantu w formularzu.
Aby nie reagować na każdy komunikat HCBT_SETFOCUS, w procedurze sprawdzany jest uchwyt poprzednio aktywnego formularza z uchwytem aktualnie aktywnego formularza.
Jeżeli uchwyty są różne, świadczy to, że fokus otrzymał inny formularz i możemy (powinniśmy) coś wykonać.
Aż prosi się, aby skorzystać z przechwytu komunikatu HCBT_ACTIVATE, który generowany jest podczas aktywacji okna,
ale niestety to mi się udało tylko dla okien formularzy które mają ustawioną własciwość PopUp = TRUE
UWAGA ! Ze względu na użycie operatora AddressOf do przechwytu komunikatów, próba debugowania kodu po wywołaniu funkcji Sub HookWindow(), kończy się natychmiastowym zamknięciem Accessa (lub jego zawieszeniem). Aby przeglądać kod należy (z wcześniej opisanego powodu)wywołać procedurę Sub UnhookWindow().
ΔΔΔ | | | | |
|
| |
