Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1012to1016
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
Datein aus Ordner in Listbox
30.09.2008 12:45:47
Markus
Hallo,
brauch wieder mal eure Hilfe.
Möchte über ein UserForm nach bestimmte Dateien eines Ordners inkl. Unterordner suchen.
Button: Ordner wählen öffnet Msg Box such dort mein Ordner aus klappt schon.
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare

Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare 

Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long


Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Bitte einen Ordner auswählen."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function


Mein Problem möchte das auch die Unterordner bei der Suche mit einbezogen werden.
Möchte nach bestimmten Dateien in den Ordnern suchen und die in einer Listbox aufgelistet haben.
Userbild
DANKE schonmal

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Datein aus Ordner in Listbox
30.09.2008 15:00:20
Tino
Hallo,
hier mal eine Version, diese liest den Pfad+Dateien in ein Area und gibt diese dann in der Listbox aus.
Der Originalcode stammt von Nepumuk!
kommt in UserForm1
'Benötigt UserForm mit den Namen UserForm1 
'eine Befehlsschaltfleche mit den Namen CommandButton1 
'ein Listenfeld mit den Namen ListBox1 
Option Explicit 
Private Sub CommandButton1_Click() 
Dim a As Long 
'erster Parameter Optional Suche nach 
'"*.xls" Exceldateien, "*.jpg" Bilder usw. 
'lässt man diesen aus, werden alle gesucht 
'Beispiel: SucheDateien( , True) 
'___________________________________________________
'zweiter Parameter Optional True mit Unterordner,False = ohne 
'lässt man diesen aus wird nicht in Unterordner gesucht 
Call SucheDateien("*.xls", True) 
     
    For a = Lbound(strDateien) To Ubound(strDateien) 
     Me.ListBox1.AddItem strDateien(a) 
    Next a 
 Erase strDateien 
End Sub 
 


kommt in ein Modul

Option Explicit 
Option Private Module 
 
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 
 
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 strDateien() 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 
 
Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String, _
        ByRef lngFilecount As Long, Optional Subfolder As Boolean = True) 
    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 Subfolder = False Then Exit Sub 'ohne Unterordner 
                If (strDirName <> ".") And (strDirName <> "..") Then _
                    FindFiles strFolderPath & strDirName & "\", strSearch, lngFilecount 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
End Sub 
 
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) 
                 Redim Preserve strDateien(lngFilecount) 
                    strDateien(lngFilecount) = strFolderPath & strFileName 
                    lngFilecount = lngFilecount + 1 
            End If 
        Loop While FindNextFile(lngSearch, WFD) 
        FindClose lngSearch 
    End If 
End Sub 
 Sub SucheDateien(Optional strSearch As String = "*", Optional Subfolder As Boolean = False) 
    Dim myFileSystemObject As Object, myDrive As Object 
    Dim lngFilecount As Long 
    Dim strFolder As String 
    Dim Pfad As String 
     
    strFolder = Trim$(fncGetFolder(sPath:="C:\")) 
    If strFolder <> "" Then 
        If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\" 
        Application.ScreenUpdating = False 
        FindFiles strFolder, strSearch, lngFilecount, Subfolder 
    End If 
End Sub 
 


Gruß Tino

www.VBA-Excel.de


Anzeige

302 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige