无组件上传图片至SQLSERVER数据库(示例)

在无组件上传我刚试成功，所以提供代码给大家一起共享。

/* addemployee.asp */

<html>

<head>

</head>

<!--

//选择分类

///////////////////////////////////////////////////////////////////////

function selectsort(txtSubject){

var returnValue

returnValue=window.showModalDialog("selMode.htm",null,"center:1;status:0;help:0;resized:0;dialogheight:300px;dialogwidth:206px");

if (returnValue!="" && returnValue!=null){

txtSubject.value=returnValue

}

///////////////////////////////////////////////////////////////////////

//合法性检查

function isOK(thisForm){

var strTemp,strValue,strLen,strExName

if(thisForm.txtTitle.value==""){

alert("提示：标题不能为空，请正确输入")

thisForm.txtTitle.focus()

return false

}

if(thisForm.txtSort.value==""){

alert("提示：请正确选择分类")

thisForm.txtSort.focus()

return false

}

/*检查图片类型*/

if(thisForm.file.value!=""){

strTemp=thisForm.file.value

strValue=strTemp.toLowerCase()

strLen=strTemp.length

strExName=strValue.substring(strLen-4,strLen)

if (strExName!=".jpg" && strExName!=".gif"){

alert("请选择jpg或者gif文件！")

return false

}

return true

}

//-->

</script>

<tr>

</tr>

<tr>

</td>

<td>

</td>

</tr>

<tr>

</td>

<td>

</td>

</tr>

<tr>

</td>

<td>

</td>

</tr>

<tr>

</td>

</div>

</td>

</tr>

<tr>

<p>1、您上传的图片大小请控制在<font color="#FF0000"><b>500K</b></font>以内,否则不允许上传<br>

2、你上传的图片必须为<font color="#FF0000"><b>150*130象素</b></font><br>

3、上传上传图片的格式为JPG或者GIF</p>

</td>

</tr>

<tr>

</td>

</tr>

</table>

</form>

</body>

</html>

*************************************************************************

/* transact1.asp*/

If Request.ServerVariables("REQUEST_METHOD") = "POST" Then

Dim Fields

Dim strTitle,strSort,strContent

Dim rs,sSql

Dim iMaxid

Dim strMaxid

Dim strlen

Set Fields = GetUpload()

strTitle=BinaryToString(Fields("txtTitle").value)

strSort=BinaryToString(Fields("txtSort").value)

strContent=BinaryToString(Fields("txtContent").value)

strSort=split(trim(strSort),"-")

if instr(1,lcase(Fields("file").FileName),".jpg")=0 and instr(1,lcase(Fields("file").FileName),".gif")=0 then

response.write "<script language='javascript'>alert('上传的图片必须是gif或者jpg格式的图片')</script>"

response.write "<script language='javascript'>window.location='addemployee.asp';</script>"

Response.end

end if

if Fields("file").Length>500000 then

response.write "<script language='javascript'>alert('只允许不大于500k的图片上传');</script>"

response.write "<script language='javascript'>window.location='addemployee.asp';</script>"

response.end

end if

'/*存至数据库*/

if Fields("file").FileName<>"" then

Set rs=Server.CreateObject("ADODB.Recordset")

sSql="select * from employee order by id desc"

rs.open sSql,conn,2,2

if not rs.eof then

iMaxid=Clng(rs("id"))+1

strlen=4-len(cstr(iMaxid))

strMaxid=string(strlen,"0") & cstr(iMaxid)

else

strMaxid="0001"

end if

rs.addnew

rs("id")=strMaxid

rs("title")=strTitle

rs("sort")=strSort(0)

rs("img").AppendChunk Fields("file").Value

rs("content")=quoteChg(strContent)

rs("todate")=date()

rs.update

rs.close

response.write "<script language='javascript'>alert('添加记录成功')</script>"

end if

**********************************************************************

/*fupload.inc*/

Dim UploadSizeLimit

'********************************** GetUpload **********************************

'.Name name of the form field (<Input Name="..." Type="File,...">)

'.ContentDisposition = Content-Disposition of the form field

'.FileName = Source file name for <input type=file>

'.ContentType = Content-Type for <input type=file>

'.Value = Binary value of the source field.

'.Length = Len of the binary data field

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

'response.write CT

'application/x-www-form-urlencoded

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

'********************************** SeparateFields **********************************

'This function retrieves the upload fields from binary data and retuns the fields as array

'Binary is safearray of all raw binary data from input.

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

BinaryToString=strto

End Function

Function StringToBinary(String)

Dim I, B

For I=1 to len(String)

B = B & ChrB(Asc(Mid(String,I,1)))

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

If PosF = 0 Then PosF = 1

GetFileName = Mid(FullPath, PosF)

End Function

</SCRIPT>

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