Thema: Dateistrukturen in UserForm einlesen und Datei öffnen

ClassModule: frmFiles

Private Sub cboDirectories_Change()
   Dim fs As FileSearch
   Dim intCounter As Integer, iRow As Integer
   Dim sDir As String
   Columns("C").Clear
   cboFiles.Clear
   Set fs = Application.FileSearch
   With fs
      .LookIn = cmdEinlesen.Tag & cboDirectories.Value
      .FileName = "*.*"
      .Execute
      For intCounter = 1 To .FoundFiles.Count
         cboFiles.AddItem FileName(.FoundFiles(intCounter))
         Cells(intCounter, 3).Value = FileName(.FoundFiles(intCounter))
      Next intCounter
      If .FoundFiles.Count > 0 Then cboFiles.ListIndex = 0
   End With
End Sub

Private Function FileName(strName As String) As String
   Dim intCounter As Integer
   For intCounter = Len(strName) To 1 Step -1
      If Mid(strName, intCounter, 1) = "\" Then Exit For
   Next intCounter
   FileName = Right(strName, Len(strName) - intCounter)
End Function

Private Sub cmdCancel_Click()
   Unload Me
End Sub

Private Sub cmdEinlesen_Click()
   Dim iRow As Integer
   Dim sDir As String, sFile As String
   Columns("A:B").ClearContents
   sDir = GetDirectory("Bitte Verzeichnis auswählen:")
   If sDir = "" Then Exit Sub
   If Right(sDir, 1) <> "\" Then sDir = sDir & "\"
   Range("A1").Value = sDir
   cmdEinlesen.Tag = sDir
   sFile = Dir(sDir & "*.*", vbDirectory)
   Do While sFile <> ""
      If sFile = "." Or sFile = ".." Then
      ElseIf (GetAttr(sDir & sFile) And _
         vbDirectory) = vbDirectory Then
         cboDirectories.AddItem sFile
         iRow = iRow + 1
         Cells(iRow, 2).Value = sFile
      End If
      sFile = Dir()
   Loop
   If cboDirectories.ListCount > 0 Then
      cboDirectories.ListIndex = 0
      cmdOK.Enabled = True
      cmdEinlesen.Enabled = False
   End If
End Sub

Private Sub cmdOK_Click()
   Shell "explorer " & cmdEinlesen.Tag & _
      cboDirectories.Value & "\" & cboFiles.Value
   Unload Me
End Sub

StandardModule: basFunctions

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 = "Wählen Sie bitte einen Ordner aus."
   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

StandardModule: basMain

Sub DialogAufruf()
   frmFiles.Show
End Sub

Beiträge aus dem Excel-Forum zu den Themen Dialog und ComboBox