Ordner auswählen und alle xls-Datein öffnen
11.07.2003 23:32:38
Christoph
Ich möchte über einen CommandButton1 ein Verzeichnis auswählen. Über einen zweiten CommandButton sollen alle xls-Dateien des ausgewählten Ordners geöffnet werden.
(Diese sollen nicht nur geöffnet, sondern auch bearbeitet werden - das ist aber hier nicht relevant)
Mit Hilfe eures genialen Archivs habe ich auch denn Code zur Ordnerauswahl gefunden. Ebenso kann ich alle Dateien in einem fest vorgegebenen Pfad öffnen.
Mein Problem ist, wie kann ich den über CommandButton1 ausgewählten Pfad als Variable in das Sub von CommandButton2 übergeben?
Code zur Ordnerauswahl:
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
Dim arrFiles As Variant
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
Sub DirAuswahl()
Dim sMsg As String, sPath As String
sMsg = "Wählen Sie bitte einen Ordner aus:"
sPath = getdirectory(sMsg)
If sPath <> "" Then MsgBox sPath
End Sub
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
Code zum Öffnen der Dateien:
Sub Dateien_oeffnen()
Application.ScreenUpdating = False
Dim j As Integer
Dim arrFiles As Variant
Dim intCounter As Integer
Dim strPath As String
strPath = "D:\Test"
arrFiles = FileArray(strPath, "*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For intCounter = 1 To UBound(arrFiles)
Workbooks.Open strPath & arrFiles(intCounter)
' hier weitere Bearbeitungsschritte für jede Datei
'aktuelles Fenster schließen
Windows(arrFiles(intCounter)).Close
Next intCounter
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Private Function FileArray(strPath As String, strPattern As String)
Dim arrDateien()
Dim intCounter As Integer
Dim strDatei As String
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strDatei = Dir(strPath & strPattern)
Do While strDatei <> ""
intCounter = intCounter + 1
ReDim Preserve arrDateien(1 To intCounter)
arrDateien(intCounter) = strDatei
strDatei = Dir()
Loop
FileArray = arrDateien
End Function
schon vorab vielen Dank
Gruß Christoph