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]; }
//-->
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; }
欢迎你：<% =username %> 管理中心
<% set rs=server.createobject("adodb.recordset") sql="select * from photo where author='"&username&"'" rs.open sql,conn,1,1 %>
'********************************** 得到上传数据 ********************************** 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)
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))
'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
//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 }
addphoto.asp
<% 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 %>
上传的照片应该为GIF或JPG文件！
<% else '------------ '开始输入 '----------- response.write sss response.write" " 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 %>
size=3>成功输入个人基本档案！
<% end if end if %>
showpic.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") %>
