Access

  MS Access 2010+  |  Przetwarzanie plików  |   VBA 7.0

• Lista plików w folderze roboczym i jego podfolderach.

Na stronie API. Lista folderów (Unikod) przedstawiłem rekurencyjną funkcję plikListSubFoldersApiW(...) wykorzystującą Unicodowe funkcje API w celu znalezienia wszystkich podfolderów w folderze roboczym.

Wyszukiwanie plików w podfolderach za pomocą funkcji API.

Funkcja FindFirstFile(...) umożliwia znalezienie pierwszego pliku lub folderu, którego nazwa pasuje do przekazanego wzorca. Może to być, ale nie musi, pierwszy plik lub folder na liście otrzymanej innymi metodami, gdyż funkcja FindFirstFile(...), podobnie jak wbudowana funkcja Dir nie sortuje wyników wyszukiwania.

• Użyte funkcje API

Funkcja FindFirstFile wyszukuje pliki i foldery wyłącznie po nazwie pliku, lub wzorcu z użyciem symboli wieloznacznych "?" oraz "*". W wyszukiwaniu nie można określić żadnych atrybutów, takich jak data lub typ pliku. Wyszukiwanie obejmuje długie i krótkie nazwy plików. Jeżeli wywołanie funkcji FindFirstFile(...) zakończy się sukcesem (zostanie znaleziony plik lub folder) pasujący do wzorca, to funkcja zwraca uchwyt wyszukiwania, a w strukturze WIN32_FIND_DATA informacje o znalezionym pliku lub folderze. Znaleziony plik lub folder może, ale nie musi, być pierwszym plikiem lub folderem na liście otrzymanej innymi metodami, gdyż funkcja FindFirstFile(...), podobnie jak wbudowana funkcja Dir nie sortuje wyników wyszukiwania. Zwrócony uchwyt wyszukiwania możemy użyć w celu wyszukania kolejnego pliku (folderu) za pomocą funkcji FindNextFile(...) która użyje tego samego filtru wyszukiwania. Przy powodzeniu (znalezieniu pliku lub folderu), funkcja FindNextFile(...) zwraca wartość niezerową, a w strukturze WIN32_FIND_DATA informacje o znalezionym pliku lub folderze. Aby zakończyć wyszukiwanie powinniśmy zamknąć uchwyt wyszukiwania za pomocą funkcji FindClose(...).

Bardziej szczegółowy opis użytych funkcji i struktur API użytych do wyszukania folderów znajduje się na stronie API. Lista folderów. Na stronie tej jest też przedstawiona funkcja własna plikListSubFoldersApiW(...), która zostanie użyta w funkcji wyszukującej pliki w folderze roboczym i jego podfolderach. Jako funkcja pomocnicza zostanie użyta funkcja własna tekstIsUnicode(...), korzystająca z funkcji API IsTextUnicode(...), sprawdzająca, czy tekst jest w formacie Unicode.

Struktura WIN32_FIND_DATA

Gdy funkcja FindFirstFile(...) lub FindNextFile(...) zakończy się sukcesem (zostanie znaleziony plik lub folder) pasujący do wzorca, możemy skorzystać ze zwracanej struktury WIN32_FIND_DATA, by pobrać więcej danych o pliku lub folderze. W funkcji fileListSubFoldersAPI(...) wyszukującej podfoldery w folderze roboczym korzystamy z elementu dwFileAttributes tej struktury, by sprawdzić, czy znaleziony obiekt jest folderem, a nie plikiem. W poniżej funkcji plikListFilesW, skorzystamy z elementu dwFileAttributes, by sprawdzić atrybuty pliku. Wyszukiwanie można rozbudować o wyszukiwanie po dacie utworzenia (ftCreationTime), lub dacie modyfikacji (ftLastWriteTime), a także po wielkości pliku (nFileSizeHigh i nFileSizeLow).

Poniżej struktura WIN32_FIND_DATA i krótki opis jej poszczególnych elementów:

Type WIN32_FIND_DATA
dwFileAttributes As Long
atrybuty pliku (ukryty, tylko do odczytu, systemowy lub archiwalny
ftCreationTime As FILETIME
data utworzenia pliku
ftLastAccessTime As FILETIME
data ostatniego dostępu (otworzenia, modyfikacja lub uruchomienie)
ftLastWriteTime As FILETIME
data ostatniej modyfikacji pliku
nFileSizeHigh As Long
rozmiar pliku w bajtach, jako najbardziej znacząca wartość DWORD
nFileSizeLow As Long
rozmiar pliku w bajtach, jako mniej znacząca wartość DWORD
dwReserved0 As Long
zarezerwowane
dwReserved1 As Long
zarezerwowane
cFileName As String * MAX_PATH
nazwa pliku
cAlternate As String * 14
alternatywna nazwa pliku w formacie 8.3
End Type
 

Funkcja wyszukująca pliki w folderze roboczym i podfolderach


⊗ Public Function plikListFilesW( _
                   ByVal sFolderNameW As String, _
                   sFilesPathRetW() As String, _
                   tpWFDRet() As WIN32_FIND_DATA, _
          Optional ByVal sMaskW As String, _
          Optional fSearchInSubFolders As Boolean = True, _
          Optional iAttrib As Integer = -1) As Long
  • Funkcja plikListFilesW(...) wykorzystuje Unicodowe funkcje API w celu znalezienia plików w folderze roboczym i jego podfolderach.
  • argumenty:
    • sFolderNameW
    • pełna ścieżka określająca roboczy folder, który zostanie przeszukany w celu znalezienia podfolderów. Argument ten musi być przekazany w formacie Unicode.
    • sFilesPathRetW()
    • zwracana ByRef tablica typu String zawierająca pełne nazwy, w formacie Unicode, znalezionych plików folderze sFolderNameW i jego podfolderach.
    • tpWFDRet()
    • zwracana ByRef tablica struktur WIN32_FIND_DATA dla każdego pliku. UWAGA! nazwa pliku jest zwracana także w tej strukturze.
    • sMaskW
    • argument opcjonalny, przekazany w formacie Unicode. Domyślna wartość "*". Maska umożliwiająca szukanie wielu plików przy użyciu symboli wieloznacznych takich jak "*" lub "?"
    • fSearchInSubFolders
    • argument opcjonalny. Domyślna wartość True.
      Określa rodzaj operacji, jaka będzie wykonywana w trakcie przeszukiwania folderów. Dla domyślnej wartości argumentu fSearchInSubFolders = True przeszukiwane będą wszystkie podfoldery w folderze roboczym. Dla wartości argumentu fSearchInSubFolders = False przeszukiwanie ograniczone zostanie do folderu roboczego, bez przeszukiwania podfolderów.
    • iAttrib
    • Argument opcjonalny. Domyślna wartość -1, dla której wyszukiwane są wszystkie pliki bez względu na posiadany atrybut. Dla innych wartości iAttrib zwracane są jedynie pliki mające zgodne atrybuty.
  • zwraca:
  • Zwraca liczbę znalezionych plików w folderze roboczym sFolderNameW, a w zwracanym ByRef argumencie sFilesPathRetW() tablicę, której elementy zawierają pełne ścieżki znalezionych plików (w formacie Unicode) bez znaku "/" (backslash) na końcu ścieżki.
  • autor: Zbigniew Bratko
  • data: 19.12.2017
Option Compare Database
Option Explicit
#If VBA7 Then
	Private Declare PtrSafe Function FindFirstFile Lib "kernel32" _
					Alias "FindFirstFileW" _
					(ByVal lpFileName As String, _
					lpFindFileData As WIN32_FIND_DATA) As LongPtr
	Private Declare PtrSafe Function FindNextFile Lib "kernel32" _
					Alias "FindNextFileW" _
					(ByVal hFindFile As LongPtr, _
					lpFindFileData As WIN32_FIND_DATA) As Long
	Private Declare PtrSafe Function FindClose Lib "kernel32" _
					(ByVal hFindFile As LongPtr) As Long
	Private Declare PtrSafe Function lstrlen Lib "kernel32" _
					Alias "lstrlenW" (ByVal lpString As String) As Long
	Private Declare PtrSafe Function IsTextUnicode Lib "advapi32" _
					(ByVal lpBuffer As String, ByVal cb As Long, lpi As Long) As Long
#Else
	Private Declare Function FindFirstFile Lib "kernel32" _
					Alias "FindFirstFileW" _
					(ByVal lpFileName As String, _
					lpFindFileData As WIN32_FIND_DATA) As Long
	Private Declare Function FindNextFile Lib "kernel32" _
					Alias "FindNextFileW" _
					(ByVal hFindFile As Long, _
					lpFindFileData As WIN32_FIND_DATA) As Long
	Private Declare Function FindClose Lib "kernel32" _
					(ByVal hFindFile As Long) As Long
	Private Declare Function lstrlen Lib "kernel32" _
					Alias "lstrlenW" _
					(ByVal lpString As String) As Long
	Private Declare Function IsTextUnicode Lib "advapi32" _
					(ByVal lpBuffer As String, ByVal cb As Long, lpi As Long) As Long
#End If

Private Const MAX_PATH = 520  ' 260*2
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

Private Const IS_TEXT_UNICODE_STATISTICS = &H2

Public Type FILETIME
	dwLowDateTime As Long
	dwHighDateTime As Long
End Type

Public Type WIN32_FIND_DATA
	 dwFileAttributes As Long
	 ftCreationTime As FILETIME
	 ftLastAccessTime As FILETIME
	 ftLastWriteTime As FILETIME
	 nFileSizeHigh As Long
	 nFileSizeLow As Long
	 dwReserved0 As Long
	 dwReserved1 As Long
	 cFileName As String * MAX_PATH
	 cAlternate As String * 28 '14*2
End Type

' Znaki pomocnicze i wieloznaczniki w formacie Unicode
Private Const conBackslashW     As String = "\" &vbNullChar
Private Const conDotW           As String = "." &vbNullChar
Private Const conDotDotW        As String = "." &vbNullChar &"." &vbNullChar
Private Const conAsteriskW      As String = "*" &vbNullChar
Private Const conQuestionMark   As String = "?" &vbNullChar

Public Function plikListFilesW( _
										 ByVal sFolderNameW As String, _
										 sFilesPathRetW() As String, _
										 tpWFDRet() As WIN32_FIND_DATA, _
						Optional ByVal sMaskW As String = conAsteriskW, _
						Optional fSearchInSubFolders As Boolean = True, _
						Optional iAttrib As Integer = -1) As Long

#If VBA7 Then
	Dim hFindFile   As LongPtr
	Dim hNextFile   As LongPtr
#Else
	Dim hFindFile   As Long
	Dim hNextFile   As Long
#End If

Dim tpWFD         As WIN32_FIND_DATA
Dim sSubfolders() As String
Dim sFileNameW    As String
Dim iFileAttrib   As Integer
Dim lCount        As Long
Dim i             As Long

	' sprawdź, czy argument sFolderNameW jest formacie Unicode
	' jeżeli nie, to go przekonwertuj - ToDo (ew. Err.Raise)
	If Not tekstIsUnicode(sFolderNameW) Then
		sFolderNameW = StrConv(sFolderNameW, vbUnicode)
	End If

	' sprawdź, czy argument sFolderNameW jest formacie Unicode
	' jeżeli nie, to go przekonwertuj - ToDo (ew. Err.Raise)
	If Not tekstIsUnicode(sMaskW) Then
		sMaskW = StrConv(sMaskW, vbUnicode)
	End If

	' sprawdź, czy na końcu znajduje się backslach, jeżeli nie to go dopisz
	If StrComp(Right$(sFolderNameW, 2), conBackslashW, vbBinaryCompare) <> 0 Then
		sFolderNameW = sFolderNameW &conBackslashW
	End If

	' uwzględnij podfoldery
	If fSearchInSubFolders = True Then
		If plikListSubFoldersApiW(sFolderNameW, sSubfolders(), conAsteriskW, True) > 0 Then
			' dostosuj wymiar tablicy do ilości zwróconych podfolderów
			ReDim Preserve sSubfolders(0 To UBound(sSubfolders) + 1)
		Else
			' brak podfolderów
			ReDim Preserve sSubfolders(0 To 0)
		End If
		' dopisz katalog główny bez znaku \ na końcu
		sSubfolders(UBound(sSubfolders)) = Left$(sFolderNameW, Len(sFolderNameW) - 2)
	Else
		' dopisz katalog główny bez znaku \ na końcu
		ReDim Preserve sSubfolders(0 To 0)
		sSubfolders(0) = Left$(sFolderNameW, Len(sFolderNameW) - 2)
	End If

	' dopisz  znaku \ na końcu nazwy podfolderu
	For i = LBound(sSubfolders()) To UBound(sSubfolders())
		sSubfolders(i) = sSubfolders(i) &conBackslashW
	Next

	' przeszukaj folder roboczy i wszystkie podfoldery (dla fSearchInSubFolders = True)
	For i = LBound(sSubfolders()) To UBound(sSubfolders())
		' utwórz uchwyt wyszukiwania
		hFindFile = FindFirstFile(sSubfolders(i) &sMaskW, tpWFD)
		' szukaj następnych plików zgodnych z uchwytem wyszukiwania
		If hFindFile <> INVALID_HANDLE_VALUE Then
			Do
				sFileNameW = Left$(tpWFD.cFileName, _
				2 * lstrlen(tpWFD.cFileName))
				' nie uwzględniaj "." i ".."
				If StrComp(sFileNameW, conDotW, vbBinaryCompare) <> 0 And _
					StrComp(sFileNameW, conDotDotW, vbBinaryCompare) <> 0 Then

					' pobierz atrybuty znalezionego elementu
					iFileAttrib = tpWFD.dwFileAttributes

					' uwzględniamy tylko pliki w folderach
					If (iFileAttrib And FILE_ATTRIBUTE_DIRECTORY) = 0 Then
						With tpWFD
							' wszystkie pliki
							If iAttrib = -1 Then
								ReDim Preserve sFilesPathRetW(0 To lCount)
								ReDim Preserve tpWFDRet(0 To lCount)
								sFilesPathRetW(lCount) = _
								sSubfolders(i) &sFileNameW
								tpWFDRet(lCount) = tpWFD
								lCount = lCount + 1
							Else
								' tylko pliki z wybranymi atrybutem(-ami) - iAttrib
								If (iFileAttrib And iAttrib) = iAttrib Then
									ReDim Preserve sFilesPathRetW(0 To lCount)
									ReDim Preserve tpWFDRet(0 To lCount)
									sFilesPathRetW(lCount) = _
									sSubfolders(i) &sFileNameW
									tpWFDRet(lCount) = tpWFD
									lCount = lCount + 1
								End If
							End If
						End With

					End If
				End If
				' szukaj następnego pliku
				hNextFile = FindNextFile(hFindFile, tpWFD)

			Loop Until hNextFile = 0
			' zamknij uchwyt wyszukiwania
			hNextFile = FindClose(hFindFile)
		End If
	Next

	plikListFilesW = lCount

End Function

' Rekurencyjna funkcja plikListSubFoldersApiW (...) wykorzystuje Unicodowe funkcje API
' w celu znalezienia wszystkich podfolderów w folderze roboczym.
'argumenty:
' sFolderNameW:
'		pełna ścieżka określająca roboczy folder, który zostanie przeszukany w celu
'		znalezienia podfolderów.  Argument ten musi być przekazany w formacie Unicode.
' sSubFoldersRetW()
'		tablica typu String, która przekazywana jest ByRef w kolejnych rekurencyjnych
'		wywołaniach funkcji. W każdym wywołaniu uzupełniana jest pełnymi ścieżkami
'		w formacie Unicode, znalezionych podfolderów w przekazywanym folderze sFolderNameW.
' sMaskW
'		Argument opcjonalny przekazany w formacie Unicode. Domyślna wartość "*".
'		Maska umożliwiająca wyszukanie podfolderów przy użyciu symboli wieloznacznych takich
'		jak "*" lub "?". Niestety, wyszukiwanie za pomocą wieloznacznika "?" (question mark)
'		jest nieco odmienne od działania przy użyciu kryterium Like, gdzie pojedynczy znak "?"
'		oznacza jeden znak w ciągu znaków.
' fSearchInSubFolders
'   Argument opcjonalny. Domyślna wartość True. Określa rodzaj operacji, jaka będzie wykonywana
'		 w trakcie przeszukiwania folderów. Dla domyślnej wartości argumentu fSearchInSubFolders = True
'		 przeszukiwane będą wszystkie podfoldery w folderze roboczym. Dla wartości argumentu
'		 fSearchInSubFolders = False przeszukiwanie ograniczone zostanie do folderu roboczego,
'		 bez przeszukiwania podfolderów.
' zwraca:
'		Zwraca liczbę znalezionych podfolderów w folderze roboczym sFolderNameW, a w zwracanym
'		ByRef argumencie sSubfoldersRetW() tablicę, której elementy zawierają pełne ścieżki
'		znalezionych podfolderów (w formacie Unicode) bez znaku "/" (backslash) na końcu ścieżki.
' autor: Zbigniew Bratko
' data: 23.11.2017

Public Function plikListSubFoldersApiW( _
															 ByVal sFolderNameW As String, _
															 ByRef sSubFoldersRetW() As String, _
											Optional ByVal sMaskW As String = conAsteriskW, _
											Optional fSearchInSubFolders As Boolean = True) As Long
#If VBA7 Then
	Dim hFindFile   As LongPtr
	Dim hNextFile   As LongPtr
#Else
	Dim hFindFile   As Long
	Dim hNextFile   As Long
#End If

Dim tpWFD         As WIN32_FIND_DATA
Dim sDirNameW     As String
Dim sFullPathW    As String
Dim colSubFolders As Collection
Dim lCount        As Long
Static lRet       As Long
Dim i             As Long

	' jeżeli tablica została zainicjowana to ustal ponownie licznik
	' (nietypowe sprawdzenie, czy tablica jest zainicjowana ?ToDo?)
	If (Not sSubFoldersRetW) <> -1 Then
		lCount = UBound(sSubFoldersRetW) + 1
	End If

	' sprawdź, czy argument sFolderNameW jest formacie Unicode
	' jeżeli nie, to go przekonwertuj. ToDo (ew. Err.Raise)
	If Not tekstIsUnicode(sFolderNameW) Then
		sFolderNameW = StrConv(sFolderNameW, vbUnicode)
	End If

	' sprawdź, czy argument jest sFolderNameW formacie Unicode
	' jeżeli nie, to go przekonwertuj. ToDo (ew. Err.Raise)
	If Not tekstIsUnicode(sMaskW) Then
		sMaskW = StrConv(sMaskW, vbUnicode)
	End If

	' sprawdź, czy na końcu znajduje się backslach, jeżeli nie to go dopisz
	If StrComp(Right$(sFolderNameW, 2), conBackslashW, vbBinaryCompare) <> 0 Then
		sFolderNameW = sFolderNameW &conBackslashW
	End If

	' zainicjuj kolekcję przechowującą znalezione podfoldery,
	' by przekazać je w rekurencyjnym wywołaniu
	Set colSubFolders = New Collection

	' zacznij wyszukiwanie, zwróć uchwyt wyszukiwania
	hFindFile = FindFirstFile(sFolderNameW &sMaskW, tpWFD)

	' zacznij szukaj
	If hFindFile <> INVALID_HANDLE_VALUE Then
		Do
			sDirNameW = Left$(tpWFD.cFileName, _
			2 * lstrlen(tpWFD.cFileName))
			' nie uwzględniaj "." i ".."
			If StrComp(sDirNameW, conDotW, vbBinaryCompare) <> 0 And _
					StrComp(sDirNameW, conDotDotW, vbBinaryCompare) <> 0 Then

				' sprawdź czy znaleziony element jest folderem
				If (tpWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
					sFullPathW = sFolderNameW &sDirNameW

					' sprawdź, czy przeszukiwać podfoldery
					If fSearchInSubFolders = True Then
						' dodaj do kolekcji rekurencyjnej
						colSubFolders.Add sFullPathW
					End If

					' dodaj do zwracanej tablicy i zwiększ licznik
					ReDim Preserve sSubFoldersRetW(0 To lCount)
					sSubFoldersRetW(lCount) = sFullPathW '& conBackslashW
					lCount = lCount + 1
				End If
			End If

			' szukaj następnego podfolderu
			hNextFile = FindNextFile(hFindFile, tpWFD)
		Loop Until hNextFile = 0

		' zamknij uchwyt wyszukiwania
		hNextFile = FindClose(hFindFile)

	End If

	' sprawdź, czy przeszukiwać podfoldery
	If fSearchInSubFolders = True Then
		' przeszukuj rekurencyjnie podfoldery z kolekcji colSubfolders
		For i = 1 To colSubFolders.Count
			Call plikListSubFoldersApiW(colSubFolders.Item(i), sSubFoldersRetW, _
																	sMaskW, fSearchInSubFolders)
		Next
	End If

	If (Not sSubFoldersRetW) <> -1 Then
		plikListSubFoldersApiW = UBound(sSubFoldersRetW) + 1
	End If

	Set colSubFolders = Nothing

End Function

' prototypowa funkcja sprawdzająca, czy tekst jest w formacie Unicode

' Funkcja tekstIsUnicode (...) testuje wejściowy ciąg znaków za pomocą
' funkcję API IsTextUnicode(...). Gdy wejściowy tekst nie przejdzie testu
' (nie jest w formacie Unicode), dodatkowo jest sprawdzana
' obecność znaku vbNullChar za pomocą funkcji InStr(...), obecność którego
' może świadczyć (ale nie musi), że testowany ciąg znaków jest w formacie Unicode.
' argumenty:
'   sText:
'     ciąg znaków, który poddany zostanie testowi
' zwraca:
'   Zwraca True gdy tekst jest w formacie Unicode, w przeciwnym wypadku zwraca False.
' autor: Zbigniew Bratko
' data: 01.12.2017

Public Function tekstIsUnicode(ByVal sText As String) As Boolean
Dim fRet As Boolean

	' sprawdź, czy tekst jest w formacie Unicode
	fRet = CBool(IsTextUnicode(ByVal sText, Len(sText), IS_TEXT_UNICODE_STATISTICS))

	' jeżeli nie jest, to sprawdź, czy zawiera znak vbNullChar
	If fRet = False Then
		If (InStr(1, sText, vbNullChar, vbBinaryCompare)) > 0 Then fRet = True
	End If

	tekstIsUnicode = fRet

End Function

Uwagi.

Fragment kodu oznaczony komentarzem „Nietypowe sprawdzenie, czy tablica jest zainicjowana” wymaga dalszego doprecyzowania. ⇒ToDo⇐

Nietypowe sprawdzenie, czy tablica jest zainicjowana
If (Not sSubFoldersRetW) <> -1 Then
   ' wykonaj instrukcje
End If

Funkcja tekstIsUnicode(...) jest prototypem, i wymaga dokładniejszego dopracowania, gdyż dla poniższych znaków (i ich kombinacji) nie zwraca prawidłowej wartość: ‚    „    …    †    ‡    ‰     ‹    ‘    ’    “”    •    –     —    ™    ›    Ă    ă O funkcji tekstIsUnicode(...) i poprawkach w najbliższym czasie. ⇒ToDo⇐