|
| | | |
 • II.6. VBA - Operacje na plikach [2] •
- 6.10 Jak pobrać pełne ścieżki do wszystkich podfolderów znajdujących się w folderze ?
- 6.11 Jak pobrać (zapisać w tabeli) pełne ścieżki wszystkich plików znajdujących się w folderze (również w podfolderach) ?
- 6.12 Jak pobrać niektóre właściwości plików: data utworzenia, data dostępu, data modyfikacji pliku oraz wielkość pliku ?
- 6.13 Jak przekształcić krótką nazwę pliku na nazwę długą ?
- <<• idź do str. 1 •>>
| | | | |
 |
| | |
|
6.10 Jak pobrać pełne ścieżki do wszystkich podfolderów znajdujących się w folderze ?
Bardziej rozbudowany przykład dostosowany do 32 bitowego oraz 64 bitowego VBA7 znajduje się na stronie:
• Lista podfolderów w folderze. Funkcja API FindFirstFileA i FindNextFileA •
' • Metoda I - za pomocą funkcji API
Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Private Const MAX_PATH = 520
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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 * 14
End Type
' rekurencyjnie poszukuje podfolderów w wybranym folderze, pełne ścieżki znalezionych podfolderów dodaje do kolekcji colSubFolders
' • sFolderName - folder główny, który bedzie przeszukiwany,
' • colSubFolders - zwracana ByRef kolekcja znalezionych podfolderów w folderze głównym
Public Sub zbListSubFoldersAPI( _
sFolderName As String, _
colSubFolders As Collection)
Dim colTmp As Collection
Dim wfd As WIN32_FIND_DATA
Dim sDirName As String
Dim sFullPath As String
Dim hFindFile As Long
Dim hNextFile As Long
Dim i As Long
Set colTmp = New Collection
If Right$(sFolderName, 1) <> "\" Then
sFolderName = sFolderName & "\"
End If
hFindFile = FindFirstFile(sFolderName & "*", wfd)
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
sDirName = Left$(wfd.cFileName, _
InStr(wfd.cFileName, vbNullChar) - 1)
If (sDirName <> ".") And (sDirName <> "..") Then
If (wfd.dwFileAttributes And _
FILE_ATTRIBUTE_DIRECTORY) = _
FILE_ATTRIBUTE_DIRECTORY Then
sFullPath = sFolderName & sDirName & "\"
' dodaj do kolekcji zwracanej
colSubFolders.Add sFullPath
' dodaj do kolekcji rekurencyjnej
colTmp.Add sFullPath
End If
End If
' szukaj następnego podfolderu
hNextFile = FindNextFile(hFindFile, wfd)
Loop Until hNextFile = 0
hNextFile = FindClose(hFindFile)
End If
' przeszukuj rekurencyjnie podfoldery
For i = 1 To colTmp.Count
Call zbListSubFoldersAPI(colTmp.Item(i), colSubFolders)
Next
Set colTmp = Nothing
End Sub
' przykładowe wywołanie:
Private Sub btnAPI_Click()
Dim colFolders As Collection
Dim i As Long
Set colFolders = New Collection
' pobierz wszystkie podfoldery
Call zbListSubFoldersAPI("C:\", colFolders)
For i = 1 To colFolders.Count
' Debug.Print colFolders.Item(i)
Next
Debug.Print "zbListSubFoldersAPI - Znaleziono ";
Debug.Print colFolders.Count & " podfolderów:"
Set colFolders = Nothing
End Sub
' • Metoda II - za pomocą funkcji API z obsługą nazw Unicode
Bardziej rozbudowany przykład i dostosowany do 32 bitowego oraz 64 bitowego VBA7 znajduje się na stronie:
• Lista podfolderów. Unikodowa funkcja API FindFirstFileW i FindNextFileW •
Public Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileW" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileW" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public 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 Const MAX_PATH = 1024
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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 * 14
End Type
' rekurencyjnie poszukuje podfolderów w wybranym folderze, pełne ścieżki znalezionych podfolderów dodaje do zwracanej ByRef tablicy sSubfoldersRetW()
' • sFolderNameW - folder główny, który będzie przeszukiwany, przekazany jako UNICODE
' • sSubfoldersRetW - zwracana ByRef tablica nazw (UNICODE) znalezionych podfolderów w folderze głównym, (ze znakiem \ na końcu)
' • fSearchInSubFolder - flaga określająca, czy przeszukiwać podfoldery,
' • lCounter - licznik podfolderów
Public Function zbListSubfoldersApiW( _
ByVal sFolderNameW As String, _
sSubfoldersRetW() As String, _
Optional fSearchInSubFolder _
As Boolean = False, _
Optional lCounter As Long = 0) As Long
Dim wfd As WIN32_FIND_DATA
Dim sDirNameW As String
Dim sFullPathW As String
Dim hFindFile As Long
Dim hNextFile As Long
Dim colRecur As Collection
Dim i As Long
Set colRecur = New Collection
If StrComp(Right$(sFolderNameW, 2), _
StrConv("\", vbUnicode), _
vbBinaryCompare) <> 0 Then
sFolderNameW = sFolderNameW & StrConv("\", vbUnicode)
End If
hFindFile = FindFirstFile(sFolderNameW & _
StrConv("*", vbUnicode), wfd)
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
sDirNameW = Left$(wfd.cFileName, _
2 * lstrlen(wfd.cFileName))
If StrComp(sDirNameW, StrConv(".", vbUnicode), _
vbBinaryCompare) <> 0 And _
StrComp(sDirNameW, StrConv("..", vbUnicode), _
vbBinaryCompare) <> 0 Then
If (wfd.dwFileAttributes And _
FILE_ATTRIBUTE_DIRECTORY) = _
FILE_ATTRIBUTE_DIRECTORY Then
sFullPathW = sFolderNameW & sDirNameW ' & _
StrConv("\", vbUnicode)
ReDim Preserve sSubfoldersRetW(0 To lCounter)
' dodaj do zwracanej tablicy
sSubfoldersRetW(lCounter) = sFullPathW
lCounter = lCounter + 1
If fSearchInSubFolder = True Then
' dodaj do kolekcji rekurencyjnej
colRecur.Add sFullPathW
End If
End If
End If
' szukaj następnego podfolderu
hNextFile = FindNextFile(hFindFile, wfd)
Loop Until hNextFile = 0
hNextFile = FindClose(hFindFile)
End If
If fSearchInSubFolder = True Then
' przeszukuj rekurencyjnie podfoldery
For i = 1 To colRecur.Count
Call zbListSubfoldersApiW( _
colRecur.Item(i), sSubfoldersRetW, _
fSearchInSubFolder, lCounter)
Next
End If
Set colRecur = Nothing
zbListSubfoldersApiW = lCounter
End Function
' przykładowe wywołanie:
Private Sub btnApiW_Click()
Dim sSubfoldersW() As String
Dim i As Long
If zbListSubfoldersApiW( _
StrConv("C:\FolderTestowy", vbUnicode), _
sSubfoldersW(), True) = 0 Then
Exit Sub
Else
For i = LBound(sSubfoldersW) To UBound(sSubfoldersW)
Debug.Print i + 1, sSubfoldersW(i)
Debug.Print i + 1, StrConv(sSubfoldersW(i), vbFromUnicode)
Next
End If
End Sub
' • Metoda III - za pomocą obiektu FileSystemObject z Windows Scripting Host.
Bardziej rozbudowany przykład i dostosowany do 32 bitowego oraz 64 bitowego VBA7 znajduje się na stronie:
• Lista podfolderów zwracanych przez FileSystemObject (FSO) •
' Metoda ta jest ok. 2 razy wolniejsza od Metody I, która wykorzystuje funkcje API.
' rekurencyjnie poszukuje podfolderów w wybranym folderze, pełne ścieżki znalezionych podfolderów dodaje do kolekcji colSubFolders
' • sFolderName - folder do przeszukania (zmienna obiektowa),
' • colSubFolders - zwracana ByRef kolekcja znalezionych podfolderów w folderze głównym
Public Sub zbListSubFoldersFSO(oFolder As Object, _
colSubFolders As Collection)
Dim subFolder As Object
On Error Resume Next ' <= błędy braku dostępu, błąd ścieżki i inne
For Each subFolder In oFolder.SubFolders
colSubFolders.Add subFolder.path & "\"
Call zbListSubFoldersFSO(subFolder, colSubFolders)
Next
End Sub
' przykładowe wywołanie:
Private Sub btnFSO_Click()
Dim oFSO As Object
Dim oIniFolder As Object
Dim colFolders As Collection
Dim i As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oIniFolder = oFSO.GetFolder("C:\")
Set colFolders = New Collection
' pobierz wszystkie podfoldery
Call zbListSubFoldersFSO(oIniFolder, colFolders)
For i = 1 To colFolders.Count
' Debug.Print colFolders.Item(i)
Next
Debug.Print "zbListSubFoldersFSO - Znaleziono: ";
Debug.Print colFolders.Count & " podfolderów"
Set colFolders = Nothing
Set oIniFolder = Nothing
Set oFSO = Nothing
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.11 Jak pobrać (zapisać w tabeli) pełne ścieżki wszystkich plików znajdujących się w folderze (również w podfolderach) ?
' • Metoda I - za pomocą funkcji API
Private Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Private Const MAX_PATH = 520
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const ATTRIBUTE_FILE_INVALID = -1
' musisz utworzyć tabelę "tTblApi"
Private Const MY_TBL_API As String= "tTblApi"
' i pole [tPath] typu Memo (Nota) w tabeli
Private Const MY_FLD_PATH As String= "tPath"
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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 * 14
End Type
' Pobiera wszystkie podfoldery w folderze głównym i następnie przeszukuje podfoldery, pełna scieżka pliku zapisywana jest jako rekord w tabeli MY_TBL_API w polu rst.Fields(MY_FLD_PATH).
' • sFolderName - folder główny, który będzie przeszukiwany,
' • sMask - maska umożliwiająca szukanie wielu plików przy użyciu symboli wieloznacznych takich jak "*" lub "?"
' • fSubFolders - flaga określająca, czy przeszukiwać podfoldery,
' • iAttrib - dla wartości -1 listowane są wszystkie pliki, dla innych wartości iAttryb zapisywany jest jedynie plik mający ustawione szukane atrybuty,
Public Sub zbListFilesAPI(ByVal sFolderName As String, _
sMask As String, _
Optional fSubFolders As Boolean = True, _
Optional iAttrib As Integer = -1)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim wfd As WIN32_FIND_DATA
Dim colFolders As Collection
Dim sDirName As String
Dim sFileName As String
Dim hFindFile As Long
Dim hNextFile As Long
Dim iFileAttrib As Integer
Dim i As Long
If Right$(sFolderName, 1) <> "\" Then
sFolderName = sFolderName & "\"
End If
Set colFolders = New Collection
' dopisz katalog główny
colFolders.Add sFolderName
' uwzględnij podfoldery
If fSubFolders = True Then
Call zbListSubFoldersAPI(sFolderName, colFolders)
End If
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(MY_TBL_API, , dbAppendOnly)
For i = 1 To colFolders.Count
hFindFile = FindFirstFile(colFolders.Item(i) & sMask, wfd)
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
sFileName = Left$(wfd.cFileName, _
InStr(wfd.cFileName, vbNullChar) - 1)
If (sFileName <> ".") And (sFileName <> "..") Then
iFileAttrib = wfd.dwFileAttributes
' uwzględniamy pliki i przypadek błędu odczytu
' atrybutów, pliki te listuje funkcja DIR i FSO)
If (iFileAttrib And _
FILE_ATTRIBUTE_DIRECTORY) = 0 Or _
(iFileAttrib = ATTRIBUTE_FILE_INVALID) Then
With rst
' listuj wszystkie pliki
If iAttrib = -1 Then
.AddNew
.Fields(MY_FLD_PATH) = _
colFolders.Item(i) & sFileName
.Update
Else
' listuj tylko pliki z atrybutem(-ami) - iAttrib
If (iFileAttrib And iAttrib) = iAttrib Then
.AddNew
.Fields(MY_FLD_PATH) = _
colFolders.Item(i) & sFileName
.Update
End If
End If
End With
End If
End If
hNextFile = FindNextFile(hFindFile, wfd)
Loop Until hNextFile = 0
hNextFile = FindClose(hFindFile)
End If
Next
rst.Close
Set rst = Nothing
Set dbs = Nothing
End Sub
' • Metoda II - za pomocą funkcji API z obsługą nazw Unicode, bez zapisu do tabeli
Public Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileW" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileW" _
(ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Public 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 Const MAX_PATH = 1024
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private 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 * 14
End Type
' Pobiera wszystkie podfoldery w folderze głównym i następnie przeszukuje podfoldery, zwraca ilość znalezionych plików
' • sFolderNameW - przeszukiwanego folder główny, przekazany jako ciąg UNICODE
' • sMask - maska umożliwiająca szukanie wielu plików przy użyciu symboli wieloznacznych takich jak "*" lub "?"
' • sFilesPathRetW() - zwracana ByRef tablica zawierająca Unikodowe pełne nazwy znalezionych plików
' • wfdRet() - zwracana ByRef tablica struktur WIN32_FIND_DATA dla każdego pliku. UWAGA! nazwa pliku jest zwracana także i w tej strukturze.
' • fSearchInSubfolders - flaga określająca, czy przeszukiwać podfoldery,
' • iAttrib - dla wartości -1 listowane są wszystkie pliki, dla innych wartości iAttryb zwracane są jedynie pliki mający ustawione szukane atrybuty,
Public Function zbListAllFilesW( _
ByVal sFolderNameW As String, _
sMask As String, _
sFilesPathRetW() As String, _
wfdRet() As WIN32_FIND_DATA, _
Optional fSearchInSubfolders As Boolean = True, _
Optional iAttrib As Integer = -1) As Long
Dim wfd As WIN32_FIND_DATA
Dim sSubfolders() As String
Dim sFileNameW As String
Dim sMaskW As String
Dim hFindFile As Long
Dim hNextFile As Long
Dim iFileAttrib As Integer
Dim lCount As Long
Dim i As Long
sMaskW = StrConv(sMask, vbUnicode)
' sprawdź, czy na końcu jest Backslash
If StrComp(Right$(sFolderNameW, 2), StrConv("\", vbUnicode), _
vbBinaryCompare) <> 0 Then
sFolderNameW = sFolderNameW & StrConv("\", vbUnicode)
End If
' uwzględnij podfoldery
If fSearchInSubfolders = True Then
If zbListSubfoldersApiW(sFolderNameW, _
sSubfolders(), True) > 0 Then
' dopisz katalog główny bez znaku \ na końcu
ReDim Preserve sSubfolders(0 To UBound(sSubfolders) + 1)
Else
ReDim Preserve sSubfolders(0 To 0)
End If
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
For i = LBound(sSubfolders()) To UBound(sSubfolders())
sSubfolders(i) = sSubfolders(i) & StrConv("\", vbUnicode)
Next
For i = LBound(sSubfolders()) To UBound(sSubfolders())
hFindFile = FindFirstFile(sSubfolders(i) & sMaskW, wfd)
If hFindFile <> INVALID_HANDLE_VALUE Then
Do
sFileNameW = Left$(wfd.cFileName, _
2 * lstrlen(wfd.cFileName))
If StrComp(sFileNameW, StrConv(".", vbUnicode), _
vbBinaryCompare) <> 0 And _
StrComp(sFileNameW, StrConv("..", vbUnicode), _
vbBinaryCompare) <> 0 Then
iFileAttrib = wfd.dwFileAttributes
' uwzględniamy tylko pliki w folderach
If (iFileAttrib And _
FILE_ATTRIBUTE_DIRECTORY) = 0 Then
With wfd
' wszystkie pliki
If iAttrib = -1 Then
ReDim Preserve sFilesPathRetW(0 To lCount)
ReDim Preserve wfdRet(0 To lCount)
sFilesPathRetW(lCount) = _
sSubfolders(i) & sFileNameW
wfdRet(lCount) = wfd
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 wfdRet(0 To lCount)
sFilesPathRetW(lCount) = _
sSubfolders(i) & sFileNameW
wfdRet(lCount) = wfd
lCount = lCount + 1
End If
End If
End With
End If
End If
hNextFile = FindNextFile(hFindFile, wfd)
Loop Until hNextFile = 0
hNextFile = FindClose(hFindFile)
End If
Next
zbListAllFilesW = lCount
End Function
Rozbudowany przykład przedstawiajacy jak zapisać w tabeli
pełne ścieżki wszystkich plików znajdujących się w folderze (również w podfolderach)
oraz jak pobrać dane tych plików, takie jak: data utworzenia, data ostatniego dostępu,
data modyfikacji, atrybuty, wielkość pliku, jego rozszerzenie i przedstawić te dane w tabeli
na stronie WWW znajduje się na stronie: Jak wylistować pliki w folderze ...
' • Metoda III - za pomocą obiektu FileSystemObject z Windows Scripting Host. Metoda ta jest ok. 8 do 10 razy wolniejsza od Metody I, która wykorzystuje funkcje API.
' Pobiera wszystkie podfoldery w folderze głównym i następnie przeszukuje podfoldery, pełna scieżka pliku zapisywana jest jako rekord w tabeli MY_TBL_FSO w polu rst.Fields(MY_FLD_PATH).
' • sFolderName - folder główny, który będzie przeszukiwany,
' • sMask - maska umożliwiająca szukanie wielu plików przy użyciu symboli wieloznacznych takich jak "*" lub "?" UWAGA! - w tym przykładzie wyszukiwanie oparte jest na operatorze Like i jego działanie jest trochę inne niż w funkcji Dir, czy też FindNextFile(...)
' • fSubFolders - flaga określająca, czy przeszukiwać podfoldery,
' • iAttrib - dla wartości -1 listowane są wszystkie pliki, dla innych wartości iAttrib zapisywany jest jedynie plik mający ustawione szukane atrybuty,
Public Sub zbListFilesFSO(ByVal sFolderName As String, _
Optional sMask As String = "*.*", _
Optional fSubFolders As Boolean = True, _
Optional iAttrib As Integer = -1)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim colFolders As Collection
Dim oFSO As Object
Dim oIniFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oIniFolder = oFSO.GetFolder(sFolderName)
Set colFolders = New Collection
If Right$(sFolderName, 1) <> "\" Then
sFolderName = sFolderName & "\"
End If
' dopisz katalog główny
colFolders.Add sFolderName
' uwzględnij podfoldery
If fSubFolders = True Then
' pobierz wszystkie podfoldery
Call zbListSubFoldersFSO(oIniFolder, colFolders)
End If
' próby przybliżenia wyszukiwania plików przy zastosowaniu
' symboli wieloznacznych dla sMask = "*.*" procedura nie zwracała
' plików bez rozszerzenia
If StrComp(Right$(sMask, 2), ".*", vbBinaryCompare) = 0 Then
sMask = Left$(sMask, Len(sMask) - 2)
End If
' pozostawiam problem maski typu sMask= "?????"
' procedura nie zwraca np. pliku ..\abc; ale zwraca
' pliki o długości 5 znaków np. ..\v.sig; ..\1.abc; ..\0.log;
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(MY_TBL_FSO, , dbAppendOnly)
For i = 1 To colFolders.Count
Set oFolder = oFSO.GetFolder(colFolders.Item(i))
For Each oFile In oFolder.Files
If (oFile.Name Like sMask) Then
With rst
If iAttrib = -1 Then
.AddNew
.Fields(MY_FLD_PATH) = _
colFolders.Item(i) & oFile.Name
.Update
Else
' listuj tylko pliki z atrybutem(-ami) - iAttrib
If (oFile.Attributes And iAttrib) = iAttrib Then
.AddNew
.Fields(MY_FLD_PATH) = _
colFolders.Item(i) & oFile.Name
.Update
End If
End If
End With
End If
Next
Next
On Error Resume Next
rst.Close
Set rst = Nothing
Set dbs = Nothing
Set colFolders = Nothing
Set oIniFolder = Nothing
Set oFSO = Nothing
End Sub
ΔΔΔ | | | | |
|
|
| | |
|
6.12 Jak pobrać niektóre właściwości plików: data utworzenia, data dostępu, data modyfikacji pliku oraz wielkość pliku ?
Private Declare Function GetFileSize Lib "kernel32" _
(ByVal hFile As Long, _
lpFileSizeHigh As Long) As Long
Private Declare Function CreateFile Lib "kernel32" _
Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function GetFileTime Lib "kernel32" _
(ByVal hFile As Long, _
lpCreationTime As FILETIME, _
lpLastAccessTime As FILETIME, _
lpLastWriteTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime _
Lib "kernel32" _
(lpFileTime As FILETIME, _
lpSystemTime As SYSTEMTIME) As Long
Private Declare Function FileTimeToLocalFileTime _
Lib "kernel32" _
(lpFileTime As FILETIME, _
lpLocalFileTime As FILETIME) As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Public Type MY_FILEPROPERTY
lFileSize As Long
dtCreated As Date
dtAccess As Date
dtWrite As Date
sErrDescr As String
End Type
' przy powodzeniu zwraca w strukturze MY_FILEPROPERTY wielkość pliku oraz datę utworzenia, datę dostępu i datę modyfikacji pliku, składowa sErrDescr jest ciągiem zerowej długości, przy niepowodzeniu składowa sErrDescr zawiera opis błędu,
Public Function zbGetFileProperties( _
sFilePath As String) As MY_FILEPROPERTY
Dim hFile As Long
Dim lFileSize As Long
Dim ftCreated As FILETIME
Dim ftAccess As FILETIME
Dim ftWrite As FILETIME
Dim ftLocal As FILETIME
Const INVALID_HANDLE_VALUE = -1
hFile = CreateFile(sFilePath, GENERIC_WRITE, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, _
ByVal 0&, OPEN_EXISTING, ByVal 0&, ByVal 0&)
If hFile = INVALID_HANDLE_VALUE Or hFile = 0 Then
zbGetFileProperties.sErrDescr = _
zbLastDllErrorDescr(Err.LastDllError)
' zbGetFileProperties.sErrDescr = "Error"
Else
zbGetFileProperties.sErrDescr = ""
zbGetFileProperties.lFileSize = _
CLng(GetFileSize(hFile, lFileSize))
GetFileTime hFile, ftCreated, ftAccess, ftWrite
zbGetFileProperties.dtCreated = _
zbFileTimeToLocalDate(ftCreated)
zbGetFileProperties.dtAccess = _
zbFileTimeToLocalDate(ftAccess)
zbGetFileProperties.dtWrite = _
zbFileTimeToLocalDate(ftWrite)
End If
CloseHandle hFile
End Function
' konwertuje 64-bitową strukturę FILETIME na datę
Private Function zbFileTimeToLocalDate(ft As FILETIME) As Date
Dim ftLocal As FILETIME
Dim st As SYSTEMTIME
FileTimeToLocalFileTime ft, ftLocal
If FileTimeToSystemTime(ftLocal, st) <> 0 Then
With st
zbFileTimeToLocalDate = _
CDate(CDbl(DateSerial(.wYear, .wMonth, .wDay)) + _
CDbl(TimeSerial(.wHour, .wMinute, .wSecond)))
End With
End If
End Function
ΔΔΔ | | | | |
|
|
| | |
|
6.13 Jak przekształcić krótką nazwę pliku na nazwę długą ?
Private Declare Function GetLongPathName Lib "kernel32" _
Alias "GetLongPathNameA" _
(ByVal lpszShortPath As String, _
ByVal lpszLongPath As String, _
ByVal cchBuffer As Long) As Long
' konwertuje krótką nazwę pliku na nazwę długą, plik musi fizycznie istnieć na dysku !
Public Function zbGetLongPath( _
sShortPath As String) As String
Dim sBff As String
Dim lRet As Long
' pobierz wielkość buforu
lRet = GetLongPathName(sShortPath, "", 0&)
' utwórz bufor
sBff = String(lRet, vbNullChar)
' pobierz długą nazwę do buforu
lRet = GetLongPathName(sShortPath, sBff, lRet)
zbGetLongPath = Left$(sBff, lRet)
End Function
ΔΔΔ | | | | |
|
| |
