Open folder file dialog by API functions in VB.NET

• • Reply

  14 years ago

  by alpha24

  SON TRAN

  , Viet Nam

  Joined 14 years ago
  Imports Scripting
  Imports System.Text
  Imports System.Diagnostics
  Imports System.Runtime.InteropServices
  
  Module MdlFolderBrowser
  
      Public Structure BROWSEINFO
          Public hWndOwner As Integer
          Public pIDLRoot As Integer
          Public pszDisplayName As String
          Public lpszTitle As String
          Public ulFlags As Integer
          Public lpfn As fbCallBack   '***-trying to assign callback type
          Public lParam As IntPtr
          Public iImage As Integer
      End Structure
  
      Public Structure RECT
          Public Left As Integer
          Public Top As Integer
          Public Right As Integer
          Public Bottom As Integer
      End Structure
  
      Public Delegate Function fbCallBack(ByVal hWnd As Integer, ByVal uMsg As Integer, ByVal lParam As Integer, ByVal lpData As Integer) As Integer
  
      Private Const BFFM_INITIALIZED As Integer = 1
      Private Const BFFM_SELCHANGED As Integer = 2
      Private Const BIF_BROWSEINCLUDEFILES As Integer = &H4000
      Private Const BIF_DONTGOBELOWDOMAIN As Integer = &H2
      Private Const BFFM_SETSELECTIONA As Integer = (WM_USER + 102)
      Private Const BFFM_SETSTATUSTEXT As Integer = &H464
  
      'Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal addr As IntPtr)
      'Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
      'Public Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As IntPtr, ByVal lpBuffer As StringBuilder) As Integer
      'Public Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As Integer, ByVal lpBuffer As String) As Integer
      'Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (ByVal lpBrowseInfo As BROWSEINFO) As IntPtr
      'Public Declare Function SHSimpleIDListFromPath Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal szPath As String) As String
  
  #Region " Local DLL Declarations - .NET style "
      <DllImport("ole32.dll")> _
      Private Sub CoTaskMemFree(ByVal addr As IntPtr)
      End Sub
  
      <DllImport("user32.dll")> _
      Private Overloads Function SendMessage(ByVal hWnd As Integer, ByVal uMsg As Integer, ByVal lParam As Integer, ByVal lpData As String) As Integer
      End Function
  
      <DllImport("user32.dll")> _
      Private Overloads Function SendMessage(ByVal hWnd As IntPtr, ByVal uMsg As Integer, ByVal lParam As Integer, ByVal lpData As Integer) As Integer
      End Function
  
      <DllImport("shell32.dll", CharSet:=CharSet.Ansi)> _
      Private Function SHGetPathFromIDList(ByVal pidl As IntPtr, ByVal pszPath As StringBuilder) As Integer
      End Function
  
      <DllImport("shell32.dll", CharSet:=CharSet.Ansi)> _
      Private Function SHBrowseForFolder(ByRef lpBrowseInfo As BROWSEINFO) As IntPtr
      End Function
  
      <DllImport("shell32.dll", CharSet:=CharSet.Ansi)> _
      Private Function SHSimpleIDListFromPath(ByVal szPath As String) As String
      End Function
  
  #End Region
  
      Public Function BrowseCallBackProc(ByVal hWnd As Integer, ByVal uMsg As Integer, ByVal lParam As Integer, ByVal lpData As Integer) As Integer
  
          Try
              Select Case uMsg
                  Case BFFM_INITIALIZED
                      Call SendMessage(hWnd, BFFM_SETSELECTIONA, &H1, lpData)
                  Case BFFM_SELCHANGED
                      SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, lpData)
              End Select
          Catch Ex As Exception
              Throw Ex
          End Try
  
      End Function
  
      Private Function GetPIDLFromPath(ByVal sPath As String) As String
          Try
              GetPIDLFromPath = SHSimpleIDListFromPath(StrConv(sPath, VbStrConv.LowerCase))
          Catch ex As Exception
              Throw ex
          End Try
  
      End Function
  
      Public Function BrowseDirectory(ByVal InitialDir As String, ByVal hWnd As Integer) As String
          Dim lpIDList As IntPtr
          Dim sBuffer As StringBuilder
          Dim szTitle As String
          Dim tBrowseInfo As BROWSEINFO
          Dim iIntPtr As Integer
  
          Try
  
              BrowseDirectory = InitialDir
  
              szTitle = "Select a file to load"
  
              With tBrowseInfo
                  .hWndOwner = hWnd
                  .pIDLRoot = 0
                  .lpszTitle = szTitle
                  .ulFlags = BIF_RETURNONLYFSDIRS
                  .lpfn = AddressOf BrowseCallBackProc
                  .lParam = Marshal.StringToHGlobalAnsi(InitialDir)
                  .pszDisplayName = Space(MAX_PATH)
              End With
  
              '//(**) - Call CoTaskMemFree(tBrowseInfo.lParam)
  
              lpIDList = SHBrowseForFolder(tBrowseInfo)
  
              If Not lpIDList.Equals(IntPtr.Zero) Then
                  sBuffer = New StringBuilder(MAX_PATH)
                  If SHGetPathFromIDList(lpIDList, sBuffer) = 1 Then
                      BrowseDirectory = sBuffer.ToString
                  End If
              Else
                  BrowseDirectory = InitialDir
              End If
  
              '//(**) - CoTaskMemFree(tBrowseInfo.lParam)
              CoTaskMemFree(lpIDList)
  
          Catch Ex As Exception
              MsgBox(Ex.Source & ": " & Ex.Message)
          End Try
      End Function
  
      Private Function GetFSPath(ByVal pidl As IntPtr) As String
  
          Dim strPath As New StringBuilder(MAX_PATH)
  
          '// Checks if the pointer is invalid
          If pidl.Equals(IntPtr.Zero) Then
              Return ""
          Else
              '// Get the actual path from the list
              If SHGetPathFromIDList(pidl, strPath) = 1 Then
                  Return strPath.ToString()
              End If
          End If
  
      End Function
  
  End Module '// End Of Module.
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  
  Report abuse