一段将EXCEL上传到ACCESS中的代码，在本地服务器测试通过，上传到远程服务器后不行了
此程序实现的目的是：
将用户在UI界面中提交的EXCEL文件传到ACCESS数据库对应的栏位中。
已有程序在本地IIS5.1 + 127.0.0.1环境下，已经能够实现。
可是上传到远程服务器后，再上传时，就报错：“您选择的EXCEL中无数据，或您未关闭EXCEL文件！”。
代码如下：
rsdb.open sqldb,conn,1,3
rsDB.addnew
rsDB("ab_jkdw")=trim(rsExcel(0))
rsDB("sfsb_id")=trim(rsADMIN("sfsb_id"))
rsExcel.update
rsDB.movenext
rsExcel.movenext
loop
'response.redirect FileName
end if
rsDB.movefirst
if rsDB.eof then
response.write"<SCRIPT language=JavaScript>alert('数据库中无数据！');"
response.write"javascript:history.go(-1)</SCRIPT>"
response.end
else
response.redirect "readExcelA.asp"
end if
end if
call rsDBclose()
call rsExcelclose()
call connExcelclose()
call connclose()
else
%>
......后面省略
End Property
Public Property Get isErr'错误的代码,0或true表示无错
isErr=isErr_
End Property
Public Property Get ErrMessage'错误的字符串信息
ErrMessage=ErrMessage_
End Property
Public Property Get AllowExt'允许上传类型(白名单)
AllowExt=AllowExt_
End Property
Public Property Let AllowExt(Value)'允许上传类型(白名单)
AllowExt_=LCase(Value)
End Property
Public Property Get NoAllowExt'不允许上传类型(黑名单)
NoAllowExt=NoAllowExt_
End Property
Public Property Let NoAllowExt(Value)'不允许上传类型(黑名单)
NoAllowExt_=LCase(Value)
End Property
'----------------------------
'类实现代码
'初始化类
Private Sub Class_Initialize
isErr_ = 0
NoAllowExt=""'黑名单,可以在这里预设不可上传的文件类型,以文件的后缀名来判断,不分大小写,每个每缀名用;号分开,如果黑名单为空,则判断白名单
NoAllowExt=LCase(NoAllowExt)
AllowExt=""'白名单,可以在这里预设可上传的文件类型,以文件的后缀名来判断,不分大小写,每个后缀名用;号分开
AllowExt=LCase(AllowExt)
isGetData_=false
End Sub
'类结束
Private Sub Class_Terminate
on error Resume Next
'清除变量及对像
Form.RemoveAll
Set Form = Nothing
File.RemoveAll
Set File = Nothing
oUpFileStream.Close
Set oUpFileStream = Nothing
End Sub
'分析上传的数据
Public Sub GetData (MaxSize)
'定义变量
on error Resume Next
if isGetData_=false then
Dim RequestBinDate,sSpace,bCrLf,sInfo,iInfoStart,iInfoEnd,tStream,iStart,oFileInfo
Dim sFormValue,sFileName
Dim iFindStart,iFindEnd
Dim iFormStart,iFormEnd,sFormName
'代码开始
If Request.TotalBytes < 1 Then'如果没有数据上传
isErr_ = 1
ErrMessage_="没有数据上传"
Exit Sub
End If
If MaxSize > 0 Then '如果限制大小
If Request.TotalBytes > MaxSize Then
isErr_ = 2'如果上传的数据超出限制大小
ErrMessage_="上传的数据超出限制大小"
Exit Sub
End If
End If
Set Form = Server.CreateObject ("Scripting.Dictionary")
Form.CompareMode = 1
Set File = Server.CreateObject ("Scripting.Dictionary")
File.CompareMode = 1
Set tStream = Server.CreateObject ("ADODB.Stream")
Set oUpFileStream = Server.CreateObject ("ADODB.Stream")
oUpFileStream.Type = 1
oUpFileStream.Mode = 3
oUpFileStream.Open
oUpFileStream.Write Request.BinaryRead (Request.TotalBytes)
oUpFileStream.Position = 0
RequestBinDate = oUpFileStream.Read
iFormEnd = oUpFileStream.Size
bCrLf = ChrB (13) & ChrB (10)
'取得每个项目之间的分隔符
sSpace = MidB (RequestBinDate,1, InStrB (1,RequestBinDate,bCrLf)-1)
iStart = LenB(sSpace)
iFormStart = iStart+2
'分解项目
Do
iInfoEnd = InStrB (iFormStart,RequestBinDate,bCrLf & bCrLf)+3
tStream.Type = 1
tStream.Mode = 3
tStream.Open
oUpFileStream.Position = iFormStart
oUpFileStream.CopyTo tStream,iInfoEnd-iFormStart
tStream.Position = 0
tStream.Type = 2
tStream.CharSet = "gb2312"
sInfo = tStream.ReadText
'取得表单项目名称
iFormStart = InStrB (iInfoEnd,RequestBinDate,sSpace)-1
iFindStart = InStr (22,sInfo,"name=""",1)+6
iFindEnd = InStr (iFindStart,sInfo,"""",1)
sFormName = Mid(sinfo,iFindStart,iFindEnd-iFindStart)
'如果是文件
If InStr (45,sInfo,"filename=""",1) > 0 Then
Set oFileInfo = new clsFileInfo
'取得文件属性
iFindStart = InStr (iFindEnd,sInfo,"filename=""",1)+10
iFindEnd = InStr (iFindStart,sInfo,""""&vbCrLf,1)
sFileName = Mid(sinfo,iFindStart,iFindEnd-iFindStart)
oFileInfo.FileName = GetFileName(sFileName)
oFileInfo.FilePath = GetFilePath(sFileName)
oFileInfo.FileExt = GetFileExt(sFileName)
iFindStart = InStr (iFindEnd,sInfo,"Content-Type: ",1)+14
iFindEnd = InStr (iFindStart,sInfo,vbCr)
oFileInfo.FileMIME = Mid(sinfo,iFindStart,iFindEnd-iFindStart)
oFileInfo.FileStart = iInfoEnd
oFileInfo.FileSize = iFormStart -iInfoEnd -2
oFileInfo.FormName = sFormName
file.add sFormName,oFileInfo
else
'如果是表单项目
tStream.Close
tStream.Type = 1
tStream.Mode = 3
tStream.Open
oUpFileStream.Position = iInfoEnd
oUpFileStream.CopyTo tStream,iFormStart-iInfoEnd-2
tStream.Position = 0
tStream.Type = 2
tStream.CharSet = "gb2312"
sFormValue = tStream.ReadText
If Form.Exists (sFormName) Then
Form (sFormName) = Form (sFormName) & ", " & sFormValue
else
Form.Add sFormName,sFormValue
End If
End If
tStream.Close
iFormStart = iFormStart+iStart+2
'如果到文件尾了就退出
Loop Until (iFormStart+2) >= iFormEnd
RequestBinDate = ""
Set tStream = Nothing
isGetData_=true
end if
End Sub
'保存到文件,自动覆盖已存在的同名文件
Public Function SaveToFile(Item,Path)
SaveToFile=SaveToFileEx(Item,Path,True)
End Function
'保存到文件,自动设置文件名
Public Function AutoSave(Item,Path)
AutoSave=SaveToFileEx(Item,Path,false)
End Function
'保存到文件,OVER为真时,自动覆盖已存在的同名文件,否则自动把文件改名保存
Private Function SaveToFileEx(Item,Path,Over)
On Error Resume Next
Dim oFileStream
Dim tmpPath
Dim nohack '防黑缓冲
isErr=0
Set oFileStream = CreateObject ("ADODB.Stream")
oFileStream.Type = 1
oFileStream.Mode = 3
oFileStream.Open
oUpFileStream.Position = File(Item).FileStart
oUpFileStream.CopyTo oFileStream,File(Item).FileSize
nohack=split(path,".") '重要修改，防止黑客二进制"01"断名!!!
tmpPath=nohack(0)&"."&nohack(ubound(nohack)) '重要修改，防止黑客二进制"01"断名!!!
if Over then
if isAllowExt(GetFileExt(tmpPath)) then
oFileStream.SaveToFile tmpPath,2
Else
isErr_=3
ErrMessage_="该后缀名的文件不允许上传!"
End if
Else
Path=GetFilePath(Path)
if isAllowExt(File(Item).FileExt) then
do
Err.Clear()
nohack=split(Path&GetNewFileName()&"."&File(Item).FileExt,".") '重要修改，防止黑客二进制"01"断名!!!
tmpPath=nohack(0)&"."&nohack(ubound(nohack)) '重要修改，防止黑客二进制"01"断名！！!
oFileStream.SaveToFile tmpPath
loop Until Err.number<1
oFileStream.SaveToFile Path
Else
isErr_=3
ErrMessage_="该后缀名的文件不允许上传!"
End if
End if
oFileStream.Close
Set oFileStream = Nothing
if isErr_=3 then SaveToFileEx="" else SaveToFileEx=GetFileName(tmpPath)
End Function
'取得文件数据
Public Function FileData(Item)
isErr_=0
if isAllowExt(File(Item).FileExt) then
oUpFileStream.Position = File(Item).FileStart
FileData = oUpFileStream.Read (File(Item).FileSize)
Else
isErr_=3
ErrMessage_="该后缀名的文件不允许上传!"
FileData=""
End if
End Function
'取得文件路径
Public function GetFilePath(FullPath)
If FullPath <> "" Then
GetFilePath = Left(FullPath,InStrRev(FullPath, ""))
Else
GetFilePath = ""
End If
End function
'取得文件名
Public Function GetFileName(FullPath)
If FullPath <> "" Then
GetFileName = mid(FullPath,InStrRev(FullPath, "")+1)
Else
GetFileName = ""
End If
End function
'取得文件的后缀名
Public Function GetFileExt(FullPath)
If FullPath <> "" Then
GetFileExt = LCase(Mid(FullPath,InStrRev(FullPath, ".")+1))
Else
GetFileExt = ""
End If
End function
'取得一个不重复的序号
Public Function GetNewFileName()
dim ranNum
dim dtNow
dtNow=Now()
ranNum=int(90000*rnd)+10000
GetNewFileName=year(dtNow) & right("0" & month(dtNow),2) & right("0" & day(dtNow),2) & right("0" & hour(dtNow),2) & right("0" & minute(dtNow),2) & right("0" & second(dtNow),2) & ranNum
End Function
Public Function isAllowExt(Ext)
if NoAllowExt="" then
isAllowExt=cbool(InStr(1,";"&AllowExt&";",LCase(";"&Ext&";")))
else
isAllowExt=not CBool(InStr(1,";"&NoAllowExt&";",LCase(";"&Ext&";")))
end if
End Function
End Class
'文件属性类
Class clsFileInfo
Dim FormName,FileName,FilePath,FileSize,FileMIME,FileStart,FileExt
End Class
%>
[解决办法]
第二段：上传文件和写入数据库
dim upfile,formPath,ServerPath,FSPath,formName,FileName,oFile,upfilecount
upfilecount=0
session("sfsb_id")="1001"
set upfile=new clsUp ''建立上传对象
upfile.NoAllowExt="asp;exe;htm;html;aspx;cs;vb;js;"'设置上传类型的黑名单
upfile.GetData (102400) '取得上传数据,限制最大上传1M
if upfile.isErr then '如果出错
select case upfile.isErr
case 1
Response.Write "没有上传数据"
case 2
Response.Write "上传的文件超出限制,最大1M"
end select
else
FSPath=GetFilePath(Server.mappath("readExcelA.asp"),"")'取得当前文件在服务器路径
FSPath=FSPath&"upload" '上传到upload文件夹
ServerPath=GetFilePath(Request.ServerVariables("HTTP_REFERER"),"/")'取得在网站上的位置
for each formName in upfile.file '列出所有上传了的文件
set oFile=upfile.file(formname)
FileName=upfile.form(formName)'取得文本域的值
if not FileName>"" then FileName=oFile.filename'如果没有输入新的文件名,就用原来的文件名
upfile.SaveToFile formname,FSPath&FileName '保存文件 也可以使用AutoSave来保存,参数一样,但是会自动建立新的文件名
if upfile.iserr then
Response.Write upfile.errmessage
else
upfilecount=upfilecount+1
Response.Write "上传成功"
end if
'将数据读入数据库===============================================
dim conn2
'连接待读入excel数据表
set conn2=CreateObject("ADODB.Connection")
conn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=;Extended properties='Excel 5.0;hdr=yes;imex=1';Data Source="& Server.MapPath("upload/"&FileName)
'查询待读入excel数据表
sql = "SELECT * FROM [Sheet1$]"
set rs = conn2.execute(sql)
'根据身份识别ID，删除原有数据
dsql="delete * from ab_tbl where Ab_tbl.sfsb_id = "&session("sfsb_id")
conn.execute dsql
'将数据循环读入目的数据库
while not rs.eof
sql = "insert into ab_tbl(ab_jkdw,sfsb_id) values('"& fixsql(rs(0)) &"','1001')"
conn.execute(sql)
rs.movenext
wend
set oFile=nothing'释放文件对象
next
set upfile=nothing'释放上传对象
'释放数据连接对象
conn.close
set conn = nothing
conn2.close
set conn2 = nothing
'删除上传数据表
Set fso = CreateObject("Scripting.FileSystemObject")
FiLePaTh = Server.MapPath("upload/"&FileName)
If fso.FileExists(FiLePaTh) Then
fso.DeleteFile(FiLePaTh)
end if
Set fso = nothing
response.Write "<script LANGUAGE='javascript'>alert('数据导入成功！');history.go(-1);</script>"
response.End
end if
'取得文件上传路径
function GetFilePath(FullPath,str)
If FullPath <> "" Then
GetFilePath = left(FullPath,InStrRev(FullPath, str))
Else
GetFilePath = ""
End If
End function
'检查读入数据，有效性验证，可以修改你要过滤的符号
function fixsql(str)
dim newstr
newstr = str
if isnull(newstr) then
newstr = ""
else
newstr =Replace(newstr ,"'","‘")
newstr =Replace(newstr ,"%","％")
newstr =Replace(newstr ,"-","－")
newstr =Replace(newstr ,">","〉")
newstr =Replace(newstr ,"<","〈")
newstr =Replace(newstr ,"&","&")
newstr =Replace(newstr,";","；")
newstr =Replace(newstr ,"+",""+"")
newstr =Replace(newstr ,"[","［")
newstr =Replace(newstr ,"]","］")
newstr =Replace(newstr ,"{","｛")
newstr =Replace(newstr ,"}","｝")
newstr =Replace(newstr ,"(","（")
newstr =Replace(newstr ,")","）")
newstr =Replace(newstr ,"""","''")
end if
fixsql = newstr
end function
