vb.net2005 用API打开文件夹对话框和设定默认路径。

来源:互联网 发布:php javascript 编辑:程序博客网 时间:2024/06/04 18:41

新建一个窗体,添加一个textbox 和一个button,拷贝下面的代码。

 Imports System.Text
Imports System.Runtime.InteropServices

Public Class OpenFolder_OK

    Private Delegate Function fbCallBack(ByVal hWnd As Integer, ByVal uMsg As Integer, ByVal lParam As Integer, ByVal lpData As Integer) As Integer

    Private initpath As String = "C:/"

    Private Structure BROWSEINFO
        Dim hOwner As Integer
        Dim pidlRoot As Integer
        Dim pszDisplayName As String
        Dim lpszTitle As String
        Dim ulFlags As Integer
        Dim lpfn As fbCallBack
        Dim lParam As Integer
        Dim iImage As Integer
    End Structure

    Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (ByVal lpBrowseInfo As IntPtr) As Integer
    Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pIdl As Integer, ByVal pszPath As StringBuilder) As Integer
    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

    Private Const WM_USER As Integer = &H400
    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
    Private Const BIF_RETURNONLYFSDIRS As Integer = &H1

    Dim pnt As IntPtr
    Dim BIptr As IntPtr
    Dim pIdl As Integer

    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Try

            pnt = Nothing
            BIptr = Nothing
            pIdl = Nothing

            If Not My.Computer.FileSystem.DirectoryExists(initpath) Then
                MsgBox(initpath & " not exist")
                Exit Try
            End If

            Dim BI As BROWSEINFO
            Dim sPath As StringBuilder
            Dim txtPath As String

            With BI
                .hOwner = Me.Handle
                .pszDisplayName = Space(260)
                .lpszTitle = "Test"
                .ulFlags = BIF_RETURNONLYFSDIRS
                .lpfn = AddressOf BrowseCallBackProc
                .lParam = Marshal.StringToHGlobalAnsi(initpath)
            End With

            txtPath = ""
            BIptr = Marshal.AllocHGlobal(Marshal.SizeOf(BI))
            Marshal.StructureToPtr(BI, BIptr, False)

            pIdl = SHBrowseForFolder(BIptr)

            If pIdl = 0 Then Exit Try
            sPath = New StringBuilder(255)
            SHGetPathFromIDList(pIdl, sPath)

            txtPath = sPath.ToString
            TextBox1.Text = txtPath
            initpath = txtPath
            Marshal.FreeHGlobal(pIdl)

        Catch ex As Exception
            MsgBox(ex.ToString)
        Finally
            Marshal.FreeHGlobal(BIptr)
            Marshal.FreeHGlobal(pnt)
        End Try

    End Sub

    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

End Class

原创粉丝点击