MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Access & Datenbanken > Microsoft Access - Code Archiv
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

 
Ads
Themen-Optionen Ansicht
Alt 28.12.2002, 10:29   #1
Günther Kramer
MS-Office-Forum Team MS-Office-Forum Team
Nachricht Codebeispiel - Verzeichnisauswahldialog für Access 97



Mit dieser Funktion stellen Sie einen Auswahldialog zur Verfügung, mit dessen Hilfe der Anwender ein gewünschtes Verzeichnis auswählen kann. Der Verzeichnispfad wird als String an die Funktion zurückgegeben.
Die besonderheit bei diesem Beispiel ist, dass man hier auch ein Startverzeichnis angeben kann.

Erstellen Sie ein neues Modul und fügen Sie nachfolgenden Code ein:

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 Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
 
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
            (ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) _
            As Long
 
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = 1
 
Global StartDir As String
 
Public Function VerzeichnisSuchen(szDialogTitle As String, _
                StartVerzeichnis As String) As String
 
  Dim X         As Long
  Dim bi        As BROWSEINFO
  Dim dwIList   As Long
  Dim szPath    As String
  Dim wPos      As Integer
 
  StartDir = StartVerzeichnis
 
  With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lpfn = DummyFunc(AddrOf("BrowseCallbackProc"))
    End With
 
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
 
    If X Then
        wPos = InStr(szPath, Chr(0))
        VerzeichnisSuchen = Left$(szPath, wPos - 1)
    Else
        VerzeichnisSuchen = ""
    End If
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, _
                ByVal lParam As Long, ByVal lpData As Long) As Long
 
    Dim pathstring  As String
    Dim retval      As Long
 
    Select Case uMsg
        Case BFFM_INITIALIZED
            pathstring = StartDir '"C:\Temp"
            retval = SendMessage(hWnd, BFFM_SETSELECTION, _
                     ByVal CLng(1), ByVal pathstring)
    End Select
 
    BrowseCallbackProc = 0
 
End Function
Public Function DummyFunc(ByVal param As Long) As Long
 
    DummyFunc = param
 
End Function
Da Access 97 die Funktion AddressOf nicht kennt, müssen Sie nur für die Access 97-Version ein zweites Modul erstellen. Kopieren Sie die folgenden Codezeilen in das neue Modul.

Code:

Option Compare Database
Option Explicit
 
Private Declare Function GetCurrentVbaProject Lib "vba332.dll" Alias _
"EbGetExecutingProj" (hProject As Long) As Long
 
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hProject As Long, ByVal strFunctionName As String, ByRef _
strFunctionId As String) As Long
 
Private Declare Function GetAddr Lib "vba332.dll" Alias _
"TipGetLpfnOfFunctionId" (ByVal hProject As Long, ByVal strFunctionId As _
String, ByRef lpfn As Long) As Long
 
Public Function AddrOf(strFuncName As String) As Long
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
 
Const NO_ERROR = 0
 
' The function name must be in Unicode, so convert it.
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
 
' Get the current VBA project
' The results of GetCurrentVBAProject seemed inconsistent, in our tests,
' so now we just check the project handle when the function returns.
Call GetCurrentVbaProject(hProject)
 
' Make sure we got a project handle... we always should, but you never know!
If hProject <> 0 Then
    ' Get the VBA function ID (whatever that is!)
    lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)
 
    ' We have to check this because we GPF if we try to get a function pointer
    ' of a non-existent function.
    If lngResult = NO_ERROR Then
        ' Get the function pointer.
        lngResult = GetAddr(hProject, strID, lpfn)
 
        If lngResult = NO_ERROR Then
            AddrOf = lpfn
        End If
    End If
End If
 
End Function
Um den Dialog aufzurufen und das Ergebnis einem Feld innerhalb des Formulars zurückzugeben erstellen Sie bitte eine Schaltfläche mit dem Namen Verzeichnisauswahl. Der im Beispiel verwendete Namen für das Feld, in welches der Verzeichnispfad zurückgeschrieben wird, lautet Verzeichnis. Beide Namen (Schaltfläche & Feld) können Sie natürlich anders benennen.

Code:

Private Sub Verzeichnisauswahl_Click()
 
    Dim strVerzeichnisName As String
 
    If IsNull(Me!Verzeichnis) Then
        Me!Verzeichnis = ""
    End If
 
    strVerzeichnisName = VerzeichnisSuchen _
        ("Wählen Sie bitte das Verzeichnis aus!", Me!Verzeichnis)
 
    If ((Not IsNull(strVerzeichnisName)) And (strVerzeichnisName <> "")) Then
        Me!Verzeichnis = strVerzeichnisName
    End If
 
End Sub
Angehängte Dateien
Dateityp: zip ap_verzeichnisauswahldialog_erweitert_a97.zip (54,1 KB, 196x aufgerufen)

__________________

Gruß, Günther


Tools und Lösungen für Microsoft Access
Günther Kramer ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
 


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 14:58 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.