|
| | | |
 • I.5. Access - Makra i moduły •
- 5.1 Jak utworzyć nowy moduł standardowy i zapisać go w bazie ?
- 5.2 Jak zapisać mały plik (np. ikonę aplikacji) w module standardowym ?
- 5.3 Jak zabezpieczyć się przed podmianą ikony bazy, czyli jak zmienić ikonę bazy na plik graficzny zapisany w module ?
- 5.4 Jak otworzyć w Access 2000+ za pomocą kodu VBA okno "Odwołania" - ( referencje ) ?
- 5.5 Jak w Access 2000+ w pliku *.mdb w oknie dialogowym "Odwołania" usunąć "zagubione referencje", lub odwołania zaczynające się od określonego ciągu znaków ?
- 5.6 Jak w Access 2000+ w pliku *.mdb wylistować wszystkie dostępne odwołania ( referencje ) ?
| | | | |
 |
| | |
|
5.1 Jak utworzyć moduł standardowy i zapisać go w bazie ?
Private Sub btnTest_Click()
Const MY_NEW_MODULE As String = "basTest"
DoCmd.RunCommand acCmdNewObjectModule
' jeżeli moduł MY_NEW_MODULE istnieje to wystapi błąd !
DoCmd.Save , MY_NEW_MODULE
DoCmd.OpenModule MY_NEW_MODULE
Modules(MY_NEW_MODULE).InsertText _
"Public Function NewFun()" & vbNewLine & _
" MsgBox ""Funkcja NewFun() w nowego modułu !""" & _
vbNewLine & "End Function"
DoCmd.Save acModule, MY_NEW_MODULE
DoCmd.Close acModule, MY_NEW_MODULE
' uruchom funkcję zapisaną w nowym module
Eval ("NewFun()")
' musi być Eval bo kod się nie skompiluje dla zapisu:
' Call NewFun ()
End Sub
lub w bardziej uniwersalny sposób:
grupa: pl.comp.bazy-danych.msaccess
wątek: Tworzenie nowego modulu.
w oparciu o artykuł: Krzysztofa Naworyty
<cyt>
Znalazłem jeszcze jeden (sposób), można traktować to jako ciekawostkę (choć myślę, że warto tę metodę ciągle przypominać)
LoadFromText acModule, "module1", "C:\plik.txt"
Plik tekstowy można sobie uprzednio wygenerować, na sto różnych sposobów
[...]
metoda jest absolutnie cicha:
- nadpisuje plik tekstowy
- nadpisuje moduł
- nie otwiera modułu
</cyt>
Private Sub knCreateModule()
Dim sTmpPath As String
Dim ff As Integer
Const MY_NEW_MODULE As String = "basTest"
Const MY_BAS_TEXT As String = _
"Public Function NewFun()" & vbNewLine & _
" MsgBox ""Funkcja NewFun() z nowego modułu !""" & _
vbNewLine & "End Function"
ff = FreeFile
sTmpPath = Environ$("TEMP") & "~" & _
MY_NEW_MODULE & ".bas"
Open sTmpPath For Output As #ff
Print #ff, MY_BAS_TEXT
Close #ff
Application.LoadFromText acModule, _
MY_NEW_MODULE, sTmpPath
If Len(Dir(sTmpPath)) > 0 Then Kill sTmpPath
' uruchom funkcję zapisaną w nowym module
Eval ("NewFun()")
' musi być Eval bo kod się nie skompiluje dla zapisu:
' Call NewFun ()
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
5.2 Jak zapisać mały plik (np. ikonę aplikacji) w module standardowym ?
Private Sub zbWriteIcoToModule(sIcoPath As String)
Dim sCodeLines As String
Dim sTmpBasFile As String
Dim aImg() As String ' tablica pliku (po 300 znaków)
Dim ff As Integer
Dim i As Long
Dim j As Long
Const MY_BAS_NAME As String = "/MyImg.bas"
Const MY_MODULE_NAME As String = "basImg"
If Len(Dir(sIcoPath)) = 0 Then Exit Sub
sTmpBasFile = Environ$("TEMP") & MY_BAS_NAME
On Error Resume Next
DoCmd.DeleteObject acModule, MY_MODULE_NAME
Application.RefreshDatabaseWindow
On Error GoTo 0
If FileLen(sIcoPath) > 75000 Then
MsgBox "Plik jest za duży. poszukaj mniejszego !", vbCritical
Exit Sub
End If
If Len(Dir(sTmpBasFile)) <> 0 Then Kill sTmpBasFile
ff = FreeFile
' wczytaj plik do tablicy po 300 znaków
Open sIcoPath For Binary Access Read As #ff
If LOF(ff) > 25000 Then
MsgBox "Plik jest dość duży, mogą wystąpić problemy !"
End If
Do While Not EOF(ff)
i = i + 1
ReDim Preserve aImg(1 To i)
aImg(i) = Input(300, #ff)
Loop
Close #ff
ff = FreeFile
Open sTmpBasFile For Binary Access Write As #ff
sCodeLines = "Option Explicit" & vbNewLine & _
"' dynamicznie tworzony moduł" & _
" zawierający mały plik" & vbNewLine
Put #ff, , sCodeLines
sCodeLines = ""
sCodeLines = "Public Function zbPartImg1() As String" & _
vbNewLine & _
"Dim aImg(" & 1 & " To " & UBound(aImg) & ")" & _
" As String" & vbNewLine & _
"Dim sTmp As String" & vbNewLine & _
"Dim i As Byte" & vbNewLine
' zapisz definicje
Put #ff, , sCodeLines
sCodeLines = ""
' przypisz do elementów tablicy poszczególne części pliku
For i = 1 To UBound(aImg)
For j = 1 To Len(aImg(i))
sCodeLines = sCodeLines & _
Format$(Asc(Mid(aImg(i), j, 1)), "000")
Next
sCodeLines = "aImg(" & i & ") = """ & _
sCodeLines & """" & vbNewLine
Put #ff, , sCodeLines
sCodeLines = ""
Next
sCodeLines = "For i = 1 To UBound(aImg)" & _
vbNewLine & _
" sTmp = sTmp & aImg(i)" & vbNewLine & _
"Next" & vbNewLine & _
"zbPartImg1 = sTmp" & vbNewLine & _
"End Function"
Put #ff, , sCodeLines
Close #ff
DoEvents: DoEvents: DoEvents
' zapisz moduł w bazie
Application.LoadFromText acModule, MY_MODULE_NAME, sTmpBasFile
DoEvents: DoEvents: DoEvents
If Dir(sTmpBasFile) <> "" Then Kill sTmpBasFile
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
5.3 Jak zabezpieczyć się przed podmianą ikony bazy, czyli jak zmienić ikonę bazy na plik graficzny zapisany w module ?
' 1. - funkcja startowa
Private Sub zbChangeAppIco()
Dim dbs As DAO.Database
Dim sTmpIcoPath As String
Dim sPrpIcoPath As String
Const MY_ICO_NAME As String = "\~MyIco.tmp"
sTmpIcoPath = Environ$("TEMP") & MY_ICO_NAME
' pobierz ścieżkę do pliku ikony z opcji Autostartu
Set dbs = CurrentDb
On Error Resume Next
sPrpIcoPath = dbs.Properties("AppIcon")
On Error GoTo 0
Set dbs = Nothing
' jeżeli ścieżki do pliku są zgodne i plik istnieje to wyjdź
If StrComp(sTmpIcoPath, sPrpIcoPath, vbTextCompare) = 0 Then
' nie jest w tym przypadku sprawdzana poprawność pliku
If Len(Dir(sTmpIcoPath)) > 0 Then Exit Sub
End If
' sprawdź, czy plik istnieje
If Len(Dir(sTmpIcoPath)) = 0 Then zbWriteIcoToDisk (sTmpIcoPath)
Call zbSetAppIco(sTmpIcoPath)
End Sub
' 2. - zapisuje do folderu TEMP ciąg znaków zwrócony przez funkcję zbPartImg1
Private Sub zbWriteIcoToDisk(sDestPath As String)
Dim sStrRet As String
Dim sTmp As String
Dim ff As Integer
Dim i As Long
' usuń istniejący plik ikony
If Len(Dir(sDestPath)) > 0 Then Kill sDestPath
ff = FreeFile
Open sDestPath For Binary As FreeFile
' jeżeli korzystasz ze metody opisanej w pkt. 5.1
' powinieneś w fazie testów użyć Eval
' sStrRet = Eval("zbPartImg1 ()")
sStrRet = zbPartImg1()
' pobieraj kolejno po trzy cyfry i przekształcaj na Byte
For i = 1 To Len(sStrRet) Step 3
sTmp = sTmp & Chr$(CByte(Mid$(sStrRet, i, 3)))
Next
Put #ff, , sTmp
Close #ff
End Sub
' 3. - zwraca ciąg znaków jako sekwencję sformatowanych bajtów (Format$(Byte, "000"))
Private Function zbPartImg1() As String
Dim aImg(1 To 3) As String
Dim sTmp As String
Dim i As Byte
aImg(1) = _
"066077014002000000000000000000118000000000040000000000032" & _
"000000000032000000000001000004000000000000000000002000000" & _
"136011000000136011000000000000000000000000000000000016224" & _
"000000255255000255048008000255000255000000000000000000000" & _
"000000000000000000000000000000000000000000000000000000000" & _
"000000000000000000000000000000000000000000000000000000000" & _
"000000000000017017017017017017017017017017017017017017017" & _
"017017016000001017017017017017017000001017017017017016000" & _
"017000001017017017017017016000001017017017017000017017000" & _
"017017017017017017016000001017017017016001017016001017000" & _
"001017017017016000001017017017000000017000016000000017017" & _
"016000017000017017017017016000000016017016001016000000001" & _
"016017017000001017017016000017016001000001017001017017017" & _
"017000000017000000001017000001001017000001017017017017000" & _
"000001017000017000017000001016000017017017017017000017017" & _
"000000001017016001017000017016001017017016000"
aImg(2) = _
"017016017000017017017017017017017000017017017016001016001" & _
"016001017017017017017017016000001017017000017000017000017" & _
"017017017017017017016000017017000017016001016001017017017" & _
"017017017017016000000001017017000016001017017017017017017" & _
"017017016000017017017016000017017017017017017017017017017" & _
"017017017017017017017017017017017017017034034017017018033" & _
"017017017034034034017017017034034034033017018034017017018" & _
"034018034033017018034017017034033017034033017034017017034" & _
"034017018033017017017034017018033017034017017033018017017" & _
"034017017017034034017034017034033017034017017017018033034" & _
"034033018033034033018034018034017017018034034033017017017" & _
"034034034018034034034017017017018034034034034033018017034" & _
"034017034033017017017017017034033017034017017017017017017" & _
"017017017018034017017034017018033017017017017017017017017" & _
"017034034017017017018033017017017017017017017017017017034" & _
"034018034034017017017017017017017017017017017"
aImg(3) = _
"017034034033017017017017017017017017017017049017017017017" & _
"017017017017017017017017017017017"
For i = 1 To UBound(aImg)
sTmp = sTmp & aImg(i)
Next
zbPartImg1 = sTmp
End Function
' 4. ustawia w opcjach startowych ścieżkę do ikony bazy
Private Sub zbSetAppIco(sPathIco As String)
On Error GoTo Err_Handler
Dim dbs As Database
Dim prp As Property
Const MY_PROP_NOT_FOUND As Long = 3270
Set dbs = CurrentDb
dbs.Properties("AppIcon") = sPathIco
Set dbs = Nothing
Application.RefreshTitleBar
Exit_Here:
Exit Sub
Err_Handler:
' właściwość nie istnieje, więc ją dodajemy
If Err.Number = MY_PROP_NOT_FOUND Then
Set prp = dbs.CreateProperty("AppIcon", dbText, sPathIco)
dbs.Properties.Append prp
dbs.Properties.Refresh
Set prp = Nothing
Resume
Else
Resume Exit_Here
End If
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
Call zbChangeAppIco
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
5.4 Jak otworzyć w Access 2000+ za pomocą kodu VBA okno " Odwołania " - ( referencje ) ?
<cyt>
VBE.MainWindow.WindowState = 1
VBE.MainWindow.Visible = True
VBE.CommandBars.FindControl(Id:=942).accDoDefaultAction
</cyt>
ΔΔΔ | | | | |
|
|
| | |
|
5.5 Jak w Access 2000+ w pliku *.mdb w oknie dialogowym " Odwołania " usunąć "zagubione referencje", lub odwołania zaczynające się od określonego ciągu znaków ?
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
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 GetDlgItem Lib "user32" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem 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 BM_CLICK = &HF5
Private Const WM_CLOSE = &H10
Private Const LB_FINDSTRING = &H18F
Private Const LB_FINDSTRINGEXACT = &H1A2
Private Const LB_SETSEL = &H185
Private Const CB_ERR = (-1)
Private Const MY_REF_NAME As String = "MISSING"
Private Const MY_TYPE_WINDOW As String = "LISTBOX"
Private Const MY_ID_BTN_OK As Long = 1
' w oknie "Odwołania" powinny być widoczne zagubione odwołania ( referencje ) do bazy [db1Ref.mdb]
Private Sub zbRemoveMissingRef()
On Error Resume Next
LockWindowUpdate GetDesktopWindow
VBE.MainWindow.WindowState = 1
VBE.MainWindow.Visible = True
' otwórz okno dialogowe "Odwołania" i uruchom Timer formularza
Me.TimerInterval = 40
VBE.CommandBars.FindControl(Id:=942).accDoDefaultAction
LockWindowUpdate False
End Sub
Private Sub Form_Timer()
Dim hWndRef As Long
Dim hLstBox As Long
Dim lFirst As Long
Dim lRet As Long
On Error Resume Next
Me.TimerInterval = 0
hWndRef = GetActiveWindow
VBE.MainWindow.Visible = False
VBE.MainWindow.Close
hLstBox = FindWindowEx(hWndRef, 0&, _
MY_TYPE_WINDOW, vbNullString)
' aby znależć dokładną nazwę, należy użyć stałej LB_FINDSTRINGEXACT
lFirst = SendMessage(hLstBox, LB_FINDSTRING, -1&, _
ByVal MY_REF_NAME)
If lFirst = CB_ERR Then
' zamykamy okno, bo nie znalaziono referencji, których nazwa
' zaczyna się znaków MY_REF_NAME,
SendMessage hWndRef, WM_CLOSE, ByVal 0&, ByVal 0&
MsgBox "Nie znaleziono 'zagubionych' referencji"
Exit Sub
End If
lRet = lFirst
Do
SendMessage hLstBox, LB_SETSEL, ByVal False, ByVal lRet
lRet = SendMessage(hLstBox, LB_FINDSTRING, ByVal lRet, ByVal MY_REF_NAME)
' nie wracaj na początek listy
If lRet = lFirst Then Exit Do
Loop
' zatwierdź przyciskiem OK
SendMessage GetDlgItem(hWndRef, MY_ID_BTN_OK), _
BM_CLICK, ByVal 0&, ByVal 0&
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
' wywołaniu poniższej funkcji towarzyszy krótkotrwałe mignięcie okna "Odwołania"
Call zbRemoveMissingRef
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
5.6 Jak w Access 2000+ w pliku *.mdb wylistować wszystkie dostępne odwołania ( referencje ) ?
Private Declare Function LockWindowUpdate Lib "user32" _
(ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
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 SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal Msg As Long, _
wParam As Any, _
lParam As Any) As Long
Private Const WM_CLOSE = &H10
Private Const LB_GETCOUNT = &H18B
Private Const MY_TYPE_WINDOW As String = "LISTBOX"
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A
Private Sub zbListRef()
On Error Resume Next
' praktycznie LockWindowUpdate w tym przypadku nic nie daje !
LockWindowUpdate GetDesktopWindow
VBE.MainWindow.WindowState = 1
VBE.MainWindow.Visible = True
' otwórz okno dialogowe "Odwołania" i uruchom Timer formularza
Me.TimerInterval = 40
VBE.CommandBars.FindControl(Id:=942).accDoDefaultAction
LockWindowUpdate False
DoCmd.RunCommand acCmdDebugWindow
End Sub
Private Sub Form_Timer()
Dim hWndRef As Long
Dim hLstBox As Long
Dim lCount As Long
Dim lLen As Long
Dim sBufferRef As String
Dim i As Long
Me.TimerInterval = 0
hWndRef = GetActiveWindow
VBE.MainWindow.Visible = False
hLstBox = FindWindowEx(hWndRef, 0&, _
MY_TYPE_WINDOW, vbNullString)
lCount = SendMessage(hLstBox, LB_GETCOUNT, _
ByVal 0&, ByVal 0&)
For i = 0 To lCount - 1
lLen = SendMessage(hLstBox, LB_GETTEXTLEN, _
ByVal i, ByVal 0&)
sBufferRef = String(lLen, vbNullChar)
lLen = SendMessage(hLstBox, LB_GETTEXT, _
ByVal i, ByVal sBufferRef)
sBufferRef = Left$(sBufferRef, lLen)
Debug.Print i, sBufferRef
Next
' zamknij okno referencji
Call SendMessage(hWndRef, WM_CLOSE, _
ByVal 0&, ByVal 0&)
VBE.MainWindow.Visible = True
End Sub
' przykładowe wywołanie:
Private Sub btnTest_Click()
' wywołaniu poniższej funkcji towarzyszy krótkotrwałe migotanie okien ;-)
Call zbListRef
End Sub
ΔΔΔ | | | | |
|
| |
