steffen0815
VBA-Programmierer
Verfasst am:
30. Nov 2009, 14:45
Rufname: Steffen
Wohnort: bei Dresden
|
|
| Version: Office 97 |
|
Hallo Leute,
ich bin kein Freund der ab AC20xxx eingebauten Office-Filedialoge und setze selbst lieber die entsprechenden API-Funktionen ein.
Zur Auswahl eines Ordners gibt es schon etliche Codes hier im Forum.
Allerdings habe ich (auch im Netz) kein komplettes Beispiel gefunden, wo man die Konfigurationsmöglichkeiten nutzen kann.
Nachfolgender Code erweitert die einfache Ordnerauswahl um:
Einstellen eines Titels
Einstellen eines Startverzeichnisses
Einstellen eines Vorgabeverzeichnisses
Einstellen der Fensterposition  Hinweis für Office 97:
Hier muss noch die AFunktion AddressOf definiert werden (Link im Code enthalten)
Hinweis:
Dateiauswahldialog:GetOpenFileName
Dateierstellungsdialog:GetSaveFileName
Hier ein paar Beispiele für den Aufruf:
| Code: | Sub Beispiele()
Const BIF_NEWDIALOGSTYLE = &H40
Dim Ordnername As String
' ohne weiter Parameter
Ordnername = fncOrdnerauswahl
' Mit Titel und Startverzeichnis
Ordnername = fncOrdnerauswahl("Wählen Sie den Importordner" _
, "c:\Dokumente und Einstellungen")
' Mit Titel und Vorgabeverzeichnis
Ordnername = fncOrdnerauswahl("Wählen Sie den Importordner" _
, , "c:\Programme")
' Mit Positionierung
Ordnername = fncOrdnerauswahl(, , , 500, 500)
' Startordner und Möglichkeit Ordner anzulegen (Neuer Dialogstyle)
Ordnername = fncOrdnerauswahl(, "c:\Programme", , , , BIF_NEWDIALOGSTYLE)
End Sub |
Hier der komplette Code, welcher in ein neues Modul Namens "modOrdnerauswahl" kopiert werden sollte:
| Code: | Option Compare Database
Option Explicit
Private 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
Private Type RECT
Left As Long
Top As Integer
Right As Long
Bottom As Long
End Type
Const BIF_BROWSEFORCOMPUTER = &H1000
Const BIF_BROWSEFORPRINTER = &H2000
Const BIF_BROWSEINCLUDEFILES = &H4000
Const BIF_BROWSEINCLUDEURLS = &H80
Const BIF_DONTGOBELOWDOMAIN = &H2
Const BIF_EDITBOX = &H10
Const BIF_NEWDIALOGSTYLE = &H40
Const BIF_NONEWFOLDERBUTTON = &H200
Const BIF_RETURNFSANCESTORS = &H8
Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_SHAREABLE = &H8000
Const BIF_STATUSTEXT = &H4
Const BIF_UAHINT = &H100
Const BIF_USENEWUI = &H40
Const BIF_VALIDATE = &H20
Const BFFM_INITIALIZED = 1
Const BFFM_SETSELECTIONA As Long = (&H400 + 102)
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long _
, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "OLE32.dll" (ByVal pv As Long)
Private Declare Function ILCreateFromPath Lib "shell32" Alias _
"#157" (ByVal sPath As String) As Long
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long _
, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetWindowRect Lib "user32.dll" _
(ByVal hwnd As Long, lpRect As RECT) As Long
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 DialogXPos As Long, DialogYPos As Long
Public Function fncOrdnerauswahl(Optional Title, _
Optional StartVerzeichnis, _
Optional DefaultVerzeichnis, _
Optional xPos As Long = -1, _
Optional yPos As Long = -1, _
Optional Art As Long _
) As String
Const MAXPATH As Long = 260
Dim uBrowseInfo As BROWSEINFO
Dim sPath As String
Dim lPidl As Long
With uBrowseInfo
.hOwner = GetActiveWindow()
.pidlRoot = IIf(IsMissing(StartVerzeichnis), 0&, PathToPIDL(StartVerzeichnis))
.ulFlags = IIf(IsMissing(Art), BIF_RETURNONLYFSDIRS, Art)
.lpszTitle = IIf(IsMissing(Title), "Bitte wählen Sie ein Verzeichnis", Title)
.lpfn = FARPROC(AddressOf BrowseCallbackProc)
' bei office97 Hilfsfunktion notwendig
' http://www.ms-office-wissen.de/askdrmof/details.php?id=45
'.lpfn = FARPROC(AddressOf97("BrowseCallbackProc"))
.lParam = IIf(IsMissing(DefaultVerzeichnis), 0&, PathToPIDL(DefaultVerzeichnis))
End With
' Fensterposition übergeben
DialogXPos = xPos: DialogYPos = yPos
lPidl = SHBrowseForFolder(uBrowseInfo)
sPath = Space(MAXPATH)
If SHGetPathFromIDList(ByVal lPidl, ByVal sPath) Then
fncOrdnerauswahl = Left(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call CoTaskMemFree(lPidl)
End Function
' Hilfsfunktionen
Private Function PathToPIDL(ByVal sPath As Variant) As Long
Dim lRet As Long
If IsMissing(sPath) Then Exit Function
lRet = ILCreateFromPath(sPath)
If lRet = 0 Then
sPath = StrConv(sPath, VbStrConv.vbUnicode)
lRet = ILCreateFromPath(sPath)
End If
PathToPIDL = lRet
End Function
Private Function FARPROC(FunctionPointer As Long) As Long
FARPROC = FunctionPointer
End Function
Private Function BrowseCallbackProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long _
) As Long
Dim WKoo As RECT
GetWindowRect hwnd, WKoo
MoveWindow hwnd, IIf(DialogXPos = -1, WKoo.Top, DialogXPos), _
IIf(DialogYPos = -1, WKoo.Top, DialogYPos), _
WKoo.Right - WKoo.Left, WKoo.Bottom - WKoo.Top, 1
Select Case uMsg
Case BFFM_INITIALIZED ' Dialog wurde initialisiert
Call SendMessage(hwnd, BFFM_SETSELECTIONA, 0&, ByVal lpData)
End Select
End Function |
Code ist getestet unter AC97 und AC2003
Falls jemand einen ähnlichen verlinkbaren Code findet, bitte melden, dann kann man den hier löschen.
_________________
Gruß Steffen
|
|
