Option Compare Database
Option Explicit
#If VBA7 Then
  Private Declare PtrSafe Function FindFirstFileW Lib "kernel32" _
          (ByVal lpFileName As String, _
          lpFindFileData As WIN32_FIND_DATA) As LongPtr
  Private Declare PtrSafe Function FindNextFileW Lib "kernel32" _
          (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 lstrlenW Lib "kernel32" _
          (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 FindFirstFileW Lib "kernel32" _
          (ByVal lpFileName As String, _
          lpFindFileData As WIN32_FIND_DATA) As Long
  Private Declare Function FindNextFileW Lib "kernel32" _
          (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 lstrlenW Lib "kernel32" _
          (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 = FindFirstFileW(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 * lstrlenW(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 = FindNextFileW(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
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 = FindFirstFileW(sFolderNameW & sMaskW, tpWFD)

	' sprawdź, czy wyszukiwanie powiodło się
	If hFindFile <> INVALID_HANDLE_VALUE Then
		Do
			sDirNameW = Left$(tpWFD.cFileName, _
			2 * lstrlenW(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 = FindNextFileW(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

	' sprawdź, czy tablica jest zainicjowana
	' folder roboczy może nie zwierać podfolderów
	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