API / Verzeichnis auswählen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo

'
'   05/10/2003
'©  Ing.Friedrich Grath
'@  grath.fritz@ aon.at
'

Option Explicit

' Benötigte API-Deklarationen
Private 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 Long
End Type

Private Const MAX_PATH = 260
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = 1

Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
  (ByVal hMem As Long)

Private Declare Function lstrcat Lib "kernel32" Alias _
  "lstrcatA" (ByVal lpString1 As String, _
  ByVal lpString2 As String) As Long

Private Declare Function GetActiveWindow Lib "user32" () As Long

Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
  ByVal pidList As Long, _
  ByVal lpBuffer As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32" ( _
  lpbi 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 m_BrowseInitDir As String

'Soll im Ordnerauswahl-Dialog z.B. das Anwendungsverzeichnis Ihres
'Programms vorselektiert werden, rufen Sie die BrowseForFolder-Funktion
'wie folgt auf:
Sub Dialog_aufrufen()
Dim sPath As String

sPath = BrowseForFolder("Bitte Ordner auswählen", "C:\temp")
If sPath <> "" Then
  MsgBox sPath
End If

End Sub

' Ordnerauswahl-Dialog mit optionaler
' Angabe eines Startverzeichnisses
Public Function BrowseForFolder(ByVal sPrompt As String, _
  Optional ByVal sInitDir As String) As String

  Dim nPos As Long
  Dim nIDList As Long
  Dim sPath As String
  Dim oInfo As BrowseInfo

  m_BrowseInitDir = sInitDir

  ' Datenstruktur füllen
  With oInfo
    .hWndOwner = GetActiveWindow()
    .lpszTitle = lstrcat(sPrompt, "")
    .ulFlags = BIF_RETURNONLYFSDIRS
    If sInitDir <> "" Then
      ' Callback-Funktionsadresse
      .lpfnCallback = FuncCallback(AddressOf BrowseCallback)
    End If
  End With

  ' Dialog anzeigen und auswerten
  nIDList = SHBrowseForFolder(oInfo)
  If nIDList Then
    sPath = String$(MAX_PATH, 0)
    Call SHGetPathFromIDList(nIDList, sPath)
    Call CoTaskMemFree(nIDList)
    nPos = InStr(sPath, vbNullChar)
    If nPos Then sPath = Left$(sPath, nPos - 1)
  End If

  BrowseForFolder = sPath
End Function
Private Function BrowseCallback(ByVal hWnd As Long, _
  ByVal uMsg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As Long) As Long

  Select Case uMsg
    Case BFFM_INITIALIZED
      ' Start-Ordner
      Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal 1&, _
        ByVal m_BrowseInitDir)
  End Select
  BrowseCallback = 0
End Function
' Hilfsfunktion für AddressOf
Private Function FuncCallback(ByVal nParam As Long) As Long
  FuncCallback = nParam
End Function

Code eingefügt mit Syntaxhighlighter 2.4

mfg, GraFri

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread