<%
Option Explicit
Sub CheckXlDriver()
On Error Resume Next
Dim vConnString
Dim oConn, oErr
vConnString = "DRIVER={Microsoft Excel Driver (*.xls)};DBQ=NUL:"
' 连接NUL
Set oConn = CreateObject("ADODB.Connection")
oConn.Open vConnString
For Each oErr in oConn.Errors
' 如果Excel程序报告"文件创建失败",别担心,这表示它正在正常运行呢
If oErr.NativeError = -5036 Then
Exit Sub
End If
Next
Response.Write " MDAC 供应商或驱动程序不可用,请检查或重新安装!
"
Response.Write hex(Err.Number) & " " & Err.Description & " "
For Each oErr in oConn.Errors
Response.Write hex(oErr.Number) & " " & oErr.NativeError & " " & oErr.Description & " "
Next
Response.End
End Sub
Function GetConnection(vConnString)
On Error Resume Next
Set GetConnection = Server.CreateObject("ADODB.Connection")
GetConnection.Open vConnString
If Err.Number <> 0 Then
Set GetConnection = Nothing
End If
End Function
Function OptionTag(vChoice,vTrue)
Dim vSelected
If vTrue Then
vSelected = "selected"
End If
OptionTag = "" & vbCrLf
End Function
Function IsChecked(vTrue)
If vTrue Then
IsChecked = "checked"
End If
End Function
Function BookOptions(vXlFile)
Dim vServerFolder
Dim oFs, oFolder, oFile
Dim vSelected
vServerFolder = Server.MapPath(".")
Set oFs = Server.CreateObject("Scripting.FileSystemObject")
Set oFolder = oFs.GetFolder(vServerFolder)
For Each oFile in oFolder.Files
If instr(oFile.name,"xls")>0 Then
vSelected = (oFile.Name = vXlFile)
BookOptions = BookOptions & _
OptionTag(oFile.name, vSelected)
End If
Next
Set oFolder = Nothing
Set oFs = Nothing
End Function
Function NamedRangeOptions(oConn, vXlRange, vTableType)
Dim oSchemaRs
Dim vSelected
NamedRangeOptions = OptionTag(Empty, Empty)
If TypeName(oConn) = "Connection" Then
Set oSchemaRs = oConn.OpenSchema(adSchemaTables)
Do While Not oSchemaRs.EOF
If oSchemaRs("TABLE_TYPE") = vTableType Then
vSelected = (oSchemaRs("TABLE_NAME") = vXlRange)
NamedRangeOptions = NamedRangeOptions & _
OptionTag(oSchemaRs("TABLE_NAME"), vSelected)
End If
oSchemaRs.MoveNext
Loop
End If
End Function
Function DataTable(oConn, vXlRange, vXlHasHeadings)
On Error Resume Next
Const DB_E_ERRORSINCOMMAND = &H80040E14
Dim oRs, oField
Dim vThTag, vThEndTag
If vXlHasHeadings Then
vThTag = "
"
vThEndTag = "
"
Else
vThTag = "
"
vThEndTag = "
"
End If
DataTable = "
"
If TypeName(oConn) = "Connection" Then
Set oRs = oConn.Execute("[" & vXlRange & "]")
If oConn.Errors.Count > 0 Then
For Each oConnErr in oConn.Errors
If oConnErr.Number = DB_E_ERRORSINCOMMAND Then
DataTable = DataTable & _
"
该范围不存在:
" & vXlRange & "
"
Else
DataTable = DataTable & _
"
" & oConnErr.Description & "
"
End If
Next
Else
DataTable = DataTable & "
"
For Each oField in oRs.Fields
DataTable = DataTable & vThTag & oField.Name & vThEndTag
Next
DataTable = DataTable & "
"
Do While Not oRs.Eof
DataTable = DataTable & "
"
For Each oField in oRs.Fields
DataTable = DataTable & "
" & oField.Value & "
"
Next
DataTable = DataTable & "
"
oRs.MoveNext
Loop
End If
Set oRs = Nothing
Else
DataTable = DataTable & "
文件被另一个请求锁定,或者不允许执行!程序终止...
"
End If
DataTable = DataTable & "
"
End Function
%>
' --main--
Read Excel
<%
Dim vXlFile, vXlFilePath
Dim vXlRange, vXlHasHeadings
Dim vDisabled
Dim vConnString
Dim oConn, oConnErr
Const adSchemaTables = 20 ' from adovbs.inc
CheckXlDriver
' 确认它正常工作
vXlFile = Request("XlBook")
If vXlFile <> Empty Then
vXlRange = Request("XlTypedRange")
If vXlRange = Empty Then
vXlRange = "A:IV"
Else
vXlRange = Replace(vXlRange, "!", "$")
End If
vXlHasHeadings = Request("XlHasHeadings")
vXlFilePath = Server.MapPath(vXlFile)
vConnString = "DRIVER={Microsoft Excel Driver (*.xls)};ReadOnly=1;DBQ=" & _
vXlFilePath
' 建立连接
Set oConn = GetConnection(vConnString)
Else
vDisabled = "disabled"
End If
%>
<%
If vXlRange <> Empty Then
Response.Write DataTable(oConn, vXlRange, vXlHasHeadings)
End If
%>