求带有新建功能的目录浏览对话框代码,急用,谢谢

[leaxin]

找了很久没找到,请各位帮帮忙

[hisofty]

BrowseForFolder函数，看看他的参数，其中有一个，不难的

[leaxin]

BrowseForFolder

[leaxin]

是什么函数,在哪里可以找得到?

[TechnoFantasy]

Module:

Option Explicit

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

Public Enum DialogStyle
BIF_BROWSEFORCOMPUTER = &H1000
BIF_BROWSEFORPRINTER = &H2000
BIF_BROWSEINCLUDEFILES = &H4000
BIF_DONTGOBELOWDOMAIN = &H2
BIF_EDITBOX = &H10
BIF_NEWDIALOGSTYLE = &H40
BIF_RETURNFSANCESTORS = &H8
BIF_RETURNONLYFSDIRS = &H1
BIF_STATUSTEXT = &H4
BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
End Enum

Private Const MAX_PATH = 260

Private Type SHITEMID
cb As Long
abID As Byte
End Type

Private Type ITEMIDLIST
mkid As SHITEMID
End Type

Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

Global m_sCurrentDirectory As String

Public Function BrowseForFolder(ByVal OwnerHwnd As Long, ByVal Title As String, Optional StartDir As String = "", Optional DStyle As DialogStyle = BIF_RETURNONLYFSDIRS + BIF_STATUSTEXT) As String
Dim lpIDList As Long
Dim szTitle As String
Dim sBuffer As String
Dim tBrowseInfo As BrowseInfo

If StartDir = "" Then StartDir = App.Path

m_sCurrentDirectory = StartDir & vbNullChar
BrowseForFolder = ""

szTitle = Title
With tBrowseInfo
.hWndOwner = OwnerHwnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = DStyle
.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function.
End With

lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
BrowseForFolder = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
End If
End Function

Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long

Dim lpIDList As Long
Dim ret As Long
Dim sBuffer As String

On Error Resume Next

Select Case uMsg
Case BFFM_INITIALIZED
Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_sCurrentDirectory)

Case BFFM_SELCHANGED
sBuffer = Space(MAX_PATH)

ret = SHGetPathFromIDList(lp, sBuffer)
If ret = 1 Then Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
End Select

BrowseCallbackProc = 0

End Function

Private Function GetAddressofFunction(add As Long) As Long
GetAddressofFunction = add
End Function

[TechnoFantasy]

调用：
BrowseForFolder Me.hWnd, "GGG", "c:\windows", BIF_NEWDIALOGSTYLE

只要加上BIF_NEWDIALOGSTYLE标记就可以实现创建新文件夹了。

[liyd1978]

Option Explicit
Option Base 1

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Public Function SelectFile() As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String

OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = frmRegisterSelectFile.hWnd
OpenFile.lpstrTitle = "オープンファイル"
OpenFile.hInstance = App.hInstance
sFilter = "All Files (*.*)" & Chr(0) & "*.*" & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = App.Path
OpenFile.lpstrTitle = "選択ファイル"
OpenFile.Flags = 0
lReturn = GetOpenFileName(OpenFile)

If lReturn = 0 Then
'MsgBox "操作を取り消し"
'OpenFileClass = "0"
Else
SelectFile = Trim(OpenFile.lpstrFile)
End If

End Function