无组件上传图片到数据库中，最完整解决方案

王朝other·作者佚名 2006-11-24

宽屏版字体: 小|中|大|超大

-------------------------------------------------------------------

':::::: 此程序属扬子原创 ::::::::::::::::::

':::::: 在sql2000，2000s中测试通过::::::::

':::::: 联系我：QQ：21112856，Email：yangzinet@hotmail.com:::::::::

':::::: http://www.tingfo.net ::::::

up.htm

<html>

<head>

<!--

.tx1 { height: 20px; width: 30px; font-size: 9pt; border: 1px solid; border-color: black black

#000000; color: #0000FF}

-->

</style>

<!--

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>

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>

<tr>

</table>

<tr>

</table>

<td>

set rs=server.createobject("adodb.recordset")

sql="select * from photo where author='"&username&"'"

rs.open sql,conn,1,1

<tr><td height=20 valign="bottom" bgcolor=#eeeeee> 现在位置： 98243班 - 管理中心 - 添加新闻

<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>

</select>

</textarea> <font color=red>最多20个字符</font>

</tr></form>

</table>

</body>

</html>

fupload.inc

'限制上传图片大小

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

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_Ty

[1] [2] 下一页