1,451
社区成员
发帖
与我相关
我的任务
分享
'modBrowseFile
'描述:选择文件对话框
'注意常数BIF_NEWDIALOGSTYLE和MAX_PATH只用一个就行了,因为它们的效果貌似一样
Option Explicit
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
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_SHAREAWARE = &H4000
Public Function browseFile(hWnd As Long, strTitle As String, strFilter) As String
On Error GoTo mnuFileOpenDialog_Click_Error
Dim file As OPENFILENAME, sFile As String, lResult As Long, iDelim As Integer
file.lStructSize = Len(file)
file.hwndOwner = hWnd
file.flags = OFN_HIDEREADONLY + OFN_PATHMUSTEXIST + OFN_FILEMUSTEXIST + OFN_SHAREAWARE
file.lpstrFile = "" & String$(250, 0)
file.nMaxFile = 255
file.lpstrFileTitle = String$(255, 0)
file.nMaxFileTitle = 255
'file.lpstrInitialDir = Environ$("WinDir")
file.lpstrFilter = strFilter
file.nFilterIndex = 1
file.lpstrTitle = strTitle
lResult = GetOpenFileName(file)
If lResult <> 0 Then
iDelim = InStr(file.lpstrFile, Chr$(0))
If iDelim > 0 Then
sFile = left$(file.lpstrFile, iDelim - 1)
End If
End If
browseFile = sFile
mnuFileOpenDialog_Click_Exit:
Exit Function
mnuFileOpenDialog_Click_Error:
MsgBox "Error: " & Format$(Err) & " " & Error$, , "mnuFileOpenDialog_Click"
Resume mnuFileOpenDialog_Click_Exit
End Function
'文件类型设置范例:
'strFilter = "音频文件(*.mp3;*.mid;*.midi;*.rmi;*.ra;*.rm;*.rmvb;*.wma;*.wmv;*.wav;*.avi;*.vob;*.cda)" & Chr$(0) & _
' "*.mp3;*.mid;*.midi;*.rmi;*.ra;*.rm;*.rmvb;*.wma;*.wmv;*.wav;*.avi;*.vob;*.cda" & Chr$(0) & _
' "可执行文件(*.exe;*.com;*.bat;*.cmd;*.vbs)" & Chr$(0) & _
' "*.exe;*.com;*.bat;*.cmd;*.vbs" & Chr$(0) & _
' "所有文件(*.*)" & Chr$(0) & _
' "*.*" & Chr$(0)
'modBrowseFounder
'描述:选择目录对话框(可定位)
Option Explicit
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
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_NEWDIALOGSTYLE As Long = &H40
Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Dim xstrStartPath As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'功能:显示浏览文件夹,由用户选择一个目录并返回
'函数名:selectDir
'入口参数:strStartPath,String型,可选参数,初始化定位选择的目录
' strTitle,String型,可选参数,用于在“浏览文件夹”上面显示的提示信息,默认为【请选择文件夹】
'返回值:String型,用户选择的路径,如果点取消就返回""
'备注:sysdzw 于 9:09 2007-08-22 提供
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function selectDir(Optional strStartPath As String, Optional strTitle As String) As String
Dim iBROWSEINFO As BROWSEINFO
With iBROWSEINFO
.hOwner = Screen.ActiveForm.hWnd
.lpszTitle = IIf(Len(strTitle), strTitle, "【请选择文件夹】")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_NEWDIALOGSTYLE
If Len(strStartPath) Then
xstrStartPath = strStartPath & vbNullChar
.lpfnCallback = GetAddressOf(AddressOf CallBack)
End If
End With
Dim xPath As String, NoErr As Long, l
xPath = Space$(512)
l = SHBrowseForFolder(iBROWSEINFO)
NoErr = SHGetPathFromIDList(l, xPath)
selectDir = IIf(NoErr, left$(xPath, InStr(xPath, Chr(0)) - 1), "")
End Function
Function GetAddressOf(Address As Long) As Long
GetAddressOf = Address
End Function
Function CallBack(ByVal hWnd As Long, ByVal Msg As Long, ByVal pidl As Long, ByVal pData As Long) As Long
Select Case Msg
Case 1
Call SendMessage(hWnd, 1126, 1, xstrStartPath)
Case 2
Dim sDir As String * 64, tmp As Long
tmp = SHGetPathFromIDList(pidl, sDir)
If tmp = 1 Then SendMessage hWnd, 1124, 0, sDir
End Select
End Function
'使用范例:
'Private Sub Command1_Click()
' Dim sPath As String
' sPath = selectDir("C:\windows\system32\")
' If Len(sPath) Then MsgBox sPath
'End Sub