Ordnerauswahl unter W95 & VBA

Computer: Software & Programmierung Programmierung allgemein
1

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

2

Vielen Dank!

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]

3

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]

4

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

5

… noch’n Versuch…
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

6

‚StrSubs‘ fehlt noch
Function StrSubs(s, Subs, Optional Repl = „“, Optional N = 0)
’
’ Teilzeichenkette durch

7

Diesen Tag (s in spitzen Klammern) kannte ich noch gar nicht…

)))

Gruß Tobias

8
  • Tag
    Gerade in den Politikbrettern könnte der wunderschön zur Geltung kommen ;=)

Reinhard