File Search geht nicht mehr

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Thomas!
Unter XL2003 macht Filesearch manchmal Probleme. Der Grund ist nicht ganz klar!
Check mal die Verweise die im VBE gesetzt sind. Steht dort der Verweis auf
"Microsoft Office X.X Object Library"?
Wenn's daran nicht liegt, kannst du ja vielleicht auf diesen Code ausweichen.

' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
'Dateien suchen und auflisten
'by Nepumuk

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 = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100

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

Private lngDirCount As Long
Private lngFileCount As Long
Private strFiles() As String

Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String)
Dim WFD As WIN32_FIND_DATA
Dim lngSearch As Long
Dim strDirName As String
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
  GetFilesInFolder strFolderPath, strSearch
  Do
    If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
      strDirName = TrimNulls(WFD.cFileName)
      If (strDirName <> ".") And (strDirName <> "..") Then
        lngDirCount = lngDirCount + 1
        FindFiles strFolderPath & strDirName, strSearch
      End If
    End If
  Loop While FindNextFile(lngSearch, WFD)
  FindClose lngSearch
End If
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String)
Dim WFD As WIN32_FIND_DATA
Dim lngSearch As Long
Dim strFileName As String
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & strSearch, WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
  Do
    If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
      strFileName = TrimNulls(WFD.cFileName)
      lngFileCount = lngFileCount + 1
      Redim Preserve strFiles(1 To lngFileCount)
      strFiles(lngFileCount) = strFolderPath & strFileName
    End If
  Loop While FindNextFile(lngSearch, WFD)
  FindClose lngSearch
End If
End Sub

Private Function TrimNulls(ByVal strStringIn As String) As String
If InStr(strStringIn, Chr(0)) > 0 Then strStringIn = Left$(strStringIn, InStr(strStringIn, Chr(0)) - 1)
TrimNulls = strStringIn
End Function

Public Sub start()
lngDirCount = 1
lngFileCount = 0
FindFiles "C:\", "*.xls"
Range(Cells(1, 1), Cells(lngFileCount, 1)) = WorksheetFunction.Transpose(strFiles)
End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Thomas!
Schnell noch einen zusätzlichen Parameter und schon kann man das einstellen!

' **********************************************************************
' Modul: Modul4 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
'Dateien suchen und auflisten
'by Nepumuk

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 = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100

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

Private lngDirCount As Long
Private lngFileCount As Long
Private strFiles() As String

Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String, Optional ByRef searchSubFolders As Boolean = False)
Dim WFD As WIN32_FIND_DATA
Dim lngSearch As Long
Dim strDirName As String
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
  GetFilesInFolder strFolderPath, strSearch
  Do
    If searchSubFolders Then
      If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
        strDirName = TrimNulls(WFD.cFileName)
        If (strDirName <> ".") And (strDirName <> "..") Then
          lngDirCount = lngDirCount + 1
          FindFiles strFolderPath & strDirName, strSearch
        End If
      End If
    End If
  Loop While FindNextFile(lngSearch, WFD)
  FindClose lngSearch
End If
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String)
Dim WFD As WIN32_FIND_DATA
Dim lngSearch As Long
Dim strFileName As String
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & strSearch, WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
  Do
    If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
      strFileName = TrimNulls(WFD.cFileName)
      lngFileCount = lngFileCount + 1
      Redim Preserve strFiles(1 To lngFileCount)
      strFiles(lngFileCount) = strFolderPath & strFileName
    End If
  Loop While FindNextFile(lngSearch, WFD)
  FindClose lngSearch
End If
End Sub

Private Function TrimNulls(ByVal strStringIn As String) As String
If InStr(strStringIn, Chr(0)) > 0 Then strStringIn = Left$(strStringIn, InStr(strStringIn, Chr(0)) - 1)
TrimNulls = strStringIn
End Function

Public Sub start()
lngDirCount = 1
lngFileCount = 0
FindFiles "F:\Temp", "*.xls" ', True
Range(Cells(1, 1), Cells(lngFileCount, 1)) = WorksheetFunction.Transpose(strFiles)
End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

File Search geht nicht mehr

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

312 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread