無組件上傳圖片到數據庫中，最完整解決方案
'::::::: 此程序屬揚子原創 ::::::::::::::::::
':::::: 在sql2000，2000s中測試通過::::::::
':::::::聯系我：QQ：21112856，Email：yangzinet@hotmail.com:::::::::
'::::::: http://www.tingfo.net ::::::
up.htm
<!--#include file="inc/domin.asp"-->
<!--#include file="conn.asp"-->
<html>
<head>
<title><% =webname %></title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<link rel="stylesheet" href="main.css" type="text/css">
<style type="text/css">
<!--
.tx1 { height: 20px; width: 30px; font-size: 9pt; border: 1px solid; border-color: black black
#000000; color: #0000FF}
-->
</style>
<script language="JavaScript">
<!--
var bgc_on=new Array("#74D738","#FF9C17","#3278AB","#486177","#078C00","#007ECA")
var bgc_off=new Array("#4CAD12","FFB859","5F9FD0","577590","08A700","009FFF")
function turnon(obj1,id){
obj1.style.background=bgc_on[id];
}
function turnoff(obj1,id){
obj1.style.background=bgc_off[id];
}
//-->
</script>
<SCRIPT language=javascript>
function check_input()
{
if (Frm.pic.value=="")
{ alert("請選擇要上傳的圖片");
return false;
}
if (Frm.type.value=="")
{ alert("請選擇圖片類型");
return false;
}
if (Frm.thetext.value=="")
{ alert("請輸入照片說明");
return false;
}
return true;
}
</SCRIPT>
</head>
<body bgcolor="#555555" text="#000000" leftmargin="0" topmargin="0">
<table width=755 cellpadding=0 cellspacing=0 border=0 bgcolor=#ffffff align="center">
<tr>
<td height=100><img src="img/top.gif" align="top">
</table>
<!--#include file="inc/mulu.asp"-->
<table width=755 cellpadding=0 cellspacing=0 border=0 bgcolor=#ffffff align="center" bordercolor=#000000>
<tr>
<td height=400 width=180 bgcolor=#D1E9D5 style="border-right: 1px #0E801E solid">
<table width=100% height=100% cellpadding=0 cellspacing=0 border=0 align="center" bordercolor=#000000>
<tr><td height=30 align="center" class=L15><font color=#E96D08>歡迎你：<% =username %> 管理中心</font>
<tr><td height=23 align="center" class=L15 bgcolor=#4CAD12 style="border-top:0px #0E801E solid; border-bottom:1px #0E801E solid;"><font color=#C2F009 class=yinying>管 理 中 心</font>
<tr><td height=20 class=L13>
<!--#include file="inc/centermulu.asp"-->
<tr><td height=5>
<tr><td>
</table>
<td>
<%
set rs=server.createobject("adodb.recordset")
sql="select * from photo where author='"&username&"'"
rs.open sql,conn,1,1
%>
<table cellpadding=0 cellspacing=0 border=0 width=100% height=100%>
<tr><td height=3>
<tr><td height=3 bgcolor=#ffffff background=img/bj3.gif>
<tr><td height=20 valign="bottom" bgcolor=#eeeeee> 現在位置： 98243班 - 管理中心 - 添加新聞
<tr><td height=3 bgcolor=#eeeeee style="border-bottom: 1px #cccccc solid"><p style="font-size:1pt">
<tr><td height=20 valign="bottom"> <font color=green><% =username %>：你一共上傳了 <font color=red><% =rs.recordcount %></font> 張照片</font> <a href="adminphoto.asp"><font color=red><u>管理以前上傳的照片</u></font></a>
<tr><td bgcolor=#ffffff valign=top>
<table cellpadding=0 cellspacing=0 border=0 width=95% height=100% align="center">
<form action=addphoto.asp method=post name=Frm onSubmit="return check_input()" enctype="multipart/form-data">
<tr><td height=20 colspan=2>
<tr><td height=25 width=15% align="right" class=L13>選擇照片： <td> <input NAME="pic" TYPE="FILE" class="tx1" style="width:300"> <font color=red>拒絕色情、寫真圖等</font>
<tr><td height=25 width=20% align="right" class=L13>照片分類： <td> <select name="type">
<option selected value="">選擇類型</option>
<option value="班級合影">班級合影</option>
<option value="個人照片">個人照片</option>
<option value="恩師照片">恩師照片</option>
<option value="情人照片">情人照片</option>
<option value="友人照片">友人照片</option>
<option value="其他照片">其他照片</option>
</select>
<tr><td height=25 width=20% align="right" class=L13>照片說明： <td> <textarea name="thetext" cols="46" rows="7" style="border:1px double rgb(88,88,88);font:9pt">
</textarea> <font color=red>最多20個字符</font>
<tr><td height=5 colspan=2>
<tr><td height=25 colspan=2 align="center">
<input type="submit" name="Submit" value=" 提 交 " style="border:1px double rgb(88,88,88);font:9pt">
<input type="reset" name="Reset" value=" 重 寫 " style="border:1px double rgb(88,88,88);font:9pt">
<tr><td colspan=2>
</tr></form>
</table>
</table>
</table>
<!--#include file="inc/footer.asp"-->
</body>
</html>
fupload.inc
<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
'限制上傳圖片大小
Dim UploadSizeLimit
'********************************** 得到上傳數據 **********************************
Function GetUpload()
Dim Result
Set Result = Nothing
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method must be "POST"
Dim CT, PosB, Boundary, Length, PosE
CT = Request.ServerVariables("HTTP_Content_Type") 'reads Content-Type header
If LCase(Left(CT, 19)) = "multipart/form-data" Then 'Content-Type header must be "multipart/form-data"
'This is upload request.
'Get the boundary and length from Content-Type header
PosB = InStr(LCase(CT), "boundary=") 'Finds boundary
If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundary
Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Get Content-Length header
if "" & UploadSizeLimit<>"" then
UploadSizeLimit = clng(UploadSizeLimit)
if Length > UploadSizeLimit then
' on error resume next 'Clears the input buffer
' response.AddHeader "Connection", "Close"
' on error goto 0
Request.BinaryRead(Length)
Err.Raise 2, "GetUpload", "Upload size " & FormatNumber(Length,0) & "B exceeds limit of " & FormatNumber(UploadSizeLimit,0) & "B"
exit function
end if
end if
If Length > 0 And Boundary <> "" Then 'Are there required informations about upload ?
Boundary = "--" & Boundary
Dim Head, Binary
Binary = Request.BinaryRead(Length) 'Reads binary data from client
'Retrieves the upload fields from binary data
Set Result = SeparateFields(Binary, Boundary)
Binary = Empty 'Clear variables
Else
Err.Raise 10, "GetUpload", "Zero length request ."
End If
Else
Err.Raise 11, "GetUpload", "No file sent."
End If
Else
Err.Raise 1, "GetUpload", "Bad request method."
End If
Set GetUpload = Result
End Function
Function SeparateFields(Binary, Boundary)
Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary
Dim Fields
Boundary = StringToBinary(Boundary)
PosOpenBoundary = InstrB(Binary, Boundary)
PosCloseBoundary = InstrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0)
Set Fields = CreateObject("Scripting.Dictionary")
Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary)
'Header and file/source field data
Dim HeaderContent, FieldContent
'Header fields
Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
'Helping variables
Dim Field, TwoCharsAfterEndBoundary
'Get end of header
PosEndOfHeader = InstrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf))
'Separates field header
HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2)
'Separates field content
FieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2)
'Separates header fields from header
GetHeadFields BinaryToString(HeaderContent), Content_Disposition, FormFieldName, SourceFileName, Content_Type
'Create one field and assign parameters
Set Field = CreateUploadField()
Field.Name = FormFieldName
Field.ContentDisposition = Content_Disposition
Field.FilePath = SourceFileName
Field.FileName = GetFileName(SourceFileName)
Field.ContentType = Content_Type
Field.Value = FieldContent
Field.Length = LenB(FieldContent)
Fields.Add FormFieldName, Field
'Is this ending boundary ?
TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2))
'Binary.Mid(PosCloseBoundary + Len(Boundary), 2).String
isLastBoundary = TwoCharsAfterEndBoundary = "--"
If Not isLastBoundary Then 'This is not ending boundary - go to next form field.
PosOpenBoundary = PosCloseBoundary
PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary )
End If
Loop
Set SeparateFields = Fields
End Function
'********************************** Utilities **********************************
Function BinaryToString(str)
strto = ""
for i=1 to lenb(str)
if AscB(MidB(str, i, 1)) > 127 then
strto = strto & chr(Ascb(MidB(str, i, 1))*256+Ascb(MidB(str, i+1, 1)))
i = i + 1
else
strto = strto & Chr(AscB(MidB(str, i, 1)))
end if
next
BinaryToString=strto
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
'Separates header fields from upload header
Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName, Content_Type)
Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";"))
Name = (SeparateField(Head, "name=", ";")) 'ltrim
If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2)
FileName = (SeparateField(Head, "filename=", ";")) 'ltrim
If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2)
Content_Type = LTrim(SeparateField(Head, "content-type:", ";"))
End Function
'Separets one filed between sStart and sEnd
Function SeparateField(From, ByVal sStart, ByVal sEnd)
Dim PosB, PosE, sFrom
sFrom = LCase(From)
PosB = InStr(sFrom, sStart)
If PosB > 0 Then
PosB = PosB + Len(sStart)
PosE = InStr(PosB, sFrom, sEnd)
If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)
If PosE = 0 Then PosE = Len(sFrom) + 1
SeparateField = Mid(From, PosB, PosE - PosB)
Else
SeparateField = Empty
End If
End Function
'Separetes file name from the full path of file
Function GetFileName(FullPath)
Dim Pos, PosF
PosF = 0
For Pos = Len(FullPath) To 1 Step -1
Select Case Mid(FullPath, Pos, 1)
Case "/", "": PosF = Pos + 1: Pos = 0
End Select
Next
If PosF = 0 Then PosF = 1
GetFileName = Mid(FullPath, PosF)
End Function
</SCRIPT>
<SCRIPT RUNAT=SERVER LANGUAGE=JSCRIPT>
//The function creates Field object.
function CreateUploadField(){ return new uf_Init() }
function uf_Init(){
this.Name = null
this.ContentDisposition = null
this.FileName = null
this.FilePath = null
this.ContentType = null
this.Value = null
this.Length = null
}
</SCRIPT>
addphoto.asp
<!--#include file="conn.asp"-->
<!--#include file="inc/domin.asp"-->
<!--#include file="fupload.inc"-->
<%
if Request.ServerVariables("REQUEST_METHOD") = "POST" Then
Dim Fields
UploadSizeLimit=100000
Set Fields = GetUpload()
dim Field
For Each Field In Fields.Items
select case Field.name
case "thetext" sss=BinaryToString(Field.value)
case "type" fff=BinaryToString(Field.value)
case "submit" submit=BinaryToString(Field.value)
case "pic"
filename=field.FileName
fileContentType=field.ContentType
filevalue=field.value
end select
next
'---------------
if filename<>"" and fileContentType<>"image/gif" and
fileContentType<>"image/pjpeg" then
%>
<center>
<br><br>
<font color=red size=3>上傳的照片應該為GIF或JPG文件！</font><br><br>
<input type="button" value="重填" onclick="history.go( -1 );return
true;">
</center>
<%
else
'------------
'開始輸入
'-----------
response.write sss
response.write"<br>"
response.write fff
set rs=server.createobject("ADODB.recordset")
sql = "select * from tb where theid is null"
rs.Open sql,conn,3,3
rs.addnew
rs("author")=username
rs("thetext")=sss
rs("types")=fff
rs("hits")=1
rs("posttime")=now()
rs("photo").appendchunk filevalue
rs.update
rs.close
%>
<br><br>
<center><font color=red
size=3>成功輸入個人基本檔案！</font><br><br><form method="post"
action="personinf.asp"><input type="submit" value="返回"></form>
</center>
<%
end if
end if
%>
showpic.asp
<!--#include file="conn.asp"-->
<%
id=Request("id")
set rs=server.CreateObject("adodb.recordset")
sql="SELECT * FROM tb where theid="&id
rs.Open sql,conn,1,3
response.contenttype="image/gif"
Response.BinaryWrite rs("photo")
%>
':::::: 在sql2000，2000s中測試通過::::::::
':::::::聯系我：QQ：21112856，Email：yangzinet@hotmail.com:::::::::
'::::::: http://www.tingfo.net ::::::
up.htm
<!--#include file="inc/domin.asp"-->
<!--#include file="conn.asp"-->
<html>
<head>
<title><% =webname %></title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<link rel="stylesheet" href="main.css" type="text/css">
<style type="text/css">
<!--
.tx1 { height: 20px; width: 30px; font-size: 9pt; border: 1px solid; border-color: black black
#000000; color: #0000FF}
-->
</style>
<script language="JavaScript">
<!--
var bgc_on=new Array("#74D738","#FF9C17","#3278AB","#486177","#078C00","#007ECA")
var bgc_off=new Array("#4CAD12","FFB859","5F9FD0","577590","08A700","009FFF")
function turnon(obj1,id){
obj1.style.background=bgc_on[id];
}
function turnoff(obj1,id){
obj1.style.background=bgc_off[id];
}
//-->
</script>
<SCRIPT language=javascript>
function check_input()
{
if (Frm.pic.value=="")
{ alert("請選擇要上傳的圖片");
return false;
}
if (Frm.type.value=="")
{ alert("請選擇圖片類型");
return false;
}
if (Frm.thetext.value=="")
{ alert("請輸入照片說明");
return false;
}
return true;
}
</SCRIPT>
</head>
<body bgcolor="#555555" text="#000000" leftmargin="0" topmargin="0">
<table width=755 cellpadding=0 cellspacing=0 border=0 bgcolor=#ffffff align="center">
<tr>
<td height=100><img src="img/top.gif" align="top">
</table>
<!--#include file="inc/mulu.asp"-->
<table width=755 cellpadding=0 cellspacing=0 border=0 bgcolor=#ffffff align="center" bordercolor=#000000>
<tr>
<td height=400 width=180 bgcolor=#D1E9D5 style="border-right: 1px #0E801E solid">
<table width=100% height=100% cellpadding=0 cellspacing=0 border=0 align="center" bordercolor=#000000>
<tr><td height=30 align="center" class=L15><font color=#E96D08>歡迎你：<% =username %> 管理中心</font>
<tr><td height=23 align="center" class=L15 bgcolor=#4CAD12 style="border-top:0px #0E801E solid; border-bottom:1px #0E801E solid;"><font color=#C2F009 class=yinying>管 理 中 心</font>
<tr><td height=20 class=L13>
<!--#include file="inc/centermulu.asp"-->
<tr><td height=5>
<tr><td>
</table>
<td>
<%
set rs=server.createobject("adodb.recordset")
sql="select * from photo where author='"&username&"'"
rs.open sql,conn,1,1
%>
<table cellpadding=0 cellspacing=0 border=0 width=100% height=100%>
<tr><td height=3>
<tr><td height=3 bgcolor=#ffffff background=img/bj3.gif>
<tr><td height=20 valign="bottom" bgcolor=#eeeeee> 現在位置： 98243班 - 管理中心 - 添加新聞
<tr><td height=3 bgcolor=#eeeeee style="border-bottom: 1px #cccccc solid"><p style="font-size:1pt">
<tr><td height=20 valign="bottom"> <font color=green><% =username %>：你一共上傳了 <font color=red><% =rs.recordcount %></font> 張照片</font> <a href="adminphoto.asp"><font color=red><u>管理以前上傳的照片</u></font></a>
<tr><td bgcolor=#ffffff valign=top>
<table cellpadding=0 cellspacing=0 border=0 width=95% height=100% align="center">
<form action=addphoto.asp method=post name=Frm onSubmit="return check_input()" enctype="multipart/form-data">
<tr><td height=20 colspan=2>
<tr><td height=25 width=15% align="right" class=L13>選擇照片： <td> <input NAME="pic" TYPE="FILE" class="tx1" style="width:300"> <font color=red>拒絕色情、寫真圖等</font>
<tr><td height=25 width=20% align="right" class=L13>照片分類： <td> <select name="type">
<option selected value="">選擇類型</option>
<option value="班級合影">班級合影</option>
<option value="個人照片">個人照片</option>
<option value="恩師照片">恩師照片</option>
<option value="情人照片">情人照片</option>
<option value="友人照片">友人照片</option>
<option value="其他照片">其他照片</option>
</select>
<tr><td height=25 width=20% align="right" class=L13>照片說明： <td> <textarea name="thetext" cols="46" rows="7" style="border:1px double rgb(88,88,88);font:9pt">
</textarea> <font color=red>最多20個字符</font>
<tr><td height=5 colspan=2>
<tr><td height=25 colspan=2 align="center">
<input type="submit" name="Submit" value=" 提 交 " style="border:1px double rgb(88,88,88);font:9pt">
<input type="reset" name="Reset" value=" 重 寫 " style="border:1px double rgb(88,88,88);font:9pt">
<tr><td colspan=2>
</tr></form>
</table>
</table>
</table>
<!--#include file="inc/footer.asp"-->
</body>
</html>
fupload.inc
<SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT>
'限制上傳圖片大小
Dim UploadSizeLimit
'********************************** 得到上傳數據 **********************************
Function GetUpload()
Dim Result
Set Result = Nothing
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then 'Request method must be "POST"
Dim CT, PosB, Boundary, Length, PosE
CT = Request.ServerVariables("HTTP_Content_Type") 'reads Content-Type header
If LCase(Left(CT, 19)) = "multipart/form-data" Then 'Content-Type header must be "multipart/form-data"
'This is upload request.
'Get the boundary and length from Content-Type header
PosB = InStr(LCase(CT), "boundary=") 'Finds boundary
If PosB > 0 Then Boundary = Mid(CT, PosB + 9) 'Separetes boundary
Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Get Content-Length header
if "" & UploadSizeLimit<>"" then
UploadSizeLimit = clng(UploadSizeLimit)
if Length > UploadSizeLimit then
' on error resume next 'Clears the input buffer
' response.AddHeader "Connection", "Close"
' on error goto 0
Request.BinaryRead(Length)
Err.Raise 2, "GetUpload", "Upload size " & FormatNumber(Length,0) & "B exceeds limit of " & FormatNumber(UploadSizeLimit,0) & "B"
exit function
end if
end if
If Length > 0 And Boundary <> "" Then 'Are there required informations about upload ?
Boundary = "--" & Boundary
Dim Head, Binary
Binary = Request.BinaryRead(Length) 'Reads binary data from client
'Retrieves the upload fields from binary data
Set Result = SeparateFields(Binary, Boundary)
Binary = Empty 'Clear variables
Else
Err.Raise 10, "GetUpload", "Zero length request ."
End If
Else
Err.Raise 11, "GetUpload", "No file sent."
End If
Else
Err.Raise 1, "GetUpload", "Bad request method."
End If
Set GetUpload = Result
End Function
Function SeparateFields(Binary, Boundary)
Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBoundary
Dim Fields
Boundary = StringToBinary(Boundary)
PosOpenBoundary = InstrB(Binary, Boundary)
PosCloseBoundary = InstrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary, 0)
Set Fields = CreateObject("Scripting.Dictionary")
Do While (PosOpenBoundary > 0 And PosCloseBoundary > 0 And Not isLastBoundary)
'Header and file/source field data
Dim HeaderContent, FieldContent
'Header fields
Dim Content_Disposition, FormFieldName, SourceFileName, Content_Type
'Helping variables
Dim Field, TwoCharsAfterEndBoundary
'Get end of header
PosEndOfHeader = InstrB(PosOpenBoundary + Len(Boundary), Binary, StringToBinary(vbCrLf + vbCrLf))
'Separates field header
HeaderContent = MidB(Binary, PosOpenBoundary + LenB(Boundary) + 2, PosEndOfHeader - PosOpenBoundary - LenB(Boundary) - 2)
'Separates field content
FieldContent = MidB(Binary, (PosEndOfHeader + 4), PosCloseBoundary - (PosEndOfHeader + 4) - 2)
'Separates header fields from header
GetHeadFields BinaryToString(HeaderContent), Content_Disposition, FormFieldName, SourceFileName, Content_Type
'Create one field and assign parameters
Set Field = CreateUploadField()
Field.Name = FormFieldName
Field.ContentDisposition = Content_Disposition
Field.FilePath = SourceFileName
Field.FileName = GetFileName(SourceFileName)
Field.ContentType = Content_Type
Field.Value = FieldContent
Field.Length = LenB(FieldContent)
Fields.Add FormFieldName, Field
'Is this ending boundary ?
TwoCharsAfterEndBoundary = BinaryToString(MidB(Binary, PosCloseBoundary + LenB(Boundary), 2))
'Binary.Mid(PosCloseBoundary + Len(Boundary), 2).String
isLastBoundary = TwoCharsAfterEndBoundary = "--"
If Not isLastBoundary Then 'This is not ending boundary - go to next form field.
PosOpenBoundary = PosCloseBoundary
PosCloseBoundary = InStrB(PosOpenBoundary + LenB(Boundary), Binary, Boundary )
End If
Loop
Set SeparateFields = Fields
End Function
'********************************** Utilities **********************************
Function BinaryToString(str)
strto = ""
for i=1 to lenb(str)
if AscB(MidB(str, i, 1)) > 127 then
strto = strto & chr(Ascb(MidB(str, i, 1))*256+Ascb(MidB(str, i+1, 1)))
i = i + 1
else
strto = strto & Chr(AscB(MidB(str, i, 1)))
end if
next
BinaryToString=strto
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
'Separates header fields from upload header
Function GetHeadFields(ByVal Head, Content_Disposition, Name, FileName, Content_Type)
Content_Disposition = LTrim(SeparateField(Head, "content-disposition:", ";"))
Name = (SeparateField(Head, "name=", ";")) 'ltrim
If Left(Name, 1) = """" Then Name = Mid(Name, 2, Len(Name) - 2)
FileName = (SeparateField(Head, "filename=", ";")) 'ltrim
If Left(FileName, 1) = """" Then FileName = Mid(FileName, 2, Len(FileName) - 2)
Content_Type = LTrim(SeparateField(Head, "content-type:", ";"))
End Function
'Separets one filed between sStart and sEnd
Function SeparateField(From, ByVal sStart, ByVal sEnd)
Dim PosB, PosE, sFrom
sFrom = LCase(From)
PosB = InStr(sFrom, sStart)
If PosB > 0 Then
PosB = PosB + Len(sStart)
PosE = InStr(PosB, sFrom, sEnd)
If PosE = 0 Then PosE = InStr(PosB, sFrom, vbCrLf)
If PosE = 0 Then PosE = Len(sFrom) + 1
SeparateField = Mid(From, PosB, PosE - PosB)
Else
SeparateField = Empty
End If
End Function
'Separetes file name from the full path of file
Function GetFileName(FullPath)
Dim Pos, PosF
PosF = 0
For Pos = Len(FullPath) To 1 Step -1
Select Case Mid(FullPath, Pos, 1)
Case "/", "": PosF = Pos + 1: Pos = 0
End Select
Next
If PosF = 0 Then PosF = 1
GetFileName = Mid(FullPath, PosF)
End Function
</SCRIPT>
<SCRIPT RUNAT=SERVER LANGUAGE=JSCRIPT>
//The function creates Field object.
function CreateUploadField(){ return new uf_Init() }
function uf_Init(){
this.Name = null
this.ContentDisposition = null
this.FileName = null
this.FilePath = null
this.ContentType = null
this.Value = null
this.Length = null
}
</SCRIPT>
addphoto.asp
<!--#include file="conn.asp"-->
<!--#include file="inc/domin.asp"-->
<!--#include file="fupload.inc"-->
<%
if Request.ServerVariables("REQUEST_METHOD") = "POST" Then
Dim Fields
UploadSizeLimit=100000
Set Fields = GetUpload()
dim Field
For Each Field In Fields.Items
select case Field.name
case "thetext" sss=BinaryToString(Field.value)
case "type" fff=BinaryToString(Field.value)
case "submit" submit=BinaryToString(Field.value)
case "pic"
filename=field.FileName
fileContentType=field.ContentType
filevalue=field.value
end select
next
'---------------
if filename<>"" and fileContentType<>"image/gif" and
fileContentType<>"image/pjpeg" then
%>
<center>
<br><br>
<font color=red size=3>上傳的照片應該為GIF或JPG文件！</font><br><br>
<input type="button" value="重填" onclick="history.go( -1 );return
true;">
</center>
<%
else
'------------
'開始輸入
'-----------
response.write sss
response.write"<br>"
response.write fff
set rs=server.createobject("ADODB.recordset")
sql = "select * from tb where theid is null"
rs.Open sql,conn,3,3
rs.addnew
rs("author")=username
rs("thetext")=sss
rs("types")=fff
rs("hits")=1
rs("posttime")=now()
rs("photo").appendchunk filevalue
rs.update
rs.close
%>
<br><br>
<center><font color=red
size=3>成功輸入個人基本檔案！</font><br><br><form method="post"
action="personinf.asp"><input type="submit" value="返回"></form>
</center>
<%
end if
end if
%>
showpic.asp
<!--#include file="conn.asp"-->
<%
id=Request("id")
set rs=server.CreateObject("adodb.recordset")
sql="SELECT * FROM tb where theid="&id
rs.Open sql,conn,1,3
response.contenttype="image/gif"
Response.BinaryWrite rs("photo")
%>