最近剛做了一個asp 上傳圖片的程序,該程序可實現同時上傳表單和多張圖片,現增加了一個功能,能實現每月創建文件夾存儲當月上傳的圖片,現將代碼傳上來,供大家參考,希望大家多多指正.
1.建立數據庫,我用的是access數據庫
id 自動編號
.................................. '用於存儲表單內容
userfilepate '用於存儲圖片路徑
........................... '可存儲上傳多個圖片的路徑
2.上傳頁面:asp.asp
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<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">
<!--
.STYLE1 {color: #FF0000}
.STYLE2 {
font-size: 18px;
color: #3333CC;
font-weight: bold;
}
-->
</style>
<STYLE>
BODY {cursor:default}
.STYLE3 {color: #D4D0C8}
.STYLE4 {color: #0000FF}
body {
background-color: #00CCCC;
}
</STYLE>
</head>
<body οnlοad="webClock()">
<p align="center" class="STYLE2">交易准入資格認證</p>
<form name="form1" method="post" action="uptodir.asp" enctype="multipart/form-data" οnsubmit="return checkdata();">
<table width="669" border="0" cellspacing="0" cellpadding="0" id="table1" align="center">
<tr>
<td width="28%" bgcolor="#00CCCC"><span class="STYLE4">用戶名:<font class="Need STYLE1">*</font></span></td>
<td width="35%" bgcolor="#00CCCC"><input name="username" type="text" οnblur="checkdata()" /></td>
<td id="message1"></td>
</tr>
<tr>
<td width="28%" bgcolor="#00CCCC"><span class="STYLE4">姓名:<font class="Need STYLE1">*</font></span></td>
<td bgcolor="#00CCCC"><input name="name" type="text" οnblur="checkdata()" /> </td>
<td id="message2"></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%"><span class="STYLE4">性別:<font class="Need STYLE1">*</font></span></td>
<td><span class="STYLE4">
<select name="sex">
<option>男</option>
<option>女</option>
</select>
</span> </td>
</tr>
<tr>
<td width="28%" valign="top" bgcolor="#00CCCC"><span class="STYLE4">郵政編碼:<font class="Need STYLE1">*</font></span></td>
<td bgcolor="#00CCCC"><input name="postcode" type="text" οnblur="checkdata()" size="20" maxlength="6" /> </td>
<td id="message3"><span class="red"></span> </td>
</tr>
<tr>
<td width="28%" valign="top" bgcolor="#00CCCC"><span class="STYLE4">通信地址:<font class="Need STYLE1">*</font></span></td>
<td bgcolor="#00CCCC"><input name="mailaddress" type="text" οnblur="checkdata()" /> </td>
<td id="message4"></td>
</tr>
<tr>
<td width="28%" valign="top" bgcolor="#00CCCC"><span class="STYLE4">身份證地址:<font class="Need STYLE1">*</font></span></td>
<td bgcolor="#00CCCC"><input name="accountaddress" type="text" οnblur="checkdata()" /> </td>
<td id="message5"></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" valign="top"><span class="STYLE4">職業:</span></td>
<td><input name="vocational" type="text"/></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" valign="top"><span class="STYLE4">職務:</span></td>
<td><input name="position" type="text"/></td>
</tr>
<tr>
<td width="28%" valign="top" bgcolor="#00CCCC"><span class="STYLE4">常用電話:<font class="Need STYLE1">*</font></span></td>
<td bgcolor="#00CCCC" id="sss"><input name="homephone" type="text" οnblur="clean()" οnkeyup="change()" /> </td>
<td id="message" width="37%" bordercolorlight=#FF5050></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" valign="top"><span class="STYLE4">電子郵件:</span></td>
<td><input name="email" type="text"/></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" valign="top"><span class="STYLE4">單位或宿舍固定電話:</span></td>
<td><input name="telephone" type="text"/></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" valign="top"><span class="STYLE4">傳真:</span></td>
<td><input name="fax" type="text"/></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" valign="top"><span class="STYLE4">手機:</span></td>
<td><input name="mobile" type="text"/></td>
</tr>
<tr>
<td width="28%" valign="top" bgcolor="#00CCCC"><span class="STYLE4">身份證號碼:<font class="Need STYLE1">*</font></span></td>
<td bgcolor="#00CCCC"><input name="cardnumber" type="text" οnkeyup="checkcardnumber();" /> </td>
<td id="message7"></td>
</tr>
<tr>
<td width="28%" valign="top" bgcolor="#00CCCC"><span class="STYLE4">常用銀行帳號:<font class="Need STYLE1">*</font></span></td>
<td bgcolor="#00CCCC"><span class="STYLE4">
<select name="bankaccount">
<option></option>
<option>郵政</option>
<option>農行</option>
<option>工行</option>
<option>建行</option>
<option>交行</option>
<option>招行</option>
<option>中行</option>
<option>浦發</option>
</select>
<input name="bankaccount" type="text" maxlength="36" οnblur="return checkdata()" />
</span> </td>
<td id="message6"></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%"><span class="STYLE4">備用銀行帳號:</span></td>
<td><span class="STYLE4">
<label>
<textarea name="reservebankaccount" >
</textarea>
</label>
</span></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%"><span class="STYLE4">備用說明:</span></td>
<td><span class="STYLE4">
<label>
<textarea name="reservenote" >
</textarea>
</label>
</span>
</td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" height="83"><span class="STYLE4">上傳身份證圖片:</span><font class="Need STYLE1">*</font></td>
<td height="83"><span class="STYLE4">
<input type="file" name="file1" id="file1" οnblur="return checkdata()"/>
</span></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" height="83"><span class="STYLE4">上傳電話單圖片:</span></td>
<td><span class="STYLE4">
<input type="file" name="file2" id="file2" οnchange="picForm_Validator1()"/>
</span></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" height="83"><span class="STYLE4">上傳匯款憑據:</span></td>
<td><span class="STYLE4">
<input type="file" name="file3" id="file3" οnchange="picForm_Validator2()"/>
</span></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" height="83"><span class="STYLE4">上傳其它認證圖片:</span></td>
<td><span class="STYLE4">
<input type="file" name="file4" id="file4" οnchange="picForm_Validator3()"/>
</span></td>
</tr>
<tr bgcolor="#00CCCC">
<td width="28%" height="83"><span class="STYLE4">上傳其它認證圖片:</span></td>
<td><span class="STYLE4">
<input type="file" name="file5" id="file5" οnchange="picForm_Validator4()"/>
</span></td>
</tr>
<tr bgcolor="#00CCCC">
<td align =center><input name="Submit" type="submit" οnclick="checkdata()" value="上傳" /></td>
<td><input name="Submit2" type="reset" value="重置" /> </td>
</tr>
</table>
<p></p>
今天是：<input type="text" name="ddate" size="12" disabled="disabled">
現在時間：<input type="text" name="dtime" size="10" disabled="disabled"><br>
</form>
</body>
<script type="text/javascript" language="JavaScript">
var strTime,strDate;
function webClock()
{
var dNow = new Date();
var dHours = dNow.getHours();
var dMinutes = dNow.getMinutes();
var dSeconds = dNow.getSeconds();
strTime = dHours;
strTime += ((dMinutes<10)?":0":":")+dMinutes;
strTime += ((dSeconds<10)?":0":":")+dSeconds;
form1.dtime.value = strTime;
var dDate = dNow.getDate();
var dMonth = dNow.getMonth()+1;
var dYear = dNow.getYear();
strDate = dYear + "年";
strDate += ((dMonth<10)?"0":"")+dMonth + "月";
strDate += dDate + "日";
form1.ddate.value = strDate;
setTimeout("webClock()",1000);
}
</script>
<script language="JavaScript">
function change(){
document.getElementById("message").innerHTML="家庭電話，手機";
}
function clean(){
document.getElementById("message").innerHTML="";
}
</script>
<SCRIPT language=JavaScript>
function checkdata() {
if(document.form1.username.value.length==0){
document.getElementById("message1").innerHTML="用戶名不能爲空";
return false;
}
else{
document.getElementById("message1").innerHTML="";
}
if(document.form1.name.value.length==0){
document.getElementById("message2").innerHTML="姓名不能爲空";
return false;
}
else{
document.getElementById("message2").innerHTML="";
}
if(document.form1.postcode.value.length==0){
document.getElementById("message3").innerHTML="郵政編碼不能爲空";
return false;
}
else{
document.getElementById("message3").innerHTML="";
}
if(document.form1.mailaddress.value.length==0){
document.getElementById("message4").innerHTML="通信地址不能爲空";
return false;
}
else{
document.getElementById("message4").innerHTML="";
}
if(document.form1.accountaddress.value.length==0){
document.getElementById("message5").innerHTML="身份證地址不能爲空";
return false;
}
else{
document.getElementById("message5").innerHTML="";
}
if(document.form1.bankaccount.value.length==0){
document.getElementById("message6").innerHTML="常用銀行帳號不能爲空";
return false;
}
else{
document.getElementById("message6").innerHTML="";
}
}
function checkcardnumber(){
var str=parseInt(document.all.cardnumber.value.length);
if(str!=15 && str!=18){
document.getElementById("message7").innerHTML="身份證號碼不能爲空且只能爲15位和18位數字";
return false;
}
else{
document.getElementById("message7").innerHTML="";
}
}
</SCRIPT>
<script Language="JavaScript" Type="text/javascript">
function picForm_Validator(myform)
{
if(document.all.file1.value=="")
{
alert("請選擇上傳的照片！");
myform.mfile.focus();
return false;
}
var last=document.all.file1.value.match(/^(.*)(/.)(.{1,8})$/)[3]; //檢查上傳文件格式
last=last.toUpperCase();
if(last=="GIF" || last=="JPG" || last=="JPEG"){
}
else
{
alert("只能上傳.GIF,JPEG 或.JPG 文件,請重新選擇！");
parent.location.href="asp.asp";
return false;
}
return true;
}
function picForm_Validator1(myform)
{
if(document.all.file2.value=="")
{
alert("請選擇上傳的照片！");
myform.mfile.focus();
return false;
}
var last=document.all.file2.value.match(/^(.*)(/.)(.{1,8})$/)[3]; //檢查上傳文件格式
last=last.toUpperCase();
if(last=="GIF" || last=="JPG" || last=="JPEG"){
}
else
{
alert("只能上傳.GIF,JPEG 或.JPG 文件,請重新選擇！");
parent.location.href="asp.asp";
return false;
}
return true;
}
function picForm_Validator2(myform)
{
if(document.all.file3.value=="")
{
alert("請選擇上傳的照片！");
myform.mfile.focus();
return false;
}
var last=document.all.file3.value.match(/^(.*)(/.)(.{1,8})$/)[3]; //檢查上傳文件格式
last=last.toUpperCase();
if(last=="GIF" || last=="JPG" || last=="JPEG"){
}
else
{
alert("只能上傳.GIF,JPEG 或.JPG 文件,請重新選擇！");
parent.location.href="asp.asp";
return false;
}
return true;
}
function picForm_Validator3(myform)
{
if(document.all.file4.value=="")
{
alert("請選擇上傳的照片！");
myform.mfile.focus();
return false;
}
var last=document.all.file4.value.match(/^(.*)(/.)(.{1,8})$/)[3]; //檢查上傳文件格式
last=last.toUpperCase();
if(last=="GIF" || last=="JPG" || last=="JPEG"){
}
else
{
alert("只能上傳.GIF,JPEG 或.JPG 文件,請重新選擇！");
parent.location.href="asp.asp";
return false;
}
return true;
}
function picForm_Validator4(myform)
{
if(document.all.file5.value=="")
{
alert("請選擇上傳的照片！");
myform.mfile.focus();
return false;
}
var last=document.all.file5.value.match(/^(.*)(/.)(.{1,8})$/)[3]; //檢查上傳文件格式
last=last.toUpperCase();
if(last=="GIF" || last=="JPG" || last=="JPEG"){
}
else
{
alert("只能上傳.GIF ,JPEG 或.JPG 文件,請重新選擇！");
parent.location.href="asp.asp";
return false;
}
return true;
}
</script>
3.處理頁面:uptodir.asp
<!-- #include file="Upload1.asp" -->
<!-- #include file="conn1.asp" -->
<%
Server.ScriptTimeout =20*60 '上傳超時時間20分鐘
dim userfilepath,userfilepath1,userfilepath2
set f=server.CreateObject("scripting.filesystemobject")
y=year(date)
m=month(date) '紅色部分是實現每月創建文件夾
if len(m)<2 then m="0"&m
formPath = "UploadFiles/"&y&m&"/"
filename =server.mappath("UploadFiles/")&"/"&y&m&"/"
if not f.folderexists(filename) then f.createfolder(filename)
set f=nothing
Set upload= New DoteyUpload
Upload.SaveTo(formPath) '將文件根據其文件名統一保存在某路徑下
If upload.ErrMsg = "" then
Response.Write ("form傳遞來的數據:<BR>")
For each formName in upload.Form ''列出所有form數據
temp=temp & "||" & upload.Form(formName) '用字符串存表單所有變量
next
temp2=split(temp,"||") '將字符串拆開存入數組
username=temp2(1)
name=temp2(2)
sex=temp2(3)
postcode=temp2(4)
mailaddress=temp2(5)
accountaddress=temp2(6)
vocational=temp2(7)
position=temp2(8)
homephone=temp2(9)
email=temp2(10)
telephone=temp2(11)
fax=temp2(12)
mobile=temp2(13)
cardnumber=temp2(14)
bankaccount=temp2(15)
reservebankaccount=temp2(16)
reservenote=temp2(17)
i=1
Response.Write ("<BR><BR>已經成功上傳文件:<BR>")
set rs=server.createobject("adodb.recordset")
For Each formName In upload.Files ''列出所有上傳了的文件
Set file = upload.Files(formName) ''生成一個文件對象
userfilepath=formPath & File.FileName
'判斷
select case i
case 1
rs.open "submit",conn,1,3
rs.addnew
rs("username")=username
rs("name")=name
rs("sex")=sex
rs("postcode")=postcode
rs("mailaddress")=mailaddress
rs("accountaddress")=accountaddress
rs("vocational")=vocational
rs("position")=position
rs("homephone")=homephone
rs("email")=email
rs("telephone")=telephone
rs("fax")=fax
rs("mobile")=mobile
rs("cardnumber")=cardnumber
rs("bankaccount")=bankaccount
rs("reservebankaccount")=reservebankaccount
rs("reservenote")=reservenote
rs("ddate")=now()
rs("userfilepath").value=userfilepath
response.write "<hr>"
rs.update
rs.close
SQL="select top 1 id from submit ORDER BY ID DESC"
rs.open SQL,conn,1,3
MaxID = rs("ID")
rs.close
case 2
sql="select * from submit where id="&MaxID
rs.open sql,conn,1,3
rs("userfilepath1").value=userfilepath
response.write "<hr>"
rs.update
rs.close
case 3
sql="select * from submit where id="&MaxID
rs.open sql,conn,1,3
rs("userfilepath2").value=userfilepath
response.write "<hr>"
rs.update
rs.close
case 4
sql="select * from submit where id="&MaxID
rs.open sql,conn,1,3
rs("userfilepath3").value=userfilepath
response.write "<hr>"
rs.update
rs.close
case 5
sql="select * from submit where id="&MaxID
rs.open sql,conn,1,3
rs("userfilepath4").value=userfilepath
response.write "<hr>"
rs.update
rs.close
end select
i=i+1
Next
Else
Response.Write("上傳過程中出現錯誤:<br>" & Upload.ErrMsg)
End If
Set file=nothing
Set upload=nothing
conn.close()
%><style type="text/css">
<!--
body {
background-color: #00CCCC;
}
-->
</style>
<BR><A HREF=http://192.168.1.108/index.asp>返回首頁</A>
upload1.asp
<%
Dim DoteyUpload_SourceData
Class DoteyUpload
Public Files
Public Form
Public MaxTotalBytes
Public Version
Public ProgressID
Public ErrMsg
Private BytesRead
Private ChunkReadSize
Private Info
Private Progress
Private UploadProgressInfo
Private CrLf
Private Sub Class_Initialize()
Set Files = Server.CreateObject("Scripting.Dictionary") ' 上傳文件集合
Set Form = Server.CreateObject("Scripting.Dictionary") ' 表單集合
UploadProgressInfo = "DoteyUploadProgressInfo" ' Application的Key
MaxTotalBytes = 1 *1024 *1024 *1024 ' 默認最大1G
ChunkReadSize = 64 * 1024 ' 分塊大小64K
CrLf = Chr(13) & Chr(10) ' 換行
FileExt = "" ' 文件擴展名
Set DoteyUpload_SourceData = Server.CreateObject("ADODB.Stream")
DoteyUpload_SourceData.Type = 1 ' 二進制流
DoteyUpload_SourceData.Open
Version = "1.0 Beta" ' 版本
ErrMsg = "" ' 錯誤信息
Set Progress = New ProgressInfo
End Sub
' 將文件根據其文件名統一保存在某路徑下
Public Sub SaveTo(path)
Upload() ' 上傳
if right(path,1) <> "/" then path = path & "/"
' 遍歷所有已上傳文件
For Each fileItem In Files.Items
fileItem.FileName=Now()
fileItem.FileName=replace(fileItem.FileName," ", "")
fileItem.FileName=replace(fileItem.FileName,"-", "")
fileItem.FileName=replace(fileItem.FileName,":", "")
randomize
ranNum=int(90*rnd)+10
fileItem.FileName=fileItem.FileName&ranNum
fileItem.FileName=fileItem.FileName&".jpg"
fileItem.SaveAs path & fileItem.FileName
Next
' 保存結束後更新進度信息
Progress.ReadyState = "complete" '上傳結束
UpdateProgressInfo progressID
End Sub
' 分析上傳的數據，並保存到相應集合中
Public Sub Upload ()
Dim TotalBytes, Boundary
TotalBytes = Request.TotalBytes ' 總大小
If TotalBytes < 1 Then
Raise("無數據傳入")
Exit Sub
End If
If TotalBytes > MaxTotalBytes Then
Raise("您當前上傳大小爲" & TotalBytes/1000 & " K，最大允許爲" & MaxTotalBytes/1024 & "K")
Exit Sub
End If
Boundary = GetBoundary()
If IsNull(Boundary) Then
Raise("如果form中沒有包括multipart/form-data上傳是無效的")
Exit Sub ''如果form中沒有包括multipart/form-data上傳是無效的
End If
Boundary = StringToBinary(Boundary)
Progress.ReadyState = "loading" '開始上傳
Progress.TotalBytes = TotalBytes
UpdateProgressInfo progressID
Dim DataPart, PartSize
BytesRead = 0
'循環分塊讀取
Do While BytesRead < TotalBytes
'分塊讀取
PartSize = ChunkReadSize
if PartSize + BytesRead > TotalBytes Then PartSize = TotalBytes - BytesRead
DataPart = Request.BinaryRead(PartSize)
BytesRead = BytesRead + PartSize
DoteyUpload_SourceData.Write DataPart
Progress.UploadedBytes = BytesRead
Progress.LastActivity = Now()
' 更新進度信息
UpdateProgressInfo progressID
Loop
' 上傳結束後更新進度信息
Progress.ReadyState = "loaded" '上傳結束
UpdateProgressInfo progressID
Dim Binary
DoteyUpload_SourceData.Position = 0
Binary = DoteyUpload_SourceData.Read
Dim BoundaryStart, BoundaryEnd, PosEndOfHeader, IsBoundaryEnd
Dim Header, bFieldContent
Dim FieldName
Dim File
Dim TwoCharsAfterEndBoundary
BoundaryStart = InStrB(Binary, Boundary)
BoundaryEnd = InStrB(BoundaryStart + LenB(Boundary), Binary, Boundary, 0)
Do While (BoundaryStart > 0 And BoundaryEnd > 0 And Not IsBoundaryEnd)
' 獲取表單頭的結束位置
PosEndOfHeader = InStrB(BoundaryStart + LenB(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf))
' 分離表單頭信息，類似於：
' Content-Disposition: form-data; name="file1"; filename="G:/homepage.txt"
' Content-Type: text/plain
Header = BinaryToString(MidB(Binary, BoundaryStart + LenB(Boundary) + 2, PosEndOfHeader - BoundaryStart - LenB(Boundary) - 2))
' 分離表單內容
bFieldContent = MidB(Binary, (PosEndOfHeader + 4), BoundaryEnd - (PosEndOfHeader + 4) - 2)
FieldName = GetFieldName(Header)
' 如果是附件
If InStr (Header,"filename=""") > 0 Then
Set File = New FileInfo
' 獲取文件相關信息
Dim clientPath
clientPath = GetFileName(Header)
File.FileName = GetFileNameByPath(clientPath)
File.FileExt = GetFileExt(clientPath)
File.FilePath = clientPath
File.FileType = GetFileType(Header)
File.FileStart = PosEndOfHeader + 3
File.FileSize = BoundaryEnd - (PosEndOfHeader + 4) - 2
File.FormName = FieldName
' 如果該文件不爲空並不存在該表單項保存之
If Not Files.Exists(FieldName) And File.FileSize > 0 Then
Files.Add FieldName, File
End If
'表單數據
Else
' 允許同名表單
If Form.Exists(FieldName) Then
Form(FieldName) = Form(FieldName) & "," & BinaryToString(bFieldContent)
Else
Form.Add FieldName, BinaryToString(bFieldContent)
End If
End If
' 是否結束位置
TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, BoundaryEnd + LenB(Boundary), 2))
IsBoundaryEnd = TwoCharsAfterEndBoundary = "--"
If Not IsBoundaryEnd Then ' 如果不是結尾, 繼續讀取下一塊
BoundaryStart = BoundaryEnd
BoundaryEnd = InStrB(BoundaryStart + LenB(Boundary), Binary, Boundary)
End If
Loop
' 解析文件結束後更新進度信息
Progress.UploadedBytes = TotalBytes
Progress.ReadyState = "interactive" '解析文件結束
UpdateProgressInfo progressID
End Sub
'異常信息
Private Sub Raise(Message)
ErrMsg = ErrMsg & "[" & Now & "]" & Message & "<BR>"
Progress.ErrorMessage = Message
UpdateProgressInfo ProgressID
'call Err.Raise(vbObjectError, "DoteyUpload", Message)
End Sub
' 取邊界值
Private Function GetBoundary()
Dim ContentType, ctArray, bArray
ContentType = Request.ServerVariables("HTTP_CONTENT_TYPE")
ctArray = Split(ContentType, ";")
If Trim(ctArray(0)) = "multipart/form-data" Then
bArray = Split(Trim(ctArray(1)), "=")
GetBoundary = "--" & Trim(bArray(1))
Else '如果form中沒有包括multipart/form-data上傳是無效的
GetBoundary = null
Raise("如果form中沒有包括multipart/form-data上傳是無效的")
End If
End Function
' 將二進制流轉化成文本
Private Function BinaryToString(xBinary)
Dim Binary
if vartype(xBinary) = 8 then Binary = MultiByteToBinary(xBinary) else Binary = xBinary
Dim RS, LBinary
Const adLongVarChar = 201
Set RS = CreateObject("ADODB.Recordset")
LBinary = LenB(Binary)
if LBinary>0 then
RS.Fields.Append "mBinary", adLongVarChar, LBinary
RS.Open
RS.AddNew
RS("mBinary").AppendChunk Binary
RS.Update
BinaryToString = RS("mBinary")
Else
BinaryToString = ""
End If
End Function
Function MultiByteToBinary(MultiByte)
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(MultiByte)
if LMultiByte>0 then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk MultiByte & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
MultiByteToBinary = Binary
End Function
' 字符串到二進制
Function StringToBinary(String)
Dim I, B
For I=1 to len(String)
B = B & ChrB(Asc(Mid(String,I,1)))
Next
StringToBinary = B
End Function
'返回表單名
Private Function GetFieldName(infoStr)
Dim sPos, EndPos
sPos = InStr(infoStr, "name=")
EndPos = InStr(sPos + 6, infoStr, Chr(34) & ";")
If EndPos = 0 Then
EndPos = inStr(sPos + 6, infoStr, Chr(34))
End If
GetFieldName = Mid(infoStr, sPos + 6, endPos - _
(sPos + 6))
End Function
'返回文件名
Private Function GetFileName(infoStr)
Dim sPos, EndPos
sPos = InStr(infoStr, "filename=")
EndPos = InStr(infoStr, Chr(34) & CrLf)
GetFileName = Mid(infoStr, sPos + 10, EndPos - _
(sPos + 10))
End Function
'返回文件的 MIME type
Private Function GetFileType(infoStr)
sPos = InStr(infoStr, "Content-Type: ")
GetFileType = Mid(infoStr, sPos + 14)
End Function
'根據路徑獲取文件名
Private Function GetFileNameByPath(FullPath)
Dim pos
pos = 0
FullPath = Replace(FullPath, "/", "/")
pos = InStrRev(FullPath, "/") + 1
If (pos > 0) Then
GetFileNameByPath = Mid(FullPath, pos)
Else
GetFileNameByPath = FullPath
End If
End Function
'根據路徑獲取擴展名
Private Function GetFileExt(FullPath)
Dim pos
pos = InStrRev(FullPath,".")
if pos>0 then GetFileExt = Mid(FullPath, Pos)
End Function
' 更新進度信息
' 進度信息保存在Application中的ADODB.Recordset對象中
Private Sub UpdateProgressInfo(progressID)
Const adTypeText = 2, adDate = 7, adUnsignedInt = 19, adVarChar = 200
If (progressID <> "" And IsNumeric(progressID)) Then
Application.Lock()
if IsEmpty(Application(UploadProgressInfo)) Then
Set Info = Server.CreateObject("ADODB.Recordset")
Set Application(UploadProgressInfo) = Info
Info.Fields.Append "ProgressID", adUnsignedInt
Info.Fields.Append "StartTime", adDate
Info.Fields.Append "LastActivity", adDate
Info.Fields.Append "TotalBytes", adUnsignedInt
Info.Fields.Append "UploadedBytes", adUnsignedInt
Info.Fields.Append "ReadyState", adVarChar, 128
Info.Fields.Append "ErrorMessage", adVarChar, 4000
Info.Open
Info("ProgressID").Properties("Optimize") = true
Info.AddNew
Else
Set Info = Application(UploadProgressInfo)
If Not Info.Eof Then
Info.MoveFirst()
Info.Find "ProgressID = " & progressID
End If
If (Info.EOF) Then
Info.AddNew
End If
End If
Info("ProgressID") = clng(progressID)
Info("StartTime") = Progress.StartTime
Info("LastActivity") = Now()
Info("TotalBytes") = Progress.TotalBytes
Info("UploadedBytes") = Progress.UploadedBytes
Info("ReadyState") = Progress.ReadyState
Info("ErrorMessage") = Progress.ErrorMessage
Info.Update
Application.UnLock
End IF
End Sub
' 根據上傳ID獲取進度信息
Public Function GetProgressInfo(progressID)
Dim pi, Infos
Set pi = New ProgressInfo
If Not IsEmpty(Application(UploadProgressInfo)) Then
Set Infos = Application(UploadProgressInfo)
If Not Infos.Eof Then
Infos.MoveFirst
Infos.Find "ProgressID = " & progressID
If Not Infos.EOF Then
pi.StartTime = Infos("StartTime")
pi.LastActivity = Infos("LastActivity")
pi.TotalBytes = clng(Infos("TotalBytes"))
pi.UploadedBytes = clng(Infos("UploadedBytes"))
pi.ReadyState = Trim(Infos("ReadyState"))
pi.ErrorMessage = Trim(Infos("ErrorMessage"))
Set GetProgressInfo = pi
End If
End If
End If
Set GetProgressInfo = pi
End Function
' 移除指定的進度信息
Private Sub RemoveProgressInfo(progressID)
If Not IsEmpty(Application(UploadProgressInfo)) Then
Application.Lock
Set Info = Application(UploadProgressInfo)
If Not Info.Eof Then
Info.MoveFirst
Info.Find "ProgressID = " & progressID
If Not Info.EOF Then
Info.Delete
End If
End If
' 如果沒有記錄了, 直接釋放, 避免'800a0bcd'錯誤
If Info.RecordCount = 0 Then
Info.Close
Application.Contents.Remove UploadProgressInfo
End If
Application.UnLock
End If
End Sub
' 移除指定的進度信息
Private Sub RemoveOldProgressInfo(progressID)
If Not IsEmpty(Application(UploadProgressInfo)) Then
Dim L
Application.Lock
Set Info = Application(UploadProgressInfo)
Info.MoveFirst
Do
L = Info("LastActivity").Value
If IsEmpty(L) Then
Info.Delete()
ElseIf DateDiff("d", Now(), L) > 30 Then
Info.Delete()
End If
Info.MoveNext()
Loop Until Info.EOF
' 如果沒有記錄了, 直接釋放, 避免'800a0bcd'錯誤
If Info.RecordCount = 0 Then
Info.Close
Application.Contents.Remove UploadProgressInfo
End If
Application.UnLock
End If
End Sub
End Class
'---------------------------------------------------
' 進度信息 類
'---------------------------------------------------
Class ProgressInfo
Public UploadedBytes
Public TotalBytes
Public StartTime
Public LastActivity
Public ReadyState
Public ErrorMessage
Private Sub Class_Initialize()
UploadedBytes = 0 ' 已上傳大小
TotalBytes = 0 ' 總大小
StartTime = Now() ' 開始時間
LastActivity = Now() ' 最後更新時間
ReadyState = "uninitialized" ' uninitialized,loading,loaded,interactive,complete
ErrorMessage = ""
End Sub
' 總大小
Public Property Get TotalSize
TotalSize = FormatNumber(TotalBytes / 1024, 0, 0, 0, -1) & " K"
End Property
' 已上傳大小
Public Property Get SizeCompleted
SizeCompleted = FormatNumber(UploadedBytes / 1024, 0, 0, 0, -1) & " K"
End Property
' 已上傳秒數
Public Property Get ElapsedSeconds
ElapsedSeconds = DateDiff("s", StartTime, Now())
End Property
' 已上傳時間
Public Property Get ElapsedTime
If ElapsedSeconds > 3600 then
ElapsedTime = ElapsedSeconds / 3600 & " 時 " & (ElapsedSeconds mod 3600) / 60 & " 分 " & ElapsedSeconds mod 60 & " 秒"
ElseIf ElapsedSeconds > 60 then
ElapsedTime = ElapsedSeconds / 60 & " 分 " & ElapsedSeconds mod 60 & " 秒"
else
ElapsedTime = ElapsedSeconds mod 60 & " 秒"
End If
End Property
' 傳輸速率
Public Property Get TransferRate
If ElapsedSeconds > 0 Then
TransferRate = FormatNumber(UploadedBytes / 1024 / ElapsedSeconds, 2, 0, 0, -1) & " K/秒"
Else
TransferRate = "0 K/秒"
End If
End Property
' 完成百分比
Public Property Get Percentage
If TotalBytes > 0 Then
Percentage = fix(UploadedBytes / TotalBytes * 100) & "%"
Else
Percentage = "0%"
End If
End Property
' 估計剩餘時間
Public Property Get TimeLeft
If UploadedBytes > 0 Then
SecondsLeft = fix(ElapsedSeconds * (TotalBytes / UploadedBytes - 1))
If SecondsLeft > 3600 then
TimeLeft = SecondsLeft / 3600 & " 時 " & (SecondsLeft mod 3600) / 60 & " 分 " & SecondsLeft mod 60 & " 秒"
ElseIf SecondsLeft > 60 then
TimeLeft = SecondsLeft / 60 & " 分 " & SecondsLeft mod 60 & " 秒"
else
TimeLeft = SecondsLeft mod 60 & " 秒"
End If
Else
TimeLeft = "未知"
End If
End Property
End Class
'---------------------------------------------------
' 文件信息 類
'---------------------------------------------------
Class FileInfo
Dim FormName, FileName, FilePath, FileSize, FileType, FileStart, FileExt, NewFileName
Private Sub Class_Initialize
FileName = "" ' 文件名
FilePath = "" ' 客戶端路徑
FileSize = 0 ' 文件大小
FileStart= 0 ' 文件開始位置
FormName = "" ' 表單名
FileType = "" ' 文件Content Type
FileExt = "" ' 文件擴展名
NewFileName = "" '上傳後文件名
End Sub
Public Function Save()
SaveAs(FileName)
End Function
' 保存文件
Public Function SaveAs(fullpath)
Dim dr
SaveAs = false
If trim(fullpath) = "" Or FileStart = 0 Or FileName = "" Or right(fullpath,1) = "/" Then Exit Function
NewFileName = GetFileNameByPath(fullpath)
Set dr = CreateObject("Adodb.Stream")
dr.Mode = 3
dr.Type = 1
dr.Open
DoteyUpload_SourceData.position = FileStart
DoteyUpload_SourceData.copyto dr, FileSize
dr.SaveToFile MapPath(FullPath), 2
dr.Close
set dr = nothing
SaveAs = true
End function
' 返回Binary
Public Function GetBinary()
Dim Binary
If FileStart = 0 Then Exit Function
DoteyUpload_SourceData.Position = FileStart
Binary = DoteyUpload_SourceData.Read(FileSize)
GetBinary = Binary
End function
' 取服務器端路徑
Private Function MapPath(Path)
If InStr(1, Path, ":") > 0 Or Left(Path, 2) = "//" Then
MapPath = Path
Else
MapPath = Server.MapPath(Path)
End If
End function
'根據路徑獲取文件名
Private Function GetFileNameByPath(FullPath)
Dim pos
pos = 0
pos = InStrRev(FullPath, "/") + 1
If (pos > 0) Then
GetFileNameByPath = Mid(FullPath, pos)
Else
GetFileNameByPath = FullPath
End If
End Function
End Class
%>