'文件上传类,无惧上传类 V2.2,作者:梁无惧
全部代码粘贴不下后面分段贴出
代码虽然有点长但结构清楚 读起来不难
请路过大神帮帮忙
研究好几天无果已在濒临崩溃边缘
导入部分代码
if request("action")="import" then
if request("mdb_table")="" or request("xls_table")="" then
showerr "连接超时或非法访问"
end if
sql="select * from ["&request("mdb_table")&"] where 1<>1"
set rsfield=server.CreateObject("adodb.recordset")
rsfield.open sql,mdb_conn,1,1
if err.number<>0 then
showerr err.Description
end if
sql="select * from ["&request("xls_table")&"]"
set rsxls=xls_conn.execute(sql)
if err.number<>0 then
showerr err.Description
end if
dim success,fail,newone
success=0
fail=0
do while not rsxls.eof
sql="select * from ["&request("mdb_table")&"]"
set rsmdb=server.CreateObject("adodb.recordset")
rsmdb.open sql,mdb_conn,1,3
if err.number<>0 then
showerr err.Description
end if
rsmdb.addnew
for i=0 to rsfield.Fields.count-1
if request("s_"&rsfield.fields(i).name)<>"" then
rsmdb(rsfield.fields(i).name)=rsxls(cstr(request("s_"&rsfield.fields(i).name)))
if err.number<>0 then
response.write "<br>错误:"&err.Description
fail=fail+1
err.clear
end if
end if
next
rsmdb.update
if err.number<>0 then
response.write "<br>错误:"&err.Description
err.clear
else
success=success+1
end if
rsmdb.close
set rsmdb=nothing
rsxls.movenext
loop
rsxls.close
set rsxls=nothing
if err.number<>0 then response.write "<br>错误:"&err.Description
response.write "<br>成功导入数据"&success&"条.字段匹配错误"&fail&"次"
end if
mdb字段是备注的还是文本，文本自己检查下字段大小
还有你的单元格指Excel还是access的？
代码分段贴出
<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<%Option Explicit
Response.Buffer = True
Server.ScriptTimeOut = 90
'Session.CodePage=936
' 将EXCEL数据导入ACCESS通用程序
'Coded by 8da.OruA
dim sql,rstable,rs
dim rsfield,rsmdb,rsxls%>
<html >
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312" />
<title>EXCEL>ACCESS</title>
<style type="text/css">
<!--
td {
font-size: 9pt;
color: #333333;
background-color:#ffffff;
height:20px;
}
body {
font-size: 9pt;
color: #333333;
}
.title {
background:#0066CC;
color:#FFFFFF;
text-align:center;
font-size:12pt;
}
table {
background-color:#999999;
}
#uploading {
display:none;
}
.t_td{
height:16px;
}
.word{
color:#ff0000;
font-weight: bold;
}
.border{
border:1px solid #999999;
color:#000000;
}
-->
</style>
<script>
function uploadstart(){
if (document.all("file").value=""){
alert("请选择上传文件");
return;
}
document.all("uploading").style.display="inline";
document.all("upload").style.display="none";
document.all("pathtable").style.display="none";
document.all("fileform").submit();
}
</script>
</head>
<body>
<center>
<%
if request("action")="login" then
if request("pwd")="123456" then
session("import_login")=true
end if
end if
'文件上传类,无惧上传类 V2.2,作者:梁无惧
Class UpFile_Class
Dim Form,File
Dim AllowExt_ '允许上传类型(白名单)
Dim NoAllowExt_ '不允许上传类型(黑名单)
Dim IsDebug_ '是否显示出错信息
Private oUpFileStream '上传的数据流
Private isErr_ '错误的代码,0或true表示无错
Private ErrMessage_ '错误的字符串信息
Private isGetData_ '指示是否已执行过GETDATA过程
'------------------------------------------------------------------
'类的属性
Public Property Get Version
Version="无惧上传类 Version V2.0"
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
Public Property Let IsDebug(Value) '是否设置为调试模式
IsDebug_=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
if Err.number<>0 then OutErr("清除类时发生错误!")
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_="没有数据上传,这是因为直接提交网址所产生的错误!"
OutErr("没有数据上传,这是因为直接提交网址所产生的错误!!")
Exit Sub
End If
If MaxSize > 0 Then '如果限制大小
If Request.TotalBytes > MaxSize Then
isErr_ = 2 '如果上传的数据超出限制大小
ErrMessage_="上传的数据超出限制大小!"
OutErr("上传的数据超出限制大小!")
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")
if Err.number<>0 then OutErr("创建流对象(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 FileInfo_Class
'取得文件属性
iFindStart = InStr (iFindEnd,sInfo,"filename=""",1)+10
iFindEnd = InStr (iFindStart,sInfo,""""&vbCrLf,1)
sFileName = Trim(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
if Err.number<>0 then OutErr("分解上传数据时发生错误,可能客户端的上传数据不正确或不符合上传数据规则")
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 FileExt
if file.Exists(Item) then
Dim oFileStream
Dim tmpPath
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
tmpPath=Split(Path,".")(0)
FileExt=GetFileExt(Path)
if Over then
if isAllowExt(FileExt) then
oFileStream.SaveToFile tmpPath & "." & FileExt,2
if Err.number<>0 then OutErr("保存文件时出错,请检查路径,是否存在该上传目录!该文件保存路径为" & tmpPath & "." & FileExt)
Else
isErr_=3
ErrMessage_="该后缀名的文件不允许上传!"
OutErr("该后缀名的文件不允许上传")
End if
Else
Path=GetFilePath(Path)
dim fori
fori=1
if isAllowExt(File(Item).FileExt) then
do
fori=fori+1
Err.Clear()
tmpPath=Path&GetNewFileName()&"."&File(Item).FileExt
oFileStream.SaveToFile tmpPath
loop Until ((Err.number=0) or (fori>50))
if Err.number<>0 then OutErr("自动保存文件出错,已经测试50次不同的文件名来保存,请检查目录是否存在!该文件最后一次保存时全路径为"&Path&GetNewFileName()&"."&File(Item).FileExt)
Else
isErr_=3
ErrMessage_="该后缀名的文件不允许上传!"
OutErr("该后缀名的文件不允许上传")
End if
End if
oFileStream.Close
Set oFileStream = Nothing
else
ErrMessage_="不存在该对象(如该文件没有上传,文件为空)!"
OutErr("不存在该对象(如该文件没有上传,文件为空)")
end if
if isErr_=3 then SaveToFileEx="" else SaveToFileEx=GetFileName(tmpPath)
End Function
'取得文件数据
Public Function FileData(Item)
isErr_=0
if file.Exists(Item) then
if isAllowExt(File(Item).FileExt) then
oUpFileStream.Position = File(Item).FileStart
FileData = oUpFileStream.Read (File(Item).FileSize)
Else
isErr_=3
ErrMessage_="该后缀名的文件不允许上传"
OutErr("该后缀名的文件不允许上传")
FileData=""
End if
else
ErrMessage_="不存在该对象(如该文件没有上传,文件为空)!"
OutErr("不存在该对象(如该文件没有上传,文件为空)")
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()
randomize
ranNum=int(90000*rnd)+10000
'以下这段由webboy提供
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
Public Sub OutErr(ErrMsg)
if IsDebug_=true then
Response.Write ErrMsg
Response.End
End if
End Sub
'----------------------------------------------------------------------------------------------------
'文件属性类
Class FileInfo_Class
Dim FormName,FileName,FilePath,FileSize,FileMIME,FileStart,FileExt
End Class
function HTMLEncode(fString)
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString= replace(fString, """", """)
fString = replace(fstring,"\","\\")
fString = Replace(fString, CHR(13), " ")
HTMLEncode = fString
end function
'显示错误信息
sub showerr(message)
response.write "<script>alert("""&HTMLEncode(message)&""");window.location='import.asp';</script>"
response.end
end sub
'-----上传文件
if request("action")="upfile" then
Server.ScriptTimeOut=999999
dim upload,serverpath,errstr,path,savefilename
set upload=new UpFile_Class
path=Request.ServerVariables("PATH_info")
serverpath=server.MapPath(path)
serverpath=upload.getfilepath(serverPath)
path= Left(path,InStrRev(path, "\"))
upload.GetData(10240000)
upload.AllowExt="xls;txt;"
if upload.isErr then
select case upload.iserr
case 1
errstr="请选择上传文件"
case 2
errstr="上传的文件超出限制,最大10M"
end select
session("xls_path")=""
showerr errstr
else
upload.SaveToFile "file",serverpath&upload.file("file").filename
if upload.isErr then
if upload.isErr=3 then
errstr="只允许上传XLS文件"
else
errstr="上传中遇到未知错误"
end if
session("xls_path")=""
showerr errstr
else
session("xls_path")=path&upload.file("file").filename
response.Redirect("import.asp")
end if
end if
else
'-----连接数据源
if request("action")<>"" and request("action")<>"login" then
on error Resume Next
err.clear
select case request("action")
case "ready"
if request("xls_path")="" or request("mdb_path")="" then
showerr "文件路径为空"
end if
session("xls_path")=request("xls_path")
session("mdb_path")=request("mdb_path")
case "opentable"
if session("xls_path")="" or session("mdb_path")="" then
showerr "文件路径为空"
end if
end select
dim xls_conn,mdb_conn,connstr
connstr="Driver={Microsoft Excel Driver (*.xls)};Dbq=" & Server.MapPath(""&session("xls_path")&"")
set xls_conn= Server.CreateObject("ADODB.Connection")
xls_conn.open connstr '连接EXCEL数据
set mdb_conn= Server.CreateObject("ADODB.Connection")
connstr="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(""&session("mdb_path")&"")
mdb_conn.open connstr '连接ACCESS
if err.number<>0 then
showerr err.Description
end if
end if
end if
if request("action")="import" then
if request("mdb_table")="" or request("xls_table")="" then
showerr "连接超时或非法访问"
end if
sql="select * from ["&request("mdb_table")&"] where 1<>1"
set rsfield=server.CreateObject("adodb.recordset")
rsfield.open sql,mdb_conn,1,1
if err.number<>0 then
showerr err.Description
end if
sql="select * from ["&request("xls_table")&"]"
set rsxls=xls_conn.execute(sql)
if err.number<>0 then
showerr err.Description
end if
dim success,fail,newone
success=0
fail=0
do while not rsxls.eof
sql="select * from ["&request("mdb_table")&"]"
set rsmdb=server.CreateObject("adodb.recordset")
rsmdb.open sql,mdb_conn,1,3
if err.number<>0 then
showerr err.Description
end if
rsmdb.addnew
for i=0 to rsfield.Fields.count-1
if request("s_"&rsfield.fields(i).name)<>"" then
rsmdb(rsfield.fields(i).name)=rsxls(cstr(request("s_"&rsfield.fields(i).name)))
if err.number<>0 then
response.write "<br>错误:"&err.Description
fail=fail+1
err.clear
end if
end if
next
rsmdb.update
if err.number<>0 then
response.write "<br>错误:"&err.Description
err.clear
else
success=success+1
end if
rsmdb.close
set rsmdb=nothing
rsxls.movenext
loop
rsxls.close
set rsxls=nothing
if err.number<>0 then response.write "<br>错误:"&err.Description
response.write "<br>成功导入数据"&success&"条.字段匹配错误"&fail&"次"
end if
if session("import_login")="" then
%>
<table width="400" border="0" cellspacing="1" cellpadding="2">
<tr><form id="form1" name="form1" method="post" action="import.asp?action=login">
<td align="center">
口令:
<input name="pwd" type="password" id="pwd" />
<input type="submit" name="Submit5" value="登录" /> </td> </form>
</tr>
</table>
<%else%>
<div id="upload">
<table width="400" border="0" cellpadding="2" cellspacing="1">
<tr>
<td class="title">上传EXCEL文件</td>
</tr>
<form action="import.asp?action=upfile" method="post" id="fileform" enctype="multipart/form-data" name="fileform">
<tr>
<td align="center"><input type="file" name="file" />
<input name="upstart" type="button" id="upstart" value="上传" onClick="uploadstart();"/></td>
</tr>
</form>
</table>
</div>
<div id="uploading">
<table width="400" border="0" cellspacing="0" cellpadding="0">
<tr>
<td valign="middle" class="title" style="height:40px;">上传中...请稍候</td>
</tr>
</table>
</div>
<br />
<div id=pathtable>
<form action="import.asp?action=ready" method="post">
<table width="400" border="0" cellspacing="1" cellpadding="2">
<tr>
<td colspan="2" class="title">文件路径</td>
</tr>
<tr>
<td width="100" align="center">EXCEL路径</td>
<td><input name="xls_path" type="text" id="xls_path" value="<%=session("xls_path")%>" size="40" /></td>
</tr>
<tr>
<td align="center">ACCESS路径</td>
<td><input name="mdb_path" type="text" id="mdb_path" value="<%=session("mdb_path")%>" size="40" /></td>
</tr>
<tr>
<td colspan="2" align="center"><input type="submit" name="Submit" value="连接" />
<input type="reset" name="Submit2" value="重置" /></td>
</tr>
</table>
</form>
</div>
<%if request("action")="ready" then%>
<table width="400" border="0" cellspacing="1" cellpadding="2">
<form action="import.asp?action=opentable" method="post">
<tr>
<td colspan="2" class="title">选择对应数据表</td>
</tr>
<tr>
<td width="194" align="center">EXCEL数据源</td>
<td width="194" align="center">ACCESS数据库</td>
</tr>
<tr>
<td align="center" valign="top"><table width="100" border="0" cellspacing="0" cellpadding="0">
<%set rstable=xls_conn.OpenSchema(20)
do while not rstable.eof
if right(rstable("TABLE_NAME"),1)="$" then%>
<tr>
<td align="left" class="t_td"><input type="radio" name="xls_table" value="<%=rstable("TABLE_NAME")%>"/>
<%=rstable("TABLE_NAME")%></td>
</tr>
<%
end if
rstable.movenext
loop%>
</table></td>
<td align="center" valign="top">
<table width="100" border="0" cellspacing="0" cellpadding="0">
<%set rstable=mdb_conn.OpenSchema(20)
do while not rstable.eof
if not instr(rstable("TABLE_NAME"),"MSys")>0 then %>
<tr>
<td align="left" class="t_td"><input type="radio" name="mdb_table" value="<%=rstable("TABLE_NAME")%>"/>
<%=rstable("TABLE_NAME")%></td>
</tr>
<%end if
rstable.movenext
loop%>
</table>
</td>
</tr>
<tr>
<td colspan="2" align="center"><input type="submit" name="Submit3" value="下一步" /></td>
</tr>
</form>
</table>
<%end if
if request("action")="opentable" then%>
<script>
function setdiv(access_field){
var str=document.all("basediv").innerHTML
document.all("div_"+access_field).innerHTML=str.replace("baseselect","s_"+access_field)
}
</script>
<div id="basediv" style="display:none">
<select name="baseselect" style="height:20px;">
<option value="">----</option>
<%
if request("xls_table")="" then
showerr "请选择EXCEL表"
end if
if request("mdb_table")="" then
showerr "请选择ACCESS表"
end if
sql="select * from ["&request("xls_table")&"]"
set rs=Server.CreateObject("ADODB.Recordset")
rs.open sql,xls_conn,1,1
dim i
response.write rs.Fields.count
for i=0 to rs.Fields.count-1%>
<option value="<%=rs.Fields(i).Name%>"><%=rs.Fields(i).Name%></option>
<%next
rs.close
%></select></div>
<table width="400" border="0" cellspacing="1" cellpadding="2">
<form action="import.asp?action=import" method="post">
<tr>
<td class="title">选择导入字段
<input name="mdb_table" type="hidden" id="mdb_table" value="<%=request("mdb_table")%>" />
<input name="xls_table" type="hidden" id="xls_table" value="<%=request("xls_table")%>" /></td>
</tr>
<tr>
<td align="center">
<table border="0" cellpadding="0" cellspacing="2" bgcolor="#FFFFFF" style="background-color:#FFFFFF">
<tr>
<td align="left">ACCESS<span class="word"><%=request("mdb_table")%></span>表</td>
<td width="30" align="center"> </td>
<td>EXCEL<span class="word"><%=request("xls_table")%></span>表</td>
</tr>
<%sql="select * from ["&request("mdb_table")&"] where 1<>1"
rs.open sql,mdb_conn,1,1
for i=0 to rs.Fields.count-1%>
<tr>
<td align="center" class="border"><%=rs.Fields(i).Name %></td>
<td width="30" align="center" class="word"> <-</td>
<td id="div_<%=rs.Fields(i).Name%>"> </td>
<script>setdiv("<%=rs.Fields(i).Name%>");</script>
</tr>
<%next%>
</table></td>
</tr>
<tr>
<td align="center"><input type="submit" name="Submit4" value="开始导入" /></td>
</tr>
</form>
</table>
<%
end if
end if
%>
</center>
</body>
</html>
眼见问题要沉 心如刀绞啊 求大神拔冗指导下