//图片上传 〈SCRIPT RUNAT=SERVER LANGUAGE=VBSCRIPT〉 Function GetUpload(FormData) Dim DataStart,DivStr,DivLen,DataSize,FormFieldData '分隔标志串(+CRLF) DivStr = LeftB(FormData,InStrB(FormData,str2bin(VbCrLf)) + 1) '分隔标志串长度 DivLen = LenB(DivStr) PosOpenBoundary = InStrB(FormData,DivStr) PosCloseBoundary = InStrB(PosOpenBoundary + 1,FormData,DivStr) Set Fields = CreateObject("Scripting.Dictionary") While PosOpenBoundary 〉 0 And PosCloseBoundary 〉 0 'name起始位置(name="xxxxx")，加6是因为[name="]长度为6 FieldNameStart = InStrB(PosOpenBoundary,FormData,str2bin("name=")) + 6 FieldNameSize = InStrB(FieldNameStart,FormData,ChrB(34)) - FieldNameStart '(")的ASC值=34 FormFieldName = bin2str(MidB(FormData,FieldNameStart,FieldNameSize)) 'filename起始位置(filename="xxxxx") FieldFileNameStart = InStrB(PosOpenBoundary,FormData,str2bin("filename=")) + 10 If FieldFileNameStart 〈 PosCloseBoundary And FieldFileNameStart 〉 PosopenBoundary Then FieldFileNameSize = InStrB(FieldFileNameStart,FormData,ChrB(34)) - FieldFileNameStart '(")的ASC值=34 FormFileName = bin2str(MidB(FormData,FieldFileNameStart,FieldFileNameSize)) Else FormFileName = "" End If 'Content-Type起始位置(Content-Type: xxxxx) FieldFileCTStart = InStrB(PosOpenBoundary,FormData,str2bin("Content-Type:")) + 14 If FieldFileCTStart 〈 PosCloseBoundary And FieldFileCTStart 〉 PosOpenBoundary Then FieldFileCTSize = InStrB(FieldFileCTStart,FormData,str2bin(VbCrLf & VbCrLf)) - FieldFileCTStart FormFileCT = bin2str(MidB(FormData,FieldFileCTStart,FieldFileCTSize)) Else FormFileCT = "" End If '数据起始位置：2个CRLF开始 DataStart = InStrB(PosOpenBoundary,FormData,str2bin(VbCrLf & VbCrLf)) + 4 If FormFileName 〈〉 "" Then '数据长度，减1是因为数据文件的存取字节数问题(可能是AppendChunk方法的问题)： '由于字节数为奇数的图象存到数据库时会去掉最后一个字符导致图象不能正确显示, '字节数为偶数的数据文件就不会出现这个问题，因此必须保持字节数为偶数。 DataSize = InStrB(DataStart,FormData,DivStr) - DataStart - 1 FormFieldData = MidB(FormData,DataStart,DataSize) Else '数据长度，减2是因为分隔标志串前有一个CRLF DataSize = InStrB(DataStart,FormData,DivStr) - DataStart - 2 FormFieldData = bin2str(MidB(FormData,DataStart,DataSize)) End If '建立一个Dictionary集存储Form中各个Field的相关数据 Set Field = CreateUploadField() Field.Name = FormFieldName Field.FilePath = FormFileName Field.FileName = GetFileName(FormFileName) Field.ContentType = FormFileCT Field.Length = LenB(FormFieldData) Field.Value = FormFieldData Fields.Add FormFieldName, Field PosOpenBoundary = PosCloseBoundary PosCloseBoundary = InStrB(PosOpenBoundary + 1,FormData,DivStr) Wend Set GetUpload = Fields End Function '把二进制字符串转换成普通字符串函数 Function bin2str(binstr) Dim varlen,clow,ccc,skipflag '中文字符Skip标志 skipflag=0 ccc = "" If Not IsNull(binstr) Then varlen=LenB(binstr) For i=1 To varlen If skipflag=0 Then clow = MidB(binstr,i,1) '判断是否中文的字符 If AscB(clow) 〉 127 Then 'AscW会把二进制的中文双字节字符高位和低位反转，所以要先把中文的高低位反转 ccc =ccc & Chr(AscW(MidB(binstr,i+1,1) & clow)) skipflag=1 Else ccc = ccc & Chr(AscB(clow)) End If Else skipflag=0 End If Next End If bin2str = ccc End Function '把普通字符串转成二进制字符串函数 Function str2bin(varstr) str2bin="" For i=1 To Len(varstr) varchar=mid(varstr,i,1) varasc = Asc(varchar) ' asc对中文字符求出来的值可能为负数， ' 加上65536就可求出它的无符号数值 ' -1在机器内是用补码表示的0xffff, ' 其无符号值为65535,65535=-1+65536 ' 其他负数依次类推。 If varasc〈0 Then varasc = varasc + 65535 End If '对中文的处理：把双字节低位和高位分开 If varasc〉255 Then varlow = Left(Hex(Asc(varchar)),2) varhigh = right(Hex(Asc(varchar)),2) str2bin = str2bin & chrB("&H" & varlow) & chrB("&H" & varhigh) Else str2bin = str2bin & chrB(AscB(varchar)) End If Next End Function '取得文件名(去掉Path) Function GetFileName(FullPath) If FullPath 〈〉 "" Then FullPath = StrReverse(FullPath) FullPath = Left(FullPath, InStr(1, FullPath, "\") - 1) GetFileName = StrReverse(FullPath) Else GetFileName = "" End If End Function 〈/SCRIPT〉 〈SCRIPT RUNAT=SERVER LANGUAGE=JSCRIPT〉 function CreateUploadField(){ return new uf_Init() } function uf_Init(){ this.Name = null this.FileName = null this.FilePath = null this.ContentType = null this.Value = null this.Length = null } 〈/SCRIPT〉 //新闻添加 〈!--#include file="news_session.asp"--〉 〈html〉 〈head〉 〈meta http-equiv="Content-Language" content="zh-cn"〉 〈meta http-equiv="Content-Type" content="text/html; charset=gb2312"〉 〈style type="text/css"〉 .buttonface { BACKGROUND-COLOR: #0079F2; BORDER-BOTTOM: #333333 1px outset; BORDER-LEFT: #333333 1px outset; BORDER-RIGHT: #ffffff 1px outset; BORDER-TOP: #ffffff 1px outset; COLOR: #ffffff; FONT-SIZE: 9pta { color: #000000; text-decoration: none} 〈/style〉 〈SCRIPT ID=clientEventHandlersJS LANGUAGE=javascript〉 〈!-- function client_onblur(ii) { server=eval("form1.server"+ii) if(server.value==""){ client=eval("form1.client"+ii) clientvalue=client.value+"" varlen=clientvalue.length a=clientvalue.lastIndexOf('\\') clientvalue=clientvalue.substring(a+1) //alert(clientvalue); server.value=clientvalue } } function form1_onsubmit() { for(i=1;i〈1;i++){ client=eval("form1.client"+i) server=eval("form1.server"+i) if(client.value!="" && server.value==""){alert("上传后的文件名不能空！");server.focus();return false} } } //--〉 〈/SCRIPT〉 〈title〉新闻发布系统〈/title〉 〈/head〉 〈body bgcolor=#EDF0F5 topmargin=10 marginheight=5 leftmargin=4 marginwidth=0〉 〈form method="POST" action="news_input.asp" name="form1" enctype="multipart/form-data" LANGUAGE=javascript οnsubmit="return form1_onsubmit()"〉 〈div align="left"〉 〈table border="1" width="754" height="404"〉 〈tr align="center"〉 〈td width="754" height="28" colspan="3" style="font-size:11pt"〉〈strong〉新闻发布系统后台管理--新闻添加〈/strong〉〈/td〉 〈/tr〉 〈tr〉 〈td width="121" height="16" align="center" style="font-size:9pt"〉新闻标题〈/td〉 〈td width="617" height="16" colspan="2"〉 〈input type="text" name="news_title" size="87"〉〈/td〉 〈/tr〉 〈tr〉 〈td width="121" height="165" align="center" style="font-size:9pt"〉新闻内容〈/td〉 〈td width="617" height="165" colspan="2"〉〈textarea rows="11" name="news_content" cols="85"〉〈/textarea〉〈/td〉 〈/tr〉 〈tr〉 〈td width="121" height="21" align="center" style="font-size:9pt"〉新闻来源〈/td〉 〈td width="617" height="21" colspan="2"〉 〈input type="text" name="news_src" size="87"〉〈/td〉 〈/tr〉 〈tr〉 〈td width="121" height="20" align="center" style="font-size:9pt" 〉图片上传〈/td〉 〈td width="617" height="20" colspan="2"〉 〈input type="file" name="client1" size="20" readonly LANGUAGE=javascript οnblur="return client_onblur(1)" 〉 〈span style="font-size:9pt"〉〈/span〉 〈INPUT type="hidden" name="server1"〉 〈input type="hidden" value="mysession" name="mysession"〉 〈/td〉 〈/tr〉 〈/table〉 〈/div〉 〈p〉 〈input type="submit" value="递交" name="B1" class="buttonface"〉 〈input type="reset" value="全部重写" name="B2" class="buttonface"〉 〈input type="button" value="帐号修改" οnclick="location.href='admin/news_chadmin.asp'" name="B2" style="font-size:10pt;color:#000000;" class="buttonface"〉 〈input type="button" value="新闻修改" οnclick="location.href='news_admin1.asp'" name="B2" style="font-size:10pt;color:#000000;" class="buttonface"〉〈/p〉 〈/form〉 〈/body〉 〈/html〉 '################### news_input.asp 〈!--#include file="upload.inc"--〉 〈% 'Fields("xxx").Name 取得Form中xxx(Form Object)的名字 'Fields("xxx").FilePath 如果是file Object 取得文件的完整路径 'Fields("xxx").FileName 如果是file Object 取得文件名 'Fields("xxx").ContentType 如果是file Object 取得文件的类型 'Fields("xxx").Length 取得Form中xxx(Form Object)的数据长度 'Fields("xxx").Value 取得Form中xxx(Form Object)的数据内容 Dim FormData,FormSize,gnote,bnote,notes,binlen,binstr FormSize=Request.TotalBytes FormData=Request.BinaryRead(FormSize) Set Fields = GetUpload(FormData) '############判断输入错误 dim news_title,news_content,news_src,mysession mysession=Fields("mysession").value if len(mysession)=0 then Response.Write "非法登陆或超时请重新登陆" Response.End end if news_title=Fields("news_title").value news_title=replace(news_title,"|","|") news_content=Fields("news_content").value news_src=Fields("news_src").value news_src=replace(news_src,"|","|") if len(news_title)=0 then%〉 〈script〉 alert("出错！新闻标题不能为空"); history.go(-1); //window.location="news_add.asp"; 〈/script〉 〈%Response.end end if if len(news_content)=0 then%〉 〈script〉 alert("出错！新闻内容不能为空"); history.go(-1); 〈/script〉 〈%end if if len(news_src)=0 then%〉 〈script〉 alert("出错！新闻来源不能为空 ,上海治疗阳痿医院"); history.go(-1); 〈/script〉 〈%Response.end end if dim varchar varchar=right(Fields("server1").value,3) if len(varchar)〈〉0 then if varchar〈〉"gif" and varchar〈〉"jpg" then %〉 〈script〉 alert("出错！不能上传该图片类型"); history.go(-1); 〈/script〉 〈% Response.end else end if end if '###########将图片写入文件夹 set file_O=Server.CreateObject("Scripting.FileSystemObject") '##########当前时间做图片名 dim newname,mytime,newfile,filename,id,image endname=right(fields("server1").value,4) mytime=now() id=Year(mytime)&Month(mytime)&Day(mytime)&Hour(mytime)&Minute(MyTime)&Second(MyTime) imageid=id&endname '#############写入图片 newfile="client1" filename=Fields("server1").value If Fields(newfile).FileName〈〉"" Then file_name=Server.MapPath("./images/"&imageid&"") set outstream=file_O.CreateTextFile(file_name,true,false) binstr=Fields(newfile).Value binlen=1 varlen=lenb(binstr) for i=1 to varlen clow = MidB(binstr,i,1) If AscB(clow) = 255 then outstream.write chr(255) binlen=binlen+1 if (i mod 2)=0 then notes=gnote exit for end if elseif AscB(clow) 〉 128 then clow1=MidB(binstr,i+1,1) if AscB(clow1) 〈64 or AscB(clow1) =127 or AscB(clow1) = 255 then binlen=binlen+1 'if (binlen mod 2)=0 then binlen=binlen+1 outstream.write Chr(AscW(ChrB(128)&clow)) 'end if notes=bnote exit for else outstream.write Chr(AscW(clow1&clow)) binlen=binlen+2 i=i+1 if (i mod 2)=0 then notes=gnote exit for end if end if else outstream.write chr(AscB(clow)) binlen=binlen+1 if (i mod 2)=0 then notes=gnote exit for end if end if next outstream.close set outstream=file_O.OpenTextFile(file_name,8,false,-1) outstream.write midb(Fields(newfile).Value,binlen) outstream.close if notes=bnote then notes=notes&(binlen-1)&"字节处。" End If '###################################################################################### 把新闻数据结构写入newslist文件 dim mappath,mytext,myfso,contenttext,news_addtime,news_point news_point=1 news_addtime=mytime set myfso=createobject("scripting.filesystemobject") mappath=server.mappath("./") set mytext=myfso.opentextfile(mappath&"\new_list.asp",8,-1) dim mytext2 if len(varchar)〈〉0 then mytext2=trim(id&","&news_title&","&id&".txt"&","&news_src&","&news_point&","&news_addtime&","&imageid&"|") else mytext2=trim(id&","&news_title&","&id&".txt"&","&news_src&","&news_point&","&news_addtime&"|") end if mytext.writeline(mytext2) mytext.close '##############把新闻内容写入相应的文件中 set contenttext=myfso.OpenTextFile(mappath&"\news_content\"&id&".txt",8,-1) function htmlencode2(str) '#############字符处理函数 dim result dim l l=len(str) result="" dim i for i = 1 to l select case mid(str,i,1) case chr(34) result=result+"''" case "&" result=result+"&" case chr(13) result=result+"〈br〉" case " " result=result+" " case chr(9) result=result+" " case chr(32) if i+1〈=l and i-1〉0 then if mid(str,i+1,1)=chr(32) or mid(str,i+1,1)=chr(9) or mid(str,i-1,1)=chr(32) or mid(str,i-1,1)=chr(9) then result=result+" " else result=result+" " end if else result=result+" " end if case else result=result+mid(str,i,1) end select next htmlencode2=result end function '############################################################################ contenttext.write htmlencode2(news_content) contenttext.close set myfso=nothing %〉 〈script〉 alert("发布成功"); window.location="news_add.asp"; 〈/script〉 //新闻列表显示
转载于:https://www.cnblogs.com/chaorenman/p/4113056.html
相关资源：VB网络编程实例