Excel VBA选择文件、高容错性地打开文件

VBA选择文件

 

Sub SelectFile()    Dim FileName As Variant                             '打开文件对话框返回的文件名，是一个全路径文件名，其值也可能是False，因此类型为Variant    Dim sFileName As String                         '从FileName中提取的文件名    Dim sPathName As String                         '从FileName中提取的路径名    Dim aFile As Variant                            '数组，提取文件名sFileName时使用    Dim ws As Worksheet                             '存储文件路径名和文件名的工作表    Set ws = Worksheets("Sheet1")                   '设置工作表    FileName = Application.GetOpenFilename("Excel 文件 (*.xls),*.xls")    '调用Windows打开文件对话框    If FileName <> False Then                       '如果未按“取消”键        aFile = Split(FileName, "\")                '在全路径中，以“\”为分隔符，分成数据        sPathName = aFile(0)                        '取盘符        For i = 1 To UBound(aFile) - 1              '循环合成路径名            sPathName = sPathName & "\" & aFile(i)        Next        sFileName = aFile(UBound(aFile))            '数组的最后一个元素为文件名        ws.Cells(1, 2).Value = sPathName            '保存路径名        ws.Cells(2, 2).Value = sFileName            '保存文件名    End IfEnd Sub

 

选择打开文件后并没有真实的把它打开，然后高容错性地打开文件

 

Function OpenExcelFile(sPath As String, ByVal sFileName As String, bDisplay As Boolean, sPwd As String) As Integer    '打开Excel文件    'Ver 1.05    '完成时间：2007.12.01    '设计：美猴王软件工作室 www.okexcel.com.cn    '参数说明：    'sPath:文件绝对路径；sFileName:Excel文件名；bDisplay:True显示错误信息；sPwd:文件打开密码    '返回值：-1:同名文件已经打开；-2:文件不存在或密码错误；0:成功打开；1:文件已经被打开    Dim bOpen As Boolean    Dim sFullName As String    On Error Resume Next    If InStr(LCase(sFileName), ".xls") = 0 Then sFileName = sFileName & ".xls"    sFullName = Workbooks(sFileName).FullName    '检查是否已经打开同名的Excel文件    '如果有sFullName不为空    On Error GoTo 0    bOpen = False    If sFullName <> "" Then        If LCase(sFullName) = LCase(sPath & "\" & sFileName) Then            bOpen = True            '判断已经打开的同名文件是否本次需要打开的文件            OpenExcelFile = 1            '文件已经被打开        Else            If bDisplay Then                MsgBox "请首先关闭“" & sFileName & "”文件！" & Chr(13) & "不能同时打开同名文件，这是Excel的规定！", vbOKOnly + vbExclamation, "文件的打开错误"            End If            bOpen = True            OpenExcelFile = -1            '不能同时打开同名文件，这是Excel的规定        End If    End If    If Not bOpen Then        On Error GoTo errOpen        Workbooks.Open Filename:=sPath & "\" & sFileName, Password:=sPwd        On Error GoTo 0        OpenExcelFile = 0        '成功打开文件    End If    Exit FunctionerrOpen:    If bDisplay Then MsgBox Err.Description, vbOKOnly + vbExclamation, "文件的打开错误"    OpenExcelFile = -2    '文件不存在或密码错误    On Error GoTo 0End Function