全部
Ada助手

打开浏览文件夹对话框时可以增加"新建文件夹"的功能

redwrite 2005-08-07 11:14:31

使用SHBrowseForFolder API打开浏览文件夹对话框时，可以增加"新建文件夹"的功能吗
我记得有些软件有这样的功能，但是我却一点办法也没有，哪位大侠能帮我，谢谢。

...全文

给本帖投票

405 3 打赏收藏转发到动态举报

写回复

用AI写文章

为什么非要加了断点然后逐语句的运行才起作用？？？>>

3 条回复

切换为时间正序

请发表友善的回复…

发表回复

threenewbee 2005-08-08

打赏
举报

BIF_USENEWUI
Version 5.0. Use the new user interface, including an edit box. This flag is equivalent to BIF_EDITBOX | BIF_NEWDIALOGSTYLE. To use BIF_USENEWUI, you must call OleInitialize or CoInitialize before calling SHBrowseForFolder.

redwrite 2005-08-08

打赏
举报

谢谢

留下些什么 2005-08-08

打赏
举报

Private Sub Command1_Click()
s = BrowseForFolder(Me.hwnd, "fff", , NEWFOLDER)
End Sub

'模块
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