vb6.0 office excel 和wps共存，创建正确的excel对象以便操作excel表格

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

If xlApp.Version > 11# Then
xlBook.SaveAs xlsFileName, 51
ElseIf xlApp.Version <= 11# Then
xlBook.SaveAs xlsFileName, 56
End If

If xlApp.Version > 11# Then
xlsFileName = xlsFileName & ".xlsx"
ElseIf xlApp.Version <= 11# Then
xlsFileName = xlsFileName & ".xls"
End If

Call xlBook.SaveAs(xlsFileName)