- 积分
- 118
- 明经币
- 个
- 注册时间
- 2010-6-11
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
感谢作者
出处:http://www.cnblogs.com/liweis/
Option Explicit
Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal Hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const CSIDL_DRIVES As Long = &H11
Private Const WM_USER As Long = &H400
Private Const MAX_PATH As Long = 260 '// message from browser
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_VALIDATEFAILEDA As Long = 3 '// lParam:szPath ret:1(cont),0(EndDialog)
Private Const BFFM_VALIDATEFAILEDW As Long = 4 '// lParam:wzPath ret:1(cont),0(EndDialog)
Private Const BFFM_IUNKNOWN As Long = 5 '// provides IUnknown to client. lParam: IUnknown*
'// messages to browser
Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
Private Const BFFM_ENABLEOK As Long = WM_USER + 101
Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102
Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only
Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_ENABLETEMPLATE As Long = &H40
Private Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_NOLONGNAMES As Long = &H40000
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments
Private Const OFN_NOTESTFILECREATE As Long = &H10000
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_READONLY As Long = &H1
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_SHAREFALLTHROUGH As Long = 2
Private Const OFN_SHAREWARN As Long = 0
Private Const OFN_SHARENOWARN As Long = 1
Private Const OFN_SHOWHELP As Long = &H10
Private Const OFN_ENABLESIZING As Long = &H800000
Private Const OFS_MAXPATHNAME As Long = 260
'OFS_FILE_OPEN_FLAGS:
Private Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or _
OFN_LONGNAMES Or _
OFN_CREATEPROMPT Or _
OFN_NODEREFERENCELINKS
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As LongPtr
hInstance As LongPtr
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 LongPtr
lpTemplateName As String
End Type
Private Type BrowseInfo
hWndOwner As LongPtr
pIDLRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As LongPtr
lParam As LongPtr
iImage As Long
End Type
'====== File Browsers for 64 bit VBA 7 ========
'选择文件
Public Function FileBrowseOpen(ByVal sInitFolder As String, ByVal sTitle As String, ByVal sFilter As String, ByVal nFilterIndex As Integer, Optional ByVal multiSelect = False) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
sInitFolder = CorrectPath(sInitFolder)
OpenFile.lpstrInitialDir = sInitFolder
' Swap filter separator for api separator
sFilter = Replace(sFilter, "|", VBA.Chr(0))
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = nFilterIndex
OpenFile.lpstrTitle = sTitle
OpenFile.hWndOwner = 0
OpenFile.lpstrFile = VBA.String(257, 0)
OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
OpenFile.lStructSize = LenB(OpenFile)
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
If Not multiSelect Then
OpenFile.flags = 0
Else
OpenFile.flags = OFS_FILE_OPEN_FLAGS + OFN_ALLOWMULTISELECT
End If
lReturn = GetOpenFileName(OpenFile)
Dim result As String
If lReturn = 0 Then
FileBrowseOpen = ""
Else
If multiSelect Then
Dim str As String
str = VBA.Trim(Replace(VBA.Trim(OpenFile.lpstrFile), vbNullChar, ","))
Dim ed As String
ed = VBA.Mid(str, Len(str))
While (ed = ",")
str = VBA.Trim(VBA.Left(str, Len(str) - 1))
ed = VBA.Mid(str, VBA.Len(str))
Wend
FileBrowseOpen = str
Else
FileBrowseOpen = VBA.Trim(VBA.Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If
End If
End Function
'获取文件列表
Public Function GetFiles( _
ByVal sInitFolder As String, _
ByVal sTitle As String, _
ByVal sFilter As String, _
ByVal nFilterIndex As Integer) As String()
Dim strReturn As String
strReturn = FileBrowseOpen(sInitFolder, sTitle, sFilter, nFilterIndex, True)
GetFiles = Split(strReturn, ",")
End Function
'保存文件
Public Function FileBrowseSave(ByVal sDefaultFilename As String, ByVal sInitFolder As String, ByVal sTitle As String, ByVal sFilter As String, ByVal nFilterIndex As Integer, Optional ByVal overwritePrompt = False) As String
Dim PadCount As Integer
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
sInitFolder = CorrectPath(sInitFolder)
' Swap filter separator for api separator
sFilter = Replace(sFilter, "|", Chr(0))
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.hWndOwner = 0
PadCount = 260 - Len(sDefaultFilename)
OpenFile.lpstrFile = sDefaultFilename & String(PadCount, Chr(0))
'OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
OpenFile.lStructSize = LenB(OpenFile)
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = sInitFolder
OpenFile.lpstrTitle = sTitle
If Not IsMissing(overwritePrompt) And overwritePrompt Then
OpenFile.flags = OFN_OVERWRITEPROMPT
Else
OpenFile.flags = 0
End If
lReturn = GetSaveFileName(OpenFile)
If lReturn = 0 Then
FileBrowseSave = ""
Else
FileBrowseSave = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If
End Function
Private Function CorrectPath(ByVal sPath As String) As String
If VBA.Right$(sPath, 1) = "\" Then
If Len(sPath) > 3 Then sPath = VBA.Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
Else
If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root
End If
CorrectPath = sPath
End Function
'文件夹是否存在
Public Function FolderExists(ByVal sFolderName As String) As Boolean
Dim att As Long
On Error Resume Next
att = GetAttr(sFolderName)
If Err.Number = 0 Then
FolderExists = True
Else
Err.Clear
FolderExists = False
End If
On Error GoTo 0
End Function
|
|