测试环境
文中代码在以下环境测试通过
1.win7 64位+vb6.0企业版+office 2010 32位
2.XP+vb6.0企业版+wps 2016 尝鲜版
3.win10+wps 2016 尝鲜版+office 2003
需要函数
''' <summary>
'''office97 8.0
'''office2000 9.0
'''officeXP (2002) 10.0
'''office2003 11.0
'''office2007 12.0
'''office2010 14.0
'''根据系统安装的Excel(Excel或者wps)创建Excel对象
''' 一定要先et 然后在ket 最后才是excel
''' 在系统中,office excel 比wps 表格具有优先级或者是注册表里面某项决定的
''' </summary>
''' <param name="xlApp"></param>
''' <param name="ISAM">索引顺序访问方法</param>
''' <param name="filter">文件后缀</param>
''' <returns></returns>
Public Function CreateExcelObject(ByRef xlApp As Object, ByRef ISAM As String, ByRef filter As String) As Boolean
On Error GoTo ErrHandle
Dim funcResult As Boolean
'尝试创建wps对象(et 或者ket)
If GetWPS_V8VerFromActiveX(xlApp, ISAM, filter) = True Then
CreateExcelObject = True
Exit Function
End If
If GetWPS_V9VerAboveFromActiveX(xlApp, ISAM, filter) = True Then
CreateExcelObject = True
Exit Function
End If
'创建wps对象失败说明没有安装wps,此时尝试创建excel对象
'如果创建excel对象失败,说明本地也没有安装excel
If GetExcelFromActiveX(xlApp, ISAM, filter) = True Then
CreateExcelObject = True
Exit Function
End If
CreateExcelObject = funcResult
ErrHandle:
Select Case Err.Number
Case 0
'DoNothing
Case 429
If xlApp Is Nothing Then
CreateExcelObject = funcResult
End If
Debug.Print ("获取Excel或者WPS对象失败")
Case Else
MsgBox "错误代码:" & Err.Number & vbCrLf & "错误描述:" & Err.Description, vbCritical, "错误"
End Select
End Function
'==========================================================
'| 模 块 名 | GetWPS_V8VerFromActiveX
'| 说 明 | ET.Application对象直接获取当前WPS版本
' 版本 开发版本号
Private Function GetWPS_V8VerFromActiveX(ByRef xlApp As Object, ByRef ISAM As String, ByRef filter As String) As Boolean
On Error GoTo ErrHandle
Dim xlappVersion As Double
Set xlApp = CreateObject("ET.Application")
xlApp.Visible = False
xlappVersion = CDbl(xlApp.Version)
Select Case xlappVersion
Case Is <= 11#
filter = ".xls"
ISAM = "Excel 8.0"
GetWPS_V8VerFromActiveX = True
Case Else
filter = ".xlsx"
ISAM = "Excel 12.0 Xml"
GetWPS_V8VerFromActiveX = True
End Select
Debug.Print "获取WPSV8及以下版本成功"
ErrHandle:
Select Case Err.Number
Case 0
'DoNothing
Case 429 'ActiveX 部件不能创建对象(电脑没有安装此对象)
filter = ""
ISAM = ""
Debug.Print "获取WPSV8及以下版本失败"
Case Else
MsgBox "错误代码:" & Err.Number & vbCrLf & "错误描述:" & Err.Description, vbCritical, "错误"
Debug.Print "错误代码:" & Err.Number & vbCrLf & "错误描述:" & Err.Description
End Select
End Function
'==========================================================
'| 模 块 名 | GetWPS_V9VerAboveFromActiveX
'| 说 明 | KET.Application对象直接获取当前WPS版本(版本号为9以上的)
' 版本 开发版本号
Private Function GetWPS_V9VerAboveFromActiveX(ByRef xlApp As Object, ByRef ISAM As String, ByRef filter As String) As Boolean
On Error GoTo ErrHandle
Dim xlappVersion As Double
Set xlApp = CreateObject("KET.Application")
xlApp.Visible = False
xlappVersion = CDbl(xlApp.Version)
Select Case xlappVersion
Case Is <= 11#
filter = ".xls"
ISAM = "Excel 8.0"
GetWPS_V9VerAboveFromActiveX = True
Case Else
filter = ".xlsx"
ISAM = "Excel 12.0 Xml"
GetWPS_V9VerAboveFromActiveX = True
End Select
Debug.Print "获取WPSV9及以上版本成功"
ErrHandle:
Select Case Err.Number
Case 0
'DoNothing
Case 429 'ActiveX 部件不能创建对象(电脑没有安装此对象)
filter = ""
ISAM = ""
Debug.Print "获取WPSV9及以上版本失败"
Case Else
MsgBox "错误代码:" & Err.Number & vbCrLf & "错误描述:" & Err.Description, vbCritical, "错误"
Debug.Print "错误代码:" & Err.Number & vbCrLf & "错误描述:" & Err.Description
End Select
End Function
'==========================================================
'| 模 块 名 | GetExcelFromActiveX
'| 说 明 | 获取所有excel版本对象 如果有
' 版本 开发版本号
Private Function GetExcelFromActiveX(ByRef xlApp As Object, ByRef ISAM As String, ByRef filter As String) As Boolean
On Error GoTo ErrHandle
Dim xlappVersion As Double
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
xlappVersion = CDbl(xlApp.Version)
Select Case xlappVersion
Case Is <= 11#
filter = ".xls"
ISAM = "Excel 8.0"
GetExcelFromActiveX = True
Case Else
filter = ".xlsx"
ISAM = "Excel 12.0 Xml"
GetExcelFromActiveX = True
End Select
Debug.Print "获取Excel版本成功"
ErrHandle:
Select Case Err.Number
Case 0
'DoNothing
Case 429 'ActiveX 部件不能创建对象(电脑没有安装此对象)
filter = ""
ISAM = ""
Debug.Print "获取Excel版本失败"
Case Else
MsgBox "错误代码:" & Err.Number & vbCrLf & "错误描述:" & Err.Description, vbCritical, "错误"
Debug.Print "错误代码:" & Err.Number & vbCrLf & "错误描述:" & Err.Description
End Select
End Function
调用
Dim xlApp As Object
Dim excelFilter As String
Dim excelISAM As String
'后期绑定Excel对象 不需要知道系统安装的是哪个版本的Excel
'不需要引用Excel
If CreateExcelObject(xlApp, excelISAM, excelFilter) = False Then
MsgBox "本机未安装Excel或者WPS,导出失败!", vbInformation, "温馨提示"
End If
异常处理
另外,有时候操作excel会提示 “类 Workbook 的 SaveAs 方法无效”错误。
这个错误通常是电脑同时安装了低版本office excel(如2003)和高版本wps(如最新版2016)导致的。
如果你用保存的代码是
If xlApp.Version > 11# Then
xlBook.SaveAs xlsFileName, 51
ElseIf xlApp.Version <= 11# Then
xlBook.SaveAs xlsFileName, 56
End If
请改成,系统会自动帮你保存文件为当前所用 Excel 版本的格式
If xlApp.Version > 11# Then
xlsFileName = xlsFileName & ".xlsx"
ElseIf xlApp.Version <= 11# Then
xlsFileName = xlsFileName & ".xls"
End If
Call xlBook.SaveAs(xlsFileName)
参考
Worksheet.SaveAs 方法 详细用法请看