竞赛[高8]最好和最简洁的文件打开对话框功能 - Office中国论坛/Access中国论坛

Public Enum DialogType '定义对话框类型
Fileopen = 1
FileSaveAs = 2
FilePicker = 3
FolderPicker = 4
End Enum
Public Enum FilterType '定义筛选类型
All = 0 '所有文件
MsAccess = 1
MsWord = 2
MsExcel = 3
Txt = 4
HTML = 5
Photo = 6
Cust = 7 '自定义类型
End Enum
Public Const MsAllType As String = "*.*"
Public Const MsALLTitle As String = "所有文件"
Public Const MsAccessType As String = "*.mdb;*.adp;*.mda;*.mde;*.ade"
Public Const MsAccessTitle As String = "Microsoft Office Access"
Public Const HtmType As String = "*.html;*.htm;*.hta;*.asp"
Public Const HtmTitle As String = "网页"
Public Const TxtType As String = "*.txt"
Public Const TxtTitle As String = "文本文档"
Public Const MsExcelType As String = "*.xl;*.xls;*.xla;*.xlm;*.xlc;*.xlw"
Public Const MsExcelTitle As String = "Microsoft Office Excel"
Public Const MsWordType As String = "*.doc;*.dot"
Public Const MsWordTitle As String = "Microsoft Office Word"
Public Const PhotoType As String = "*.JPG;*.JPEG;*.JPE;*.JFIF;*.GIF;*.bmp,*.PNG,*.ico"
Public Const PhotoTitle As String = "图片文件"
Public Function GetFileName(DType As DialogType, txtFilter As FilterType, Optional txtFilterName As String, Optional ByVal strPath, Optional StrTitle As String) As String
'须引用 Micosoft Office 11.0 Object Library
'用途: 自定义对话框
'参数: DType 定义对话框类型必选: Fileopen 打开对话框;FileSaveAs 另存为对话框;FilePicker 文件选取器对话框;FolderPicker 文件夹选取器对话框
' txtFilter 定义几种常用类型支持自定义类型必选;
' txtFilterName 可选,当txtFilter类型为Cust自定义,则txtFilterName表示自定义的筛选条件和名称,筛选条件和筛选名称用","分隔:亦表示保存的文件名
' strPath 文件路径　可选
' StrTitle 自定义对话框名称,可选;缺省为系统自带的
'用法: GetFileName Fileopen, MsAccess
' GetFileName FileSaveAs, MsExcel, "Tes.xls"
' GetFileName Fileopen, Cust, "*.doc;*.xls;*.mdb"
' GetFileName Fileopen, Cust, "*.doc;*.xls;*.mdb,My Dialog"
' GetFileName Fileopen, Cust, "*.doc;*.xls;*.mdb,My Dialog", , "自定义标题"
' GetFileName Fileopen, MsAccess, , , "自定义标题"
' GetFileName Fileopen, Photo, , "D:"
Dim StrFilter As String
Dim StrFilterTitle As String
Dim fDialog As Office.FileDialog
Select Case txtFilter
Case All
StrFilter = MsAllType
StrFilterTitle = MsALLTitle
Case MsAccess
StrFilter = MsAccessType
StrFilterTitle = MsAccessTitle
Case MsWord
StrFilter = MsWordType
StrFilterTitle = MsWordTitle
Case MsExcel
StrFilter = MsExcelType
StrFilterTitle = MsExcelTitle
Case Txt
StrFilter = TxtType
StrFilterTitle = TxtTitle
Case HTML
StrFilter = HtmType
StrFilterTitle = HtmTitle
Case Photo
StrFilter = PhotoType
StrFilterTitle = PhotoTitle
Case Cust
Dim Mypos
If IsMissing(txtFilterName) Then
MsgBox "你选择了自定义类型，请在txtFilterName选项中填写筛选数据"
Exit Function
Else
Mypos = InStr(1, txtFilterName, ",")
If Mypos > 0 Then
StrFilter = Mid(txtFilterName, 1, Mypos - 1)
StrFilterTitle = Mid(txtFilterName, Mypos + 1, Len(txtFilterName) - Mypos)
Else
StrFilter = txtFilterName
StrFilterTitle = "自定义类型"
End If
End If
End Select
Set fDialog = Application.FileDialog(DType)
With fDialog
.AllowMultiSelect = False
If IsMissing(strPath) Then
.InitialFileName = CurrentProject.Path
Else
.InitialFileName = strPath
End If
If Not IsMissing(StrTitle) Then
.Title = StrTitle
End If
If DType <> FileSaveAs Then
.Filters.Clear
.Filters.Add StrFilterTitle, StrFilter
Else
.InitialFileName = txtFilterName
End If
.Show
End With
If fDialog.SelectedItems.Count > 0 Then
GetFileName = fDialog.SelectedItems(1)
Else
GetFileName = ""
End If
Set fDialog = Nothing
End Function

复制代码

'===============================================================================
'-函数名称: GetFileName
'-功能描述: 弹出文件打开对话框，获得选取的文件名
'-输入参数说明: 参数1:filter 可选文件筛选器
' 参数2:filterTitle 可选筛选文件的描述
' 参数3:title 可选对话框标题
' 参数4:SpaceDigit 可选表示文件对话框中初始显示的路径和/或文件名
'-返回参数说明: 返回选取的文件名
'-使用语法示例: Me.FileName = GetFileName("*.MDB", "Microsoft Access")
'-参考: Office VBA 帮助
'-使用注意: 可以引用Microsoft Office 1x.0 Object Library
'-兼容性: XP,2003
'-作者: fans fan0217 QQ:370552091
'-更新日期： 2007-5-2
'===============================================================================
Public Function GetFileName(Optional filter As String = "*.*", _
Optional filterTitle As String = "所有文件", _
Optional title As String, _
Optional initialFileName As String) As String
Dim dlg As Object
Set dlg = Application.FileDialog(1)
With dlg
.AllowMultiSelect = False
If Not IsMissing(title) Then
.title = title
End If
If IsMissing(initialFileName) Then
.initialFileName = initialFileName
End If
.Filters.Add filterTitle, filter
.Show
End With
If dlg.SelectedItems.Count > 0 Then
GetFileName = dlg.SelectedItems(1)
Else
GetFileName = ""
End If
Set dlg = Nothing
End Function

复制代码