Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Ordnerauswahldialog mit Konfigurationsmöglichkeiten
zurück: Mehrzweck-Kalender & Feiertage weiter: Datenmodell entwickeln: Welche Tabellen und Beziehungen? Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Tutorial Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
steffen0815
VBA-Programmierer


Verfasst am:
30. Nov 2009, 14:45
Rufname:

Ordnerauswahldialog mit Konfigurationsmöglichkeiten - Ordnerauswahldialog mit Konfigurationsmöglichkeiten

Nach oben
       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
Idea 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
Idea 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
Gast



Verfasst am:
08. Dez 2009, 12:24
Rufname:


AW: Ordnerauswahldialog mit Konfigurationsmöglichkeiten - AW: Ordnerauswahldialog mit Konfigurationsmöglichkeiten

Nach oben
       Version: Office 97

Diese Lösung habe ich schon länger gesucht.
Lieben Dank dafür.
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: CSS Forum