Probleme mit Application.FileSearch

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Dateiname_Hyperlink() '* 07.10.04, 31.07.05; 02.08.05 * '* erstellt von Ramses Rainer * '* Anpassungen von Hajo * '* <a href="http://home.media-n.de/ziplies/">http://home.media-n.de/ziplies/</a> * Dim StDateiname As String Dim Dateiform As String Dim InI As Long, TotFiles As Long Dim Suchpfad As String Dim OldStatus As Variant Suchpfad = InputBox("Geben Sie den Ordner an, der durchsucht werden soll.", "Pfad definieren", Application.DefaultFilePath) If Suchpfad = "" Then Exit Sub Dateiform = InputBox("Geben Sie den Dateityp an der gesucht werden soll", "Dateierweiterung", "*.xls") If Dateiform = "" Then Exit Sub Application.ScreenUpdating = True OldStatus = Application.StatusBar ' neue Tabelle anlegen Sheets.Add After:=Worksheets(Worksheets.Count) With Application.FileSearch .LookIn = Suchpfad ' Suchverzeichnis .SearchSubFolders = True ' suchen auch in Unterverzeichnis .Filename = Dateiform If .Execute() > 0 Then TotFiles = .FoundFiles.Count Application.StatusBar = "Total " & TotFiles & " gefunden" For InI = 1 To .FoundFiles.Count Application.StatusBar = "Datei: " & InI & " von " & TotFiles ' ergänzt Hyperlink, Dateigröße und Dateidatum ' Dateiname abtrennen für alle Versionen unte Xp ' For InI = Len(.FoundFiles(InI)) To 1 Step -1 ' If Mid(.FoundFiles(InI), InI, 1) = "\" Then ' StDateiname = Mid(.FoundFiles(InI), InI + 1, Len(.FoundFiles(InI)) - InI + 2) ' Exit For ' End If ' Next InI ' Dateiname abtrennen ab XP StDateiname = Mid(.FoundFiles(InI), InStrRev(.FoundFiles(InI), "\") + 1) ActiveSheet.Hyperlinks.Add Anchor:=Cells(InI, 1), _ Address:=.FoundFiles(InI), TextToDisplay:=StDateiname ' Hyperlink Cells(InI, 2) = FileLen(.FoundFiles(InI)) ' Dateigröße Cells(InI, 3) = FileDateTime(.FoundFiles(InI)) ' Dateidatum Next InI End If End With Application.StatusBar = OldStatus Application.ScreenUpdating = True End Sub

Hallo Horst,
und so geht's per API:

' **********************************************************************
' Modul: Modul6 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, _
    ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" ( _
    ByVal hFindFile As Long) As Long

Private Enum FILE_ATTRIBUTE
    FILE_ATTRIBUTE_READONLY = &H1
    FILE_ATTRIBUTE_HIDDEN = &H2
    FILE_ATTRIBUTE_SYSTEM = &H4
    FILE_ATTRIBUTE_DIRECTORY = &H10
    FILE_ATTRIBUTE_ARCHIVE = &H20
    FILE_ATTRIBUTE_NORMAL = &H80
    FILE_ATTRIBUTE_TEMPORARY = &H100
End Enum

Private Const MAX_PATH = 260&
Private Const INVALID_HANDLE_VALUE = -1&

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

Public Sub prcStart()
    Dim lngFileCount As Long, lngIndex As Long
    Dim strFileArray() As String
    Call prcGetFilesInFolder(ThisWorkbook.Path & "\", "*.jpg", lngFileCount, strFileArray())
    MsgBox CStr(lngFileCount) & " Datei(en) gefunden.", 48, "Hinweis"
    For lngIndex = 1 To lngFileCount
        MsgBox strFileArray(lngIndex)
    Next
End Sub

Private Sub prcGetFilesInFolder(ByRef strFolderPath As String, ByRef strSearch As String, _
        ByRef lngFileCount As Long, ByRef strFileArray() As String)
    Dim udtWFD As WIN32_FIND_DATA
    Dim lngSearch As Long
    Dim strFileName As String
    lngSearch = FindFirstFile(strFolderPath & strSearch, udtWFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (udtWFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
                strFileName = Left$(udtWFD.cFileName, InStr(udtWFD.cFileName, Chr(0)) - 1)
                lngFileCount = lngFileCount + 1
                Redim Preserve strFileArray(1 To lngFileCount)
                strFileArray(lngFileCount) = strFolderPath & strFileName
            End If
        Loop While FindNextFile(lngSearch, udtWFD)
        FindClose lngSearch
    End If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Probleme mit Application.FileSearch

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

33 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Probleme mit Application.FileSearch

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

33 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread