枫林在线论坛精华区>>程序设计
[35228] 主题： 无组件上传图片到数据库中，最完整解决方案
作者： leaflet (Leaf闭关中…)
标题： 无组件上传图片到数据库中，最完整解决方案[转载]
来自： 61.165.*.*
发贴时间： 2003年01月06日 18:13:33
长度： 12320字
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" ty
pe="text/css">
<style type="text/css">
<!--
.tx1 { height: 20px; width: 30px; font-size: 9pt; border: 1px so
lid; border-color: black black 

#000000; color: #0000FF}
-->
</style>

<script language="JavaScript">
<!--
var bgc_on=new Array("#74D738","#FF9C17",&qu
ot;#3278AB","#486177","#078C00","#
007ECA")
var bgc_off=new Array("#4CAD12","FFB859",&qu
ot;5F9FD0","577590","08A700","009F
FF")

function turnon(obj1,id){
obj1.style.background=bgc_on;
}
function turnoff(obj1,id){
obj1.style.background=bgc_off;
}

//-->
</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" le
ftmargin="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=&
quot;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-r
ight: 1px #0E801E solid">
<table width=100% height=100% cellpadding=0 cellspacing=0 bor
der=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 bg
color=#4CAD12 style="border-top:0px #0E801E solid; border-b
ottom:1px #0E801E solid;"><font color=#C2F009 class=y
inying>管 理 中 心</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&
amp;"'"
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=#ee
eeee> 现在位置： 98243班 - 管理中心 - 添加新闻 
<tr><td height=3 bgcolor=#eeeeee style="border-bot
tom: 1px #cccccc solid"><p style="font-size:1pt&
quot;> 
<tr><td height=20 valign="bottom"> <fon
t color=green><% =username %>：你一共上传了 <font co
lor=red><% =rs.recordcount %></font> 张照片</f
ont> <a href="adminphoto.asp"><font color=
red><u>管理以前上传的照片</u></font></a&
gt;
<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&qu
ot;>
<tr><td height=20 colspan=2>
<tr><td height=25 width=15% align="right" cla
ss=L13>选择照片： <td> <input NAME="pic" T
YPE="FILE" class="tx1" style="width:300
"> <font color=red>拒绝色情、写真图等</font>


<tr><td height=25 width=20% align="right" cla
ss=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" cla
ss=L13>照片说明： <td> <textarea name="thetext&
quot; 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" val
ue=" 重 写 " style="border:1px double rgb(88,88,8
8);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") = "P
OST" Then 'Request method must be "POST"
Dim CT, PosB, Boundary, Length, PosE
CT = Request.ServerVariables("HTTP_Content_Type") 'rea
ds Content-Type header
If LCase(Left(CT, 19)) = "multipart/form-data" Then 'C
ontent-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 boun
dary
Length = CLng(Request.ServerVariables("HTTP_Content_Length&
quot;)) '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 " &am
p; FormatNumber(Length,0) & "B exceeds limit of " 
& FormatNumber(UploadSizeLimit,0) & "B"
exit function
end if
end if

If Length > 0 And Boundary <> "" Then 'Are th
ere required informations about upload ?
Boundary = "--" & Boundary
Dim Head, Binary
Binary = Request.BinaryRead(Length) 'Reads binary data from clie
nt

'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.&qu
ot;
End If
Set GetUpload = Result
End Function


Function SeparateFields(Binary, Boundary)
Dim PosOpenBoundary, PosCloseBoundary, PosEndOfHeader, isLastBou
ndary
Dim Fields
Boundary = StringToBinary(Boundary)

PosOpenBoundary = InstrB(Binary, Boundary)
PosCloseBoundary = InstrB(PosOpenBoundary + LenB(Boundary), Bina
ry, 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), PosCloseBounda
ry - (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, PosCloseB
oundary + 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), Bina
ry, 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, Fi
leName, Content_Type)
Content_Disposition = LTrim(SeparateField(Head, "content-di
sposition:", ";"))
Name = (SeparateField(Head, "name=", ";")) '
ltrim
If Left(Name, 1) = """" Then Name = Mid(Name
, 2, Len(Name) - 2)
FileName = (SeparateField(Head, "filename=", ";&q
uot;)) 'ltrim
If Left(FileName, 1) = """" Then FileName = 
Mid(FileName, 2, Len(FileName) - 2)
Content_Type = LTrim(SeparateField(Head, "content-type:&quo
t;, ";"))
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") = "P
OST" 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&
quot; 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")
%> 


========== * * * * * ==========
返回