当前位置: 网学 > 编程文档 > VB > 正文

vb带新建文件夹的文件夹浏览BrowseForFolder

来源:Http://myeducs.cn 联系QQ:点击这里给我发消息 作者: 用户投稿 来源: 网络 发布时间: 12/10/16
下载{$ArticleTitle}原创论文样式

Option Explicit

Private Type BROWSEINFOTYPE
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 LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBROWSEINFOTYPE As BROWSEINFOTYPE) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Private Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Private Const LPTR = (&H0 Or &H40)

Public Enum BROWSETYPE
NONE = 0
PATHTEXT = 16
NEWFOLDER = 64
End Enum

Private Sub BrowseCallbackProcStr(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long)
If uMsg = 1 Then
Call SendMessage(hwnd, BFFM_SETSELECTIONA, True, ByVal lpData)
End If
End Sub

Private Function FunctionPointer(FunctionAddress As Long) As Long
FunctionPointer = FunctionAddress
End Function

Public Function BrowseForFolder(ByVal hwnd As Long, ByVal strTitle As String, Optional selectedPath As String, Optional ByVal Flag As BROWSETYPE = 0) As String
Dim Browse_for_folder As BROWSEINFOTYPE
Dim itemID As Long
Dim selectedPathPointer As Long
Dim tmpPath As String * 256

If selectedPath = "" Then selectedPath = "" ''避免selectedPath未初始化而出错

If Not Right(selectedPath, 1) <> "\" Then
selectedPath = Left(selectedPath, Len(selectedPath) - 1) ''如果用户加了 "\" 则删除
End If

With Browse_for_folder
.hOwner = hwnd ''所有都窗口之句柄
.lpszTitle = strTitle ''对话框的标题
.ulFlags = Flag
.lpfn = FunctionPointer(AddressOf BrowseCallbackProcStr) ''用于设置预设文件夹的回调函数
selectedPathPointer = LocalAlloc(LPTR, Len(selectedPath) + 1) ''分配一个字符串内存
Call CopyMemory(ByVal selectedPathPointer, ByVal selectedPath, Len(selectedPath) + 1) '' 拷贝那个路径到内存
.lParam = selectedPathPointer '' 预设的文件夹
End With
itemID = SHBrowseForFolder(Browse_for_folder) ''执行API函数:BrowseForFolder
If itemID Then
If SHGetPathFromIDList(itemID, tmpPath) Then ''取得选定的文件夹
BrowseForFolder = Left(tmpPath, InStr(tmpPath, vbNullChar) - 1) ''去掉多余的 null 字符
End If
Call CoTaskMemFree(itemID) ''释放内存
End If
Call LocalFree(selectedPathPointer) ''释放内存
End Function 

 

  • 下一篇资讯: VB操作Excel详解
  • 网学推荐

    免费论文

    原创论文

    浏览:
    设为首页 | 加入收藏 | 论文首页 | 论文专题 | 设计下载 | 网学软件 | 论文模板 | 论文资源 | 程序设计 | 关于网学 | 站内搜索 | 网学留言 | 友情链接 | 资料中心
    版权所有 QQ:3710167 邮箱:3710167@qq.com 网学网 [Myeducs.cn] 您电脑的分辨率是 像素
    Copyright 2008-2015 myeducs.Cn www.myeducs.Cn All Rights Reserved
    湘ICP备09003080号