Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
636to640
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
636to640
636to640
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Dateisuche mit VBA
14.07.2005 12:04:28
Borño
hola,
mein problem ist folgendes, ich möchte mir eine datei/ordner-suche mit vba für excel schreiben. die ergebnisse sollen in einem excelblatt erscheinen.
habe schon ein paar varianten mit application.filesearch probiert und das klappt auch alles so weit. das problem ist meine festplatten sind gross und haben ne menge ordner. wenn ich aus der wurzel einer platte suche und "SearchSubFolders = true" setze vergehen stunden oder er bleibt irgendwo hängen!? hier mein suchalgo:
Set DateiSuche = Application.FileSearch
With DateiSuche
.NewSearch
.FileName = DateiName 'aus UserForm
.LookIn = CurDir() 'aus msoFileDialogFolderPicker
.SearchSubFolders = True
.Execute (SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending)
If .FoundFiles.Count &gt 0 Then
ReDim Preserve FileList(5, FileCount + .FoundFiles.Count)
For i = 1 To .FoundFiles.Count
ff = .FoundFiles(i)
FileList(3, FileCount) = .FoundFiles(i) 'Feld wird gefüllt und später
FileList(4, FileCount) = .FoundFiles(i) 'ausgewertet u. dargestellt
FileCount = FileCount + 1
Next i
funktioniert einwandfrei nur wie gesagt das problem entsteht bei zb. suche nach *.xls in d:\ !
Mein neuster versuch ist mit searchscopes,scopefolder usw. zu arbeiten, da ich hoffe wenn ich Execute in jedem Subfolder einzeln ausführe und mir schon mal zwischenergebnisse anzeigen lasse er nicht hängen bleibt.
So nun zu meinen fragen:
wie kann man einen searchscope selber definieren, den msoSearchInCustom Type gibts bei mir nicht, oder wie legt man den fest?
Kann man von einem ScopeFolder-Objekt den Pfad festlegen, wie?
habe bis jetzt nur die möglichkeit realisiert meinen kompletten arbeitsplatz nach angegebenen(Name) ordnern zu durchsuchen und diese dann nach den jeweiligen dateien. möchte aber auch die möglichkeit einen ordner angeben zu können und dann in allen unterordnern nach dateien suchen. Es will mir nicht gelingen den ScopeFolder-Pfad festzulegen.
Ach so noch was, habe in der Werkzeugliste bei zusätliche Steuerelemente den
"search assistant control" gefunden der es scheinbar erlaubt den windows suchassistant komplett zu integrieren, nur wie?
Danke denjenigen die bis hierhin durchgehalten haben!
cu MB

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Dateisuche mit VBA
14.07.2005 12:55:56
Nepumuk
Servus,
wenn du was schnelleres findes, geb ich dir einen Kasten Bier aus:
Option Explicit

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 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 INVALID_HANDLE_VALUE = -1&
Private Const MAX_PATH = 260&

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 start()
    Dim myFileSystemObject As Object, myDrive As Object
    Dim lngFilecount As Long
    Application.ScreenUpdating = False
    Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
    lngFilecount = 0
    Columns(1).ClearContents
    For Each myDrive In myFileSystemObject.Drives
        If myDrive.IsReady Then
            FindFiles myDrive.DriveLetter & ":\", "*.xls", lngFilecount
        End If
    Next
    Set myFileSystemObject = Nothing
    Columns(1).AutoFit
    Application.ScreenUpdating = True
End Sub

Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String, _
        ByRef lngFilecount As Long)

    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strDirName As String
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        GetFilesInFolder strFolderPath, strSearch, lngFilecount
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                strDirName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
                If (strDirName <> ".") And (strDirName <> "..") Then _
                    FindFiles strFolderPath & strDirName & "\", strSearch, lngFilecount
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub

Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String, _
        ByRef lngFilecount As Long)

    Dim WFD As WIN32_FIND_DATA, lngSearch As Long, strFileName As String
    lngSearch = FindFirstFile(strFolderPath & strSearch, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> _
                FILE_ATTRIBUTE_DIRECTORY Then
                strFileName = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr(0)) - 1)
                lngFilecount = lngFilecount + 1
                Cells(lngFilecount, 1) = strFolderPath & strFileName
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub

Gruß
Nepumuk
Excel & VBA – Beispiele
Anzeige
für Nepumuk
14.07.2005 14:18:11
Borño
hola,
danke dir erst mal, wenn ich den code sehe, denke ich mir ich sollte den vba-level von vba-gut auf vba-(hab schon mal was gehört davon) umstellen.
kannst du mir vielleicht nochmal helfen, damit ich mit dem code klarkomme und zwar, wo und wie kann ich ein laufwerk(ordner) festlegen damit nur das durchsucht wird.
ist vielleicht ne blöde frage, brauch aber nen anhaltspunkt, dass ich mich schritt für schritt durcharbeiten kann und die eingaben aus meiner user.form reinbekomme.
danke nochmal und mit dem bier, ich glaub du kannst den selber trinken :)
cu MB
Dateien suchen schnell
14.07.2005 15:06:49
Nepumuk
Servus,
also, in der Routine "Start" (hab ich jetzt in "Start1" umbenannt) passiert folgendes:
Public Sub start1()
    Dim myFileSystemObject As Object, myDrive As Object
    Dim lngFilecount As Long
    Application.ScreenUpdating = False
    Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
    Columns(1).ClearContents
    For Each myDrive In myFileSystemObject.Drives 'alle Laufwerke
        If myDrive.IsReady Then 'wenn Datenträger eingelegt
            ' myDrive.DriveLetter gibt den Laufwerksbuchstaben zurück
            ' z.B. A für dein Floppy - Laufwerk
            FindFiles myDrive.DriveLetter & ":\", "*.xls", lngFilecount
        End If
    Next
    Set myFileSystemObject = Nothing
    Columns(1).AutoFit
    Application.ScreenUpdating = True
End Sub

Um einzelne Laufwerke / Ordner zu durchsuchen, ergänze das ganze mit dieser Routine:
Public Sub start2()
    Dim myFileSystemObject As Object, myDrive As Object
    Dim lngFilecount As Long
    Dim strFolder As String
    strFolder = Trim$(fncGetFolder())
    If strFolder <> "" Then
        If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
        Application.ScreenUpdating = False
        Columns(1).ClearContents
        FindFiles strFolder, "*.xls", lngFilecount
        Columns(1).AutoFit
        Application.ScreenUpdating = True
    End If
End Sub

Und lege ein zweites Modul an in das folgender Code kommt:
Option Explicit
Option Private Module

Private Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long

Private Type InfoT
    hwnd As Long
    Root As Long
    DisplayName As Long
    Title As Long
    Flags As Long
    FName As Long
    lParam As Long
    Image As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Enum BIF_Flag
    BIF_RETURNONLYFSDIRS = &H1
    BIF_DONTGOBELOWDOMAIN = &H2
    BIF_STATUSTEXT = &H4
    BIF_RETURNFSANCESTORS = &H8
    BIF_EDITBOX = &H10
    BIF_VALIDATE = &H20
    BIF_NEWDIALOGSTYLE = &H40
    BIF_BROWSEINCLUDEURLS = &H80
    BIF_BROWSEFORCOMPUTER = &H1000
    BIF_BROWSEFORPRINTER = &H2000
    BIF_BROWSEINCLUDEFILES = &H4000
    BIF_SHAREABLE = &H8000
End Enum

Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11

Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = &H1

Private s_BrowseInitDir As String

Public Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
        Optional ByVal sPath As String = "C:\") As String

    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
    s_BrowseInitDir = sPath
    With xl
        .hwnd = FindWindow("XLMAIN", vbNullString)
        .Root = 0
        .Title = lstrcat(sMsg, "")
        .Flags = lFlag
        .FName = FuncCallback(AddressOf BrowseCallback)
    End With
    IDList = SHBrowseForFolder(xl)
    If IDList <> 0 Then
        FolderName = Space(256)
        RVal = SHGetPathFromIDList(IDList, FolderName)
        CoTaskMemFree (IDList)
        FolderName = Trim$(FolderName)
        FolderName = Left$(FolderName, Len(FolderName) - 1)
    End If
    fncGetFolder = FolderName
End Function

Private Function BrowseCallback( _
        ByVal hwnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long

    If uMsg = BFFM_INITIALIZED Then
        Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir)
        Call CenterDialog(hwnd)
    End If
    BrowseCallback = 0
End Function

Private Function FuncCallback(ByVal nParam As Long) As Long
    FuncCallback = nParam
End Function

Private Sub CenterDialog(ByVal hwnd As Long)
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
    Dim DlgWidth As Integer, DlgHeight As Integer
    GetWindowRect hwnd, WinRect
    DlgWidth = WinRect.Right - WinRect.Left
    DlgHeight = WinRect.Bottom - WinRect.Top
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
    MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub

Gruß
Nepumuk
Excel & VBA – Beispiele
Anzeige
AW: Dateien suchen schnell
14.07.2005 15:38:35
Borño
hola,
ganz herzlichen dank, funktioniert einwandfrei. hab gerade nen härtetest gemacht auf einem 100GB laufwerk mit 14000 pdf´s. hat rund 5min gedauert aber ist nicht hängen geblieben! :)
eine bitte hät ich noch, kannst du noch ein paar tage dieses posting beobachten, falls ich noch ne frage zum code habe, danke.
cu MB
PostScriptum: www.excel-online.de ist ein guter tip!

306 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige