W poprzednim artykule
• Funkcje API - Mutex, jedna instancja bazy MS Access • zasygnalizowałem problem zbyt lakonicznego komunikatu w przypadku niepowodzenia
podczas wywołania funkcji API CreateMutex(...).
Komunikat typu:
MsgBox "Nieprzewidziany błąd wywołania biblioteki DLL." & vbNewLine & _
Numer błędu: " & Err.LastDllError
wydaje się być dość zdawkowy i nie daje końcowemu użytkownikowi zbyt wiele informacji o przyczynie błędu.
Spróbuję przedstawić rozwiązania pokazujące, jak w przypadku wystąpienia błędu zewnętrznej biblioteki DLL,
przekonwertować „suchy numer” błędu Err.LastDllError na opisowy komunikat tekstowy,
odnoszący się do zaistniałego błędu.
Zrobię to na przykładzie wywołania funkcji API • GetFileAttributes(...), która przy powodzeniu
zwraca atrybuty pliku lub katalogu, a przy niepowodzeniu zwraca wartość INVALID_FILE_ATTRIBUTES = -1.
Bardziej szczegółowe informacje o przyczynach niepowodzenia wywołania funkcji, możemy uzyskać z opisu kodu błędu systemowego wygenerowanego
przy wywołaniu biblioteki dołączanej dynamicznie (DLL). Kod błędu systemowego możemy pobrać dzięki
właściwości Err.LastDllError.
• Opis błędu o kodzie odpowiadającym właściwości Err.LastDllError
Najpierw musimy zadeklarować funkcję API • GetFileAttributes(...), a następnie spróbować
wywołać ją z nieprawidłowym argumentem, tak by wywołanie funkcji • GetFileAttributes(...) zakończyło się
niepowodzeniem, w wyniku czego funkcja zwróci wartość INVALID_FILE_ATTRIBUTES = -1), a właściwość
Err.LastDllError zwróci nam systemowy kod błędu wywołania biblioteki DLL.
Option Compare Database
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" _
Alias "GetFileAttributesA" _
(ByVal lpFileName As String) As Long
#Else
Private Declare Function GetFileAttributes Lib "kernel32" _
Alias "GetFileAttributesA" _
(ByVal lpFileName As String) As Long
#End If
' przykładowe wywołania
Public Function MojTest()
Dim lAttrib As Long
' próba pobrania atrybutów pliku, który nie istnieje
lAttrib = GetFileAttributes("C:\NotExistingFile")
If lAttrib = INVALID_FILE_ATTRIBUTES Then Debug.Print "A - Err = "; Err.LastDllError
' próba pobrania atrybutów pliku w nieistniejącej lokalizacji (brak stacji dysków B:\)
lAttrib = GetFileAttributes("B:\MojPlik.txt")
If lAttrib = INVALID_FILE_ATTRIBUTES Then Debug.Print "B - Err = "; Err.LastDllError
' próba pobrania atrybutów pliku z błędnie wpisanej lokalizacji
lAttrib = GetFileAttributes(":MojPlik.txt")
If lAttrib = INVALID_FILE_ATTRIBUTES Then Debug.Print "C - Err = "; Err.LastDllError
' próba pobrania atrybutów pliku z pustego dysku DVD (CD)
lAttrib = GetFileAttributes("Z:\NotExistingFile")
If lAttrib = INVALID_FILE_ATTRIBUTES Then Debug.Print "D - Err = "; Err.LastDllError
' próba pobrania atrybutów pliku z pustej stacji DVD (CD)
lAttrib = GetFileAttributes("Z:\MojPlik.txt")
If lAttrib = INVALID_FILE_ATTRIBUTES Then Debug.Print "E - Err = "; Err.LastDllError
DoCmd.RunCommand acCmdDebugWindow
End Function
Po wywołaniu przykładowej funkcji MojTest() w oknie „Immediate” możemy zobaczyć wyniki:
Nie wiem jak innym, ale mi cyferki (liczby) typu: 2, 3, 123, 1, 21 nic nie mówią. Tym bardziej użytkownikowi, który zobaczy poniższy komunikat:
Aby dowiedzieć się czegoś więcej o przyczynie błędu wywołania funkcji DLL, wykorzystamy funkcję API:
• FormatMessage(...), która formatuje tekst komunikatu związanego z kodem błędu wywołania biblioteki DLL
i zapisuje sformatowany komunikat do bufora wyjściowego. Zwraca ilość znaków zapisanych w buforze wyjściowym,
(nie uwzględnienia znaku końca ciągu vbNullChar).
Option Compare Database
Option Explicit
' • Function LastDllErrorDescr(lNoLastError As Long,[sFunctionName As String = ""]) As String
' --------------------------------------------------------------------------------------
' autor: Zbigniew Bratko - 03.2016
' Zwraca sformatowany tekst komunikatu związany z kodem błędu wywołania biblioteki DLL
' [lNoLastError] - numer błędu wywołania funkcji DLL, odpowiadający właściwości Err.LastDllError
' [sFunctionName] - opcjonalny argument odnoszący się do funkcji w której wystąpił błąd
' [OUT] - Przy powodzeniu zwraca tekst komunikatu związany z kodem błędu wywołania biblioteki DLL,
' przy niepowodzeniu (braku opisu błędu) zwraca informację: "Nie znaleziono opisu błędu."
'
#If VBA7 Then
Private Declare PtrSafe Function FormatMessage Lib "kernel32" _
Alias "FormatMessageA" _
(ByVal dwFlags As Long, _
lpSource As Any, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
Arguments As LongPtr) As Long
#Else
Private Declare Function FormatMessage Lib "kernel32" _
Alias "FormatMessageA" _
(ByVal dwFlags As Long, _
lpSource As Any, _
ByVal dwMessageId As Long, _
ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, _
ByVal nSize As Long, _
Arguments As Long) As Long
#End If
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const INVALID_FILE_ATTRIBUTES = -1
Private Const cDescrNotExist As String = "Nie znaleziono opisu błędu."
' Funkcja własna LastDllErrorDescr
Public Function LastDllErrorDescr(lNoLastError As Long, _
Optional sFunctionName As String = "") As String
Dim sBufferMessage As String
Dim lLenMessage As Long
Const cBufferSize As Long = 256
' przygotuj bufor na przyjęcie komunikatu o błędzie
sBufferMessage = String(cBufferSize, vbNullChar)
' zapisz tekst komunikatu do bufora sBufferMessage
lLenMessage = FormatMessage(ByVal FORMAT_MESSAGE_FROM_SYSTEM, _
0&, _
ByVal lNoLastError, _
0&, _
ByVal sBufferMessage, _
ByVal cBufferSize, _
0)
' nie znaleziono opisu błędu
If lLenMessage = 0 Then
' przygotuj własny komunikat
sBufferMessage = cDescrNotExist
lLenMessage = Len(sBufferMessage)
End If
' pobierz tekst komunikatu z bufora
If Len(sFunctionName) = 0 Then
LastDllErrorDescr = Left$(sBufferMessage, lLenMessage)
Else
LastDllErrorDescr = "Błąd nr " & lNoLastError & vbNewLine & _
"Funkcja " & sFunctionName & vbNewLine & _
"Opis błędu: " & vbNewLine & _
Left$(sBufferMessage, lLenMessage)
End If
End Function
' przykładowe wywołania
Public Function MojTestBis()
Dim lAttrib As Long
' próba pobrania atrybutów pliku, który nie istnieje
lAttrib = GetFileAttributes("C:\NotExistingFile")
If lAttrib = INVALID_FILE_ATTRIBUTES Then
Debug.Print "A - Err = "; Err.LastDllError & " " & LastDllErrorDescr(Err.LastDllError)
End If
' próba pobrania atrybutów pliku w nieistniejącej lokalizacji (brak stacji dysków B:\)
lAttrib = GetFileAttributes("B:\MojPlik.txt")
If lAttrib = INVALID_FILE_ATTRIBUTES Then
Debug.Print "B - Err = "; Err.LastDllError & " " & LastDllErrorDescr(Err.LastDllError)
End If
' próba pobrania atrybutów pliku z błędnie wpisanej lokalizacji
lAttrib = GetFileAttributes(":MojPlik.txt")
If lAttrib = INVALID_FILE_ATTRIBUTES Then
Debug.Print "C - Err = "; Err.LastDllError & " " & LastDllErrorDescr(Err.LastDllError)
End If
' próba pobrania atrybutów pliku z pustego dysku DVD (CD)
lAttrib = GetFileAttributes("Z:\NotExistingFile")
If lAttrib = INVALID_FILE_ATTRIBUTES Then
Debug.Print "D - Err = "; Err.LastDllError & " " & LastDllErrorDescr(Err.LastDllError)
End If
' próba pobrania atrybutów pliku z pustej stacji DVD (CD)
lAttrib = GetFileAttributes("Z:\MojPlik.txt")
If lAttrib = INVALID_FILE_ATTRIBUTES Then
Debug.Print "E - Err = "; Err.LastDllError & " " & LastDllErrorDescr(Err.LastDllError)
End If
DoCmd.RunCommand acCmdDebugWindow
End Function
Po wywołaniu przykładowej funkcji MojTestBis() w oknie „Immediate” możemy zobaczyć wyniki:
Uwaga: Właściwość Err.LastDllError odnosi się tylko do wywołania funkcji z zewnętrznych bibliotek DLL z kodu programu pisanego w języku VBA. Tak wywoływana funkcja zwykle zwraca kod oznaczający, czy wywoływana funkcja zakończyła się sukcesem, czy też niepowodzeniem i ustawiana jest właściwość Err.LastDllError. Właściwość Err.LastDllError powinna być sprawdzana po każdym niepowodzeniu wywoływanej funkcji biblioteki DLL. Jeśli właściwość Err.LastDllError została ustawiona, nie jest zgłaszany żaden wyjątek .
