Hallo Phreaks,
ich möchte in einem VBA-Makro den Benutzer ein Verzeichnis auswählen lassen. Würde mich sehr wundern, wenn es für diese allbekannte Dialogbox keinen API-Aufruf gaebe. Ich würde mich sehr um ein zwei Zeilen Code freuen,
Euer Dennis
[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]
Hier zwei Zeilen:
Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Ich mail dir den übrigen Code, weil das drumherum doch ein wenig komplizierter ist.
Gruß Tobias
[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]
Einen echten Ordnerdialog hab ich leider nicht, der Dateiauswahldialog geht so:
Option Explicit
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Public Const OFN_READONLY = &H1
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_FILEMUSTEXIST = &H1000
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Public Function FileDialog(Optional OpenSave As Boolean = True, _
Optional Titel As String, Optional Filter As String, _
Optional DefExtension As String, Optional AktDir As String, _
Optional Flags As Long) As String
On Error GoTo FErr
Dim Res As Long, OpenDlg As OPENFILENAME, Dateiname As String
Dateiname = String$(512, 0)
With OpenDlg
If IsMissing(Titel) Then
If OpenSave Then
.lpstrTitle = "Datei öffnen" & Chr$(0)
Else
.lpstrTitle = "Datei speichern unter" & Chr$(0)
End If
Else
.lpstrTitle = Titel & Chr$(0)
End If
If IsMissing(Filter) Then
.lpstrFilter = "Alle Dateien" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
Else
If InStr(Filter, "|") : 0 Then
.lpstrFilter = StrSubs(Filter, "|", Chr$(0)) & Chr$(0)
Else
.lpstrFilter = Filter & Chr$(0)
End If
End If
If IsMissing(DefExtension) Then
.lpstrDefExt = Chr$(0)
Else
.lpstrDefExt = DefExtension & Chr$(0)
End If
If IsMissing(AktDir) Then
.lpstrInitialDir = CurDir$ & Chr$(0)
Else
.lpstrInitialDir = AktDir & Chr$(0)
End If
If IsMissing(Flags) Then
If OpenSave Then
.Flags = OFN_FILEMUSTEXIST Or OFN_READONLY ' bzw. HideReadOnly
Else
.Flags = 0
End If
Else
.Flags = Flags
End If
.lStructSize = Len(OpenDlg)
.hwndOwner = 0
On Error Resume Next
.hwndOwner = Screen.ActiveForm.hWnd
On Error GoTo FErr
.nFilterIndex = 1
.lpstrFile = Dateiname
.nMaxFile = Len(Dateiname)
If OpenSave Then
Res = GetOpenFileName(OpenDlg)
Else
Res = GetSaveFileName(OpenDlg)
End If
If Res <: 0 Then
FileDialog = left$(.lpstrFile, InStr(.lpstrFile, Chr$(0)) - 1)
Else
FileDialog = ""
End If
End With
FExit:
On Error Resume Next
Exit Function
FErr:
MsgBox error$
Resume FExit
End Function
Ich hoffe, jetzt ist's lesbar:
Function StrSubs(s, Subs, Optional Repl = "", Optional N = 0)
'
' Teilzeichenkette [Subs] in Zeichenkette durch [Repl] ersetzen
' Ersetzung maximal [n] mal ausführen, wenn n groesser 0, sonst alle ersetzen
'
Dim FPos As Integer, I As Integer
Dim Res As String
On Error GoTo Err_StrSubs
If IsNull(s) Then StrSubs = Null: Exit Function
If IsNull(Subs) Or Subs = "" Then StrSubs = s: Exit Function
Res = s
I = 0
FPos = InStr(1, Res, Subs)
Do While FPos : 0
I = I + 1
If N : 0 And I : N Then Exit Do
If FPos : 1 Then
Res = Mid(Res, 1, FPos - 1) & Repl & Mid(Res, FPos + Len(Subs), 32000)
Else
Res = Repl & Mid(Res, FPos + Len(Subs), 32000)
End If
FPos = InStr(FPos + Len(Repl), Res, Subs)
Loop
StrSubs = Res
Exit_StrSubs:
Exit Function
Err_StrSubs:
MsgBox error$
Resume Exit_StrSubs
End Function
Function StrSubs(s, Subs, Optional Repl = "", Optional N = 0)
'
' Teilzeichenkette <Subs: in Zeichenkette <s> durch <Repl: ersetzen
' Ersetzung maximal <n: mal ausführen, wenn n : 0, sonst alle ersetzen
'
Dim FPos As Integer, I As Integer
Dim Res As String
On Error GoTo Err_StrSubs
If IsNull(s) Then StrSubs = Null: Exit Function
If IsNull(Subs) Or Subs = "" Then StrSubs = s: Exit Function
Res = s
I = 0
FPos = InStr(1, Res, Subs)
Do While FPos : 0
I = I + 1
If N : 0 And I : N Then Exit Do
If FPos : 1 Then
Res = Mid(Res, 1, FPos - 1) & Repl & Mid(Res, FPos + Len(Subs), 32000)
Else
Res = Repl & Mid(Res, FPos + Len(Subs), 32000)
End If
FPos = InStr(FPos + Len(Repl), Res, Subs)
Loop
StrSubs = Res
Exit_StrSubs:
Exit Function
Err_StrSubs:
MsgBox error$
Resume Exit_StrSubs
End Function
