Tekst informacyjny o polityce Cookies Close   
    
 
         
• Strona główna
• 1. Linki
• 3. Kontakt: e-Mail
 
         
• 1. Baza danych
• 2. Tabele i kwerendy
• 3. Formularze
• 4. Raporty
• 5. Moduły i makra
• 6. Obsługa błędów
 
    

II.   VBA 

    
• 1. Okna Accessa
• 2. Okna Formularzy
• 3.Okna Dialogowe
• 4. Tekst
• 5. Liczby
• 6. Pliki
• 7. Inne
 
    

III.   API 

    
• 1. Ogólnie o API
• 2. Funkcje API
• 3. System
• 4. Praca z oknami
• 5. Okna dialogowe
• 6. API - Inne
 
         
• 1. Bitmapy 24 Bit
• 2. GDI i HDC
• 3. Kody kreskowe
• 4. Formant Image
• 5. FreeImage.dll
 
    

V.   Inne 

    
• 1. Shell i MsDOS
• 2. Kontrolki
• 3. ६ԼҚ ਸ
• 4. Unikod

 
Odwiedzin:

Logo AccessFAQ• 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 ?


   Przykład:  • acc05a_03  •  52 KB  •  status: FREE  Pobrano    razy   



' 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 ) ?


grupa: pl.comp.bazy-danych.msaccess
wątek: Kto potrafi programowo usunąć urwaną referencję ?
przedstawił: Krzysztof Pozorek

<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 ?


   Przykład:  • acc05a_05_A2k  •  52 KB  •  status: FREE  Pobrano    razy   



grupa: pl.comp.bazy-danych.msaccess
w oparciu o artykuł: Kto potrafi programowo usunąć urwaną referencję ?



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łaniareferencje ) ?

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

 ΔΔΔ