title image


Smiley Re: bei Api zur Verzeichnisauswahl Verzeichnis vorgeben
Hallo,



'===========================================================================================''    Dim sFolder As String'    sFolder = BrowseForFolder(Me, "Bitte wählen Sie einen Ordner:", "C:\Vorgegebener\Pfad")'    If Len(sFolder) = 0 Then Exit Sub 'Bei Cancel abbrechen''===========================================================================================Option ExplicitPrivate Const BIF_STATUSTEXT = &H4&Private Const BIF_RETURNONLYFSDIRS = 1Private Const BIF_DONTGOBELOWDOMAIN = 2Private Const BIF_NEWDIALOGSTYLE = &H40Private Const BIF_EDITBOX = &H10Private Const MAX_PATH = 260Private Const WM_USER = &H400Private Const BFFM_INITIALIZED = 1Private Const BFFM_SELCHANGED = 2Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)Private Const BFFM_SETSELECTION = (WM_USER + 102)Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As LongPrivate Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As LongPrivate Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As LongPrivate Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As LongPrivate Type BrowseInfo  hWndOwner      As Long  pIDLRoot       As Long  pszDisplayName As Long  lpszTitle      As Long  ulFlags        As Long  lpfnCallback   As Long  lParam         As Long  iImage         As LongEnd TypePrivate m_CurrentDirectory As String   'Aktueller OrdnerPublic Function BrowseForFolder(ByVal Owner As Form, ByVal Title As String, ByRef StartDir As String) As String   Dim lpIDList    As Long   Dim sBuffer     As String   Dim tBrowseInfo As BrowseInfo   m_CurrentDirectory = StartDir & vbNullChar   With tBrowseInfo      .hWndOwner = Owner.hWnd      .lpszTitle = lstrcat(Title, "")      .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT + BIF_NEWDIALOGSTYLE + BIF_EDITBOX      .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc)   End With   lpIDList = SHBrowseForFolder(tBrowseInfo)   If (lpIDList) Then      sBuffer = Space(MAX_PATH)      SHGetPathFromIDList lpIDList, sBuffer      sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)      BrowseForFolder = sBuffer   Else      BrowseForFolder = ""   End IfEnd FunctionPrivate Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long   Dim lpIDList As Long   Dim ret      As Long   Dim sBuffer  As String   On Error Resume Next   Select Case uMsg      Case BFFM_INITIALIZED         Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)      Case BFFM_SELCHANGED         sBuffer = Space(MAX_PATH)         ret = SHGetPathFromIDList(lp, sBuffer)         If ret = 1 Then            Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)         End If   End Select   BrowseCallbackProc = 0End FunctionPrivate Function GetAddressofFunction(add As Long) As Long   GetAddressofFunction = addEnd Function

Mit freundlichen Grüßen

AndyG

E-Mail:  Andreas_Graf [öt] DevPlanet.de
Homepage:  http://www.DevPlanet.de



geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: