Excel中调用VBA选择目标文件夹
来源:百度文库 编辑:神马文学网 时间:2024/05/20 16:49:43
VB(A) 2009-03-22 22:07 阅读188 评论0
字号: 大 中 小小
进行文件操作时,经常要用 VBA 选择目标文件夹,现提供实现代码:
1.FileDialog 属性
Sub GetFloder_FileDialog()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then MsgBox fd.SelectedItems(1)
Set fd = Nothing
End Sub
Sub Sample1()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
MsgBox .SelectedItems(1)
End If
End With
End Sub
2.shell 方法
Sub Sample2()
Dim Shell, myPath
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(&O0, "请选择文件夹", &H1 + &H10, "G:\")
If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
Set Shell = Nothing
Set myPath = Nothing
End Sub
3.API 方法
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
Declare Function GetDesktopWindow Lib "user32" () As Long
Public Type BROWSEINFO
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
Sub Sample3()
Dim buf As String
buf = GetFolder("请选择文件夹")
If buf = "" Then Exit Sub
MsgBox buf
End Sub
Function GetFolder(Optional Msg) As String
Dim bInfo As BROWSEINFO, pPath As String
Dim R As Long, X As Long, pos As Integer
bInfo.pidlRoot = 0&
bInfo.lpszTitle = Msg
bInfo.ulFlags = &H1
X = SHBrowseForFolder(bInfo)
pPath = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal pPath)
If R Then
pos = InStr(pPath, Chr$(0))
GetFolder = Left(pPath, pos - 1)
Else
GetFolder = ""
End If
End Function
4.API 方法二,可以定位
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
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Const WM_USER = &H400
Public Const BFFM_SETSelectIONA = (WM_USER + 102)
Public Const BFFM_INITIALIZED = 1
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As String
iImage As Long
End Type
Sub Sample4()
Dim buf As String
buf = GetDirectory("请选择文件夹", "G:\Downloads")
If buf = "" Then
Exit Sub
Else
MsgBox buf
End If
End Sub
Function GetDirectory(Optional Msg, Optional UserPath) As String
Dim bInfo As BROWSEINFO, pPath As String
Dim R As Long, X As Long, pos As Integer
With bInfo
.pidlRoot = &H0
.lpszTitle = Msg
.ulFlags = &H40
.lpfn = FARPROC(AddressOf BrowseCallbackProc)
If IsMissing(UserPath) Then
.lParam = CurDir & Chr(0)
Else
.lParam = UserPath & Chr(0)
End If
End With
X = SHBrowseForFolder(bInfo)
pPath = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal pPath)
CoTaskMemFree X
If R Then
pos = InStr(pPath, Chr(0))
GetDirectory = Left(pPath, pos - 1)
Else
GetDirectory = ""
End If
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal _
lParam As Long, ByVal lpData As Long) As Long
If uMsg = BFFM_INITIALIZED Then
SendMessage hWnd, BFFM_SETSelectIONA, 1, ByVal lpData
End If
End Function
Public Function FARPROC(pfn As Long) As Long
FARPROC = pfn
End Function
字号: 大 中 小小
进行文件操作时,经常要用 VBA 选择目标文件夹,现提供实现代码:
1.FileDialog 属性
Sub GetFloder_FileDialog()
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then MsgBox fd.SelectedItems(1)
Set fd = Nothing
End Sub
Sub Sample1()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
MsgBox .SelectedItems(1)
End If
End With
End Sub
2.shell 方法
Sub Sample2()
Dim Shell, myPath
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(&O0, "请选择文件夹", &H1 + &H10, "G:\")
If Not myPath Is Nothing Then MsgBox myPath.Items.Item.Path
Set Shell = Nothing
Set myPath = Nothing
End Sub
3.API 方法
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
Declare Function GetDesktopWindow Lib "user32" () As Long
Public Type BROWSEINFO
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
Sub Sample3()
Dim buf As String
buf = GetFolder("请选择文件夹")
If buf = "" Then Exit Sub
MsgBox buf
End Sub
Function GetFolder(Optional Msg) As String
Dim bInfo As BROWSEINFO, pPath As String
Dim R As Long, X As Long, pos As Integer
bInfo.pidlRoot = 0&
bInfo.lpszTitle = Msg
bInfo.ulFlags = &H1
X = SHBrowseForFolder(bInfo)
pPath = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal pPath)
If R Then
pos = InStr(pPath, Chr$(0))
GetFolder = Left(pPath, pos - 1)
Else
GetFolder = ""
End If
End Function
4.API 方法二,可以定位
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
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Public Const WM_USER = &H400
Public Const BFFM_SETSelectIONA = (WM_USER + 102)
Public Const BFFM_INITIALIZED = 1
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As String
iImage As Long
End Type
Sub Sample4()
Dim buf As String
buf = GetDirectory("请选择文件夹", "G:\Downloads")
If buf = "" Then
Exit Sub
Else
MsgBox buf
End If
End Sub
Function GetDirectory(Optional Msg, Optional UserPath) As String
Dim bInfo As BROWSEINFO, pPath As String
Dim R As Long, X As Long, pos As Integer
With bInfo
.pidlRoot = &H0
.lpszTitle = Msg
.ulFlags = &H40
.lpfn = FARPROC(AddressOf BrowseCallbackProc)
If IsMissing(UserPath) Then
.lParam = CurDir & Chr(0)
Else
.lParam = UserPath & Chr(0)
End If
End With
X = SHBrowseForFolder(bInfo)
pPath = Space$(512)
R = SHGetPathFromIDList(ByVal X, ByVal pPath)
CoTaskMemFree X
If R Then
pos = InStr(pPath, Chr(0))
GetDirectory = Left(pPath, pos - 1)
Else
GetDirectory = ""
End If
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal _
lParam As Long, ByVal lpData As Long) As Long
If uMsg = BFFM_INITIALIZED Then
SendMessage hWnd, BFFM_SETSelectIONA, 1, ByVal lpData
End If
End Function
Public Function FARPROC(pfn As Long) As Long
FARPROC = pfn
End Function
Excel中调用VBA选择目标文件夹
Excel VBA选择目标文件夹方法
在Visual C++ 中调用Excel 2000
转 Visual C++ 中调用Excel 2000
Excel中如何调用SQL数据
Excel中各种VBA写法 - 彷徨....豁然开朗 - 博客园
利用Excel从文件夹中提取所有文件名Excel
VBA(中)
Excel VBA Examples(2)
EXCEL VBA 基础
EXCEL VBA 基础
Excel VBA完全手册
Excel VBA Examples(2)
Excel VBA语句
EXCEL VBA 基础qeq
EXCEL VBA 基础1
EXCEL VBA 基础11
Excel VBA入门语句
EXCEL VBA 基础
EXCEL VBA 基础
Excel VBA排序算法
EXCEL VBA 基础
Excel VBA入门语句
Excel VBA入门语句