asp发送携带任意附件的程序
演示效果：
发送端：
接收端：
Test_Upfile.asp
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312" />
<title>上传</title>
<style type="text/css">
</style>
<script language="JavaScript">
var num=2;
function show(obj)
{
if(obj.checked)
{
document.all.photoyn.style.display="";
document.all.photoyn.innerHTML="<input type=\"file\" size=\"25\" name=\"filePath1\" class=\"upfile\"><font color=\"red\"></font><table id=\"TB\" width=\"100%\" height=\"0px\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\"><tr><td></td></tr></table><input type=\"button\" value=\"＋\"title=\"增加一个上传\" onclick=\"oRow=TB.insertRow();oCell=oRow.insertCell();oCell.innerHTML='<input type=file size=25 name=filePath'+Number(num)+' class=upfile>';num=num+1\"> <input type=\"button\" value=\"－\" title=\"去掉一个上传\" onclick=\"oCell=TB.deleteRow()\">";
}
else
{
document.all.photoyn.innerHTML="";
document.all.photoyn.style.display="none";
}
}
</script>
</head>
<body>
<form id="form1" name="form1" method="post" action="Test_Save.asp" ENCTYPE="multipart/form-data">
<input name="nfile" type="checkbox" id="nfile" onClick="show(this)" value="a" />是否携带附件
<div id="photoyn" style="display:none;padding:0px 0 5px 0; border:1px #FF9900 solid; background:#FFCC66;"></div><br />
<!-- <input type="file" name="img1" id="img1"><br>
<input type="file" name="img2" id="img2"><br>-->
<input type="submit" name="Submit" value="发送邮件" />
</form>
</body>
</html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312" />
<title>上传</title>
<style type="text/css">
</style>
<script language="JavaScript">
var num=2;
function show(obj)
{
if(obj.checked)
{
document.all.photoyn.style.display="";
document.all.photoyn.innerHTML="<input type=\"file\" size=\"25\" name=\"filePath1\" class=\"upfile\"><font color=\"red\"></font><table id=\"TB\" width=\"100%\" height=\"0px\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\"><tr><td></td></tr></table><input type=\"button\" value=\"＋\"title=\"增加一个上传\" onclick=\"oRow=TB.insertRow();oCell=oRow.insertCell();oCell.innerHTML='<input type=file size=25 name=filePath'+Number(num)+' class=upfile>';num=num+1\"> <input type=\"button\" value=\"－\" title=\"去掉一个上传\" onclick=\"oCell=TB.deleteRow()\">";
}
else
{
document.all.photoyn.innerHTML="";
document.all.photoyn.style.display="none";
}
}
</script>
</head>
<body>
<form id="form1" name="form1" method="post" action="Test_Save.asp" ENCTYPE="multipart/form-data">
<input name="nfile" type="checkbox" id="nfile" onClick="show(this)" value="a" />是否携带附件
<div id="photoyn" style="display:none;padding:0px 0 5px 0; border:1px #FF9900 solid; background:#FFCC66;"></div><br />
<!-- <input type="file" name="img1" id="img1"><br>
<input type="file" name="img2" id="img2"><br>-->
<input type="submit" name="Submit" value="发送邮件" />
</form>
</body>
</html>
Test_Save.asp
<!-- #include file="upfile_class.asp" -->
<!-- #include file="Email_function.asp" -->
<%
'******************上传附件*******************************************
MailFile="MailFile\" '设置上传目录
ErrMsg="" '设置错误代码
upfilecount=0 '上传文件的个数
set upfile=new upfile_class ''建立上传对象
upfile.NoAllowExt="asp;exe;htm;html;aspx;cs;vb;js;" '设置上传类型的黑名单
upfile.GetData (20480000) '取得上传数据,限制最大上传20M
if upfile.isErr then
select case upfile.isErr
case 1:ErrMsg="你没有上传数据呀???是不是搞错了??"
case 2:ErrMsg="你上传的文件超出我们的限制,最大10M"
end select
else
for each formName in upfile.file
set oFile=upfile.file(formName) '获取文件对象
File_name=upfile.form(formName)'取得文本域的值
if not File_name>"" then File_name=oFile.filename '获取文件名称
if oFile.FileSize>0 then '防止失效文件
sPath=GetFilePath(Server.mappath("upfile.asp"),"\")&MailFile&upfile.GetNewFileName&"\" '取得上传目录
File_Path=sPath&File_name '文件在服务器上的完整路径
If AutoCreateFolder(sPath) Then
upfile.SaveToFile formName,File_Path '上传保存文件
if upfile.iserr then
ErrMsg=upfile.errmessage
else
upfilecount=upfilecount+1
'组合上传附件的路径
If upfilecount=1 then
File_Paths=File_Path
else
File_Paths=File_Paths&","&File_Path
end if
'response.Write("img1:------"&File_Path&"<br>")
end if
Else
ErrMsg="创建文件夹失败!"
End If
end if
next
end if
set upfile=nothing
'*******************发送邮件**********************************
J_Server = "218.244.146.105" '发送服务器
J_From = "********@********.com" '发送者地址
J_FromName = "********" '发送者姓名
J_UserName = "********@********.com" '身份验证的用户名
J_Password = "********" '身份验证的密码
J_To = "chthp@qq.com" '收件人地址
J_ToName = "杜毛" '收件人称谓
J_Subject = "图片测试！！！" '发送服务器
J_HTMLBody = "<html><body><font color=""red"">Hi, 一个漂亮的图片</font><br><br><img src=""http://powerproduct.com/images/logo.jpg""><br><br><img src=""images/ttt.gif""><br><br> 漂亮吗?</body></html>" '邮件内容
'J_Attachment="D:\1sdf1.gif" '邮件附件
If ErrMsg="" then
'发送邮件
IsSendEmail=SendEmail(J_Server,J_From,J_FromName,J_UserName,J_Password,J_To,J_ToName,J_Subject,J_HTMLBody,File_Paths,false)
If IsSendEmail then
response.Write(J_To&"---发送成功！")
end If
end if
%>
<%
function GetFilePath(FullPath,str)
If FullPath <> "" Then
GetFilePath = left(FullPath,InStrRev(FullPath, str))
Else
GetFilePath = ""
End If
End function
'--------------------------------
'自动创建指定的多级文件夹
'strPath为绝对路径
Function AutoCreateFolder(strPath) 'As Boolean
On Error Resume Next
Dim astrPath, ulngPath, i, strTmpPath
Dim objFSO
If InStr(strPath, "\") <=0 or InStr(strPath, ":") <= 0 Then
AutoCreateFolder = False
Exit Function
End If
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(strPath) Then
AutoCreateFolder = True
Exit Function
End If
astrPath = Split(strPath, "\")
ulngPath = UBound(astrPath)
strTmpPath = ""
For i = 0 To ulngPath
strTmpPath = strTmpPath & astrPath(i) & "\"
If Not objFSO.FolderExists(strTmpPath) Then
'创建
objFSO.CreateFolder(strTmpPath)
End If
Next
Set objFSO = Nothing
If Err = 0 Then
AutoCreateFolder = True
Else
AutoCreateFolder = False
End If
End Function
%>
<!-- #include file="Email_function.asp" -->
<%
'******************上传附件*******************************************
MailFile="MailFile\" '设置上传目录
ErrMsg="" '设置错误代码
upfilecount=0 '上传文件的个数
set upfile=new upfile_class ''建立上传对象
upfile.NoAllowExt="asp;exe;htm;html;aspx;cs;vb;js;" '设置上传类型的黑名单
upfile.GetData (20480000) '取得上传数据,限制最大上传20M
if upfile.isErr then
select case upfile.isErr
case 1:ErrMsg="你没有上传数据呀???是不是搞错了??"
case 2:ErrMsg="你上传的文件超出我们的限制,最大10M"
end select
else
for each formName in upfile.file
set oFile=upfile.file(formName) '获取文件对象
File_name=upfile.form(formName)'取得文本域的值
if not File_name>"" then File_name=oFile.filename '获取文件名称
if oFile.FileSize>0 then '防止失效文件
sPath=GetFilePath(Server.mappath("upfile.asp"),"\")&MailFile&upfile.GetNewFileName&"\" '取得上传目录
File_Path=sPath&File_name '文件在服务器上的完整路径
If AutoCreateFolder(sPath) Then
upfile.SaveToFile formName,File_Path '上传保存文件
if upfile.iserr then
ErrMsg=upfile.errmessage
else
upfilecount=upfilecount+1
'组合上传附件的路径
If upfilecount=1 then
File_Paths=File_Path
else
File_Paths=File_Paths&","&File_Path
end if
'response.Write("img1:------"&File_Path&"<br>")
end if
Else
ErrMsg="创建文件夹失败!"
End If
end if
next
end if
set upfile=nothing
'*******************发送邮件**********************************
J_Server = "218.244.146.105" '发送服务器
J_From = "********@********.com" '发送者地址
J_FromName = "********" '发送者姓名
J_UserName = "********@********.com" '身份验证的用户名
J_Password = "********" '身份验证的密码
J_To = "chthp@qq.com" '收件人地址
J_ToName = "杜毛" '收件人称谓
J_Subject = "图片测试！！！" '发送服务器
J_HTMLBody = "<html><body><font color=""red"">Hi, 一个漂亮的图片</font><br><br><img src=""http://powerproduct.com/images/logo.jpg""><br><br><img src=""images/ttt.gif""><br><br> 漂亮吗?</body></html>" '邮件内容
'J_Attachment="D:\1sdf1.gif" '邮件附件
If ErrMsg="" then
'发送邮件
IsSendEmail=SendEmail(J_Server,J_From,J_FromName,J_UserName,J_Password,J_To,J_ToName,J_Subject,J_HTMLBody,File_Paths,false)
If IsSendEmail then
response.Write(J_To&"---发送成功！")
end If
end if
%>
<%
function GetFilePath(FullPath,str)
If FullPath <> "" Then
GetFilePath = left(FullPath,InStrRev(FullPath, str))
Else
GetFilePath = ""
End If
End function
'--------------------------------
'自动创建指定的多级文件夹
'strPath为绝对路径
Function AutoCreateFolder(strPath) 'As Boolean
On Error Resume Next
Dim astrPath, ulngPath, i, strTmpPath
Dim objFSO
If InStr(strPath, "\") <=0 or InStr(strPath, ":") <= 0 Then
AutoCreateFolder = False
Exit Function
End If
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists(strPath) Then
AutoCreateFolder = True
Exit Function
End If
astrPath = Split(strPath, "\")
ulngPath = UBound(astrPath)
strTmpPath = ""
For i = 0 To ulngPath
strTmpPath = strTmpPath & astrPath(i) & "\"
If Not objFSO.FolderExists(strTmpPath) Then
'创建
objFSO.CreateFolder(strTmpPath)
End If
Next
Set objFSO = Nothing
If Err = 0 Then
AutoCreateFolder = True
Else
AutoCreateFolder = False
End If
End Function
%>
包含文件有两个，一个无惧上传类，一个emial发送类
Email_function.asp
<%
'===========================================================
'发送含任意内嵌附件和附件的Email函数
' J_Server 发送服务器
' J_From 发送者地址
' J_FromName 发送者姓名
' J_UserName 身份验证的用户名
' J_Password 身份验证的密码
' J_To 收件人地址
' J_ToName 收件人称谓
' J_Subject 发送服务器
' J_HTMLBody 邮件内容
' J_Attachment 邮件附件 文件之间用逗号隔开
' IsInner 是否包含内联附件
'===========================================================
Function SendEmail(J_Server,J_From,J_FromName,J_UserName,J_Password,J_To,J_ToName,J_Subject,J_HTMLBody,J_Attachment,IsInner)
Set JMail = Server.CreateObject("JMail.Message")
JMail.ISOEncodeHeaders = True
JMail.Silent = True
JMail.Charset = "gb2312"
JMail.From = J_From '发送者地址
JMail.FromName = J_FromName '发送者姓名
JMail.MailServerUserName = J_UserName '身份验证的用户名
JMail.MailServerPassword = J_Password '身份验证的密码
JMail.AddRecipient J_To, J_ToName '加入新的收件人
JMail.Subject = J_Subject '邮件标题
'**********增加普通附件********************
Temp_Att=split(J_Attachment,",")
For i=0 to ubound(Temp_Att)
JMail.AddAttachment(Trim(Temp_Att(i)))
Next
If IsInner then
'**********增加内嵌附件********************
str=J_HTMLBody
PicUrl=GetLocalPic_Url(str,2)
If Trim(PicUrl)<>"" then
Temp_Url=split(PicUrl,"|")
For i=0 to Ubound(Temp_Url)
tmp=JMail.AddAttachment(Server.MapPath(Temp_Url(i)))
J_HTMLBody=replace(J_HTMLBody,Temp_Url(i),"cid:"&tmp&"")
Next
End If
End If
JMail.HTMLBody = J_HTMLBody '邮件内容
flag = JMail.Send(J_Server) '发送服务器
JMail.Close()
SendEmail=flag
End Function
'===========================================================
'获取字符串中的本地图片地址
'Typ 1 所有图片；2本地图片；3本地图片
'===========================================================
Function GetLocalPic_Url(str,Typ)
Dim Pic_Url,Temp_Url
do while ContentInnerPicTF(str,"TF")
Temp_Url=ContentInnerPicTF(str,"PicUrl")
str=Replace(str,Temp_Url,"")
Select Case Typ
Case 1 '所有图片
Pic_Url=Pic_Url&"|"&Temp_Url
Case 2 '本地图片
If instr(Temp_Url,"http://")=0 then Pic_Url=Pic_Url&"|"&Temp_Url
Case 3 '本地图片
If instr(Temp_Url,"http://")<>0 then Pic_Url=Pic_Url&"|"&Temp_Url
End Select
If left(trim(Pic_Url),1)="|" then Pic_Url=right(Pic_Url,len(Pic_Url)-1)
loop
GetLocalPic_Url=Pic_Url
End Function
'===========================================================
'判断传入的字符传中是否包含本地图片并取得此图片地址
'===========================================================
Function ContentInnerPicTF(StrCon,ReturnTF)
Dim ConStr,Re,InnerPicAll,FistPicUrl,PicUrlStr
ConStr = StrCon & ""
Set Re = New RegExp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern = "(src\S+\.{1}(gif|jpg|png)(""|\'|>|\s)?)"
InnerPicAll = ""
Set InnerPicAll = Re.Execute(ConStr)
Set Re = Nothing
FistPicUrl = ""
For Each PicUrlStr in InnerPicAll
FistPicUrl = Replace(Replace(Replace(PicUrlStr,"src=",""),"'",""),"""","")
If LCase(Left(FistPicUrl,Len(sRootDir))) = LCase(sRootDir) Then
FistPicUrl = Mid(FistPicUrl,Len(sRootDir)+1)
End If
Exit For
Next
If ReturnTF = "TF" Then
If FistPicUrl <> "" And (Not IsNull(FistPicUrl)) then
ContentInnerPicTF = True
Else
ContentInnerPicTF = False
End If
ElseIf ReturnTF = "PicUrl" Then
If FistPicUrl <> "" And (Not IsNull(FistPicUrl)) then
ContentInnerPicTF = FistPicUrl
End If
End If
End Function
%>
'===========================================================
'发送含任意内嵌附件和附件的Email函数
' J_Server 发送服务器
' J_From 发送者地址
' J_FromName 发送者姓名
' J_UserName 身份验证的用户名
' J_Password 身份验证的密码
' J_To 收件人地址
' J_ToName 收件人称谓
' J_Subject 发送服务器
' J_HTMLBody 邮件内容
' J_Attachment 邮件附件 文件之间用逗号隔开
' IsInner 是否包含内联附件
'===========================================================
Function SendEmail(J_Server,J_From,J_FromName,J_UserName,J_Password,J_To,J_ToName,J_Subject,J_HTMLBody,J_Attachment,IsInner)
Set JMail = Server.CreateObject("JMail.Message")
JMail.ISOEncodeHeaders = True
JMail.Silent = True
JMail.Charset = "gb2312"
JMail.From = J_From '发送者地址
JMail.FromName = J_FromName '发送者姓名
JMail.MailServerUserName = J_UserName '身份验证的用户名
JMail.MailServerPassword = J_Password '身份验证的密码
JMail.AddRecipient J_To, J_ToName '加入新的收件人
JMail.Subject = J_Subject '邮件标题
'**********增加普通附件********************
Temp_Att=split(J_Attachment,",")
For i=0 to ubound(Temp_Att)
JMail.AddAttachment(Trim(Temp_Att(i)))
Next
If IsInner then
'**********增加内嵌附件********************
str=J_HTMLBody
PicUrl=GetLocalPic_Url(str,2)
If Trim(PicUrl)<>"" then
Temp_Url=split(PicUrl,"|")
For i=0 to Ubound(Temp_Url)
tmp=JMail.AddAttachment(Server.MapPath(Temp_Url(i)))
J_HTMLBody=replace(J_HTMLBody,Temp_Url(i),"cid:"&tmp&"")
Next
End If
End If
JMail.HTMLBody = J_HTMLBody '邮件内容
flag = JMail.Send(J_Server) '发送服务器
JMail.Close()
SendEmail=flag
End Function
'===========================================================
'获取字符串中的本地图片地址
'Typ 1 所有图片；2本地图片；3本地图片
'===========================================================
Function GetLocalPic_Url(str,Typ)
Dim Pic_Url,Temp_Url
do while ContentInnerPicTF(str,"TF")
Temp_Url=ContentInnerPicTF(str,"PicUrl")
str=Replace(str,Temp_Url,"")
Select Case Typ
Case 1 '所有图片
Pic_Url=Pic_Url&"|"&Temp_Url
Case 2 '本地图片
If instr(Temp_Url,"http://")=0 then Pic_Url=Pic_Url&"|"&Temp_Url
Case 3 '本地图片
If instr(Temp_Url,"http://")<>0 then Pic_Url=Pic_Url&"|"&Temp_Url
End Select
If left(trim(Pic_Url),1)="|" then Pic_Url=right(Pic_Url,len(Pic_Url)-1)
loop
GetLocalPic_Url=Pic_Url
End Function
'===========================================================
'判断传入的字符传中是否包含本地图片并取得此图片地址
'===========================================================
Function ContentInnerPicTF(StrCon,ReturnTF)
Dim ConStr,Re,InnerPicAll,FistPicUrl,PicUrlStr
ConStr = StrCon & ""
Set Re = New RegExp
Re.IgnoreCase = True
Re.Global = True
Re.Pattern = "(src\S+\.{1}(gif|jpg|png)(""|\'|>|\s)?)"
InnerPicAll = ""
Set InnerPicAll = Re.Execute(ConStr)
Set Re = Nothing
FistPicUrl = ""
For Each PicUrlStr in InnerPicAll
FistPicUrl = Replace(Replace(Replace(PicUrlStr,"src=",""),"'",""),"""","")
If LCase(Left(FistPicUrl,Len(sRootDir))) = LCase(sRootDir) Then
FistPicUrl = Mid(FistPicUrl,Len(sRootDir)+1)
End If
Exit For
Next
If ReturnTF = "TF" Then
If FistPicUrl <> "" And (Not IsNull(FistPicUrl)) then
ContentInnerPicTF = True
Else
ContentInnerPicTF = False
End If
ElseIf ReturnTF = "PicUrl" Then
If FistPicUrl <> "" And (Not IsNull(FistPicUrl)) then
ContentInnerPicTF = FistPicUrl
End If
End If
End Function
%>
upfile_class.asp
<%
'----------------------------------------------------------------------
'转发时请保留此声明信息,这段声明不并会影响你的速度!
'******************* 无惧上传类 V2.2 ************************************
'作者:梁无惧
'网站:http://www.25cn.com
'电子邮件:yjlrb@21cn.com
'版权声明:版权所有,源代码公开,各种用途均可免费使用,但是修改后必须把修改后的文件
'发送一份给作者.并且保留作者此版权信息
'**********************************************************************
'----------------------------------------------------------------------
'----------------------------------------------------------------------
'文件上传类
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
%>
'----------------------------------------------------------------------
'转发时请保留此声明信息,这段声明不并会影响你的速度!
'******************* 无惧上传类 V2.2 ************************************
'作者:梁无惧
'网站:http://www.25cn.com
'电子邮件:yjlrb@21cn.com
'版权声明:版权所有,源代码公开,各种用途均可免费使用,但是修改后必须把修改后的文件
'发送一份给作者.并且保留作者此版权信息
'**********************************************************************
'----------------------------------------------------------------------
'----------------------------------------------------------------------
'文件上传类
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
%>
