网站导航网学 原创论文 原创专题 网站设计 最新系统 原创论文 论文降重 发表论文 论文发表 UI设计定制 论文答辩PPT格式排版 期刊发表 论文专题
返回网学首页
网学原创论文
最新论文 推荐专题 热门论文 论文专题
当前位置: 网学 > 交易代码 > ASP精品代码 > 正文

ASP保存远程图片到本地,并生成缩略图

论文降重修改服务、格式排版等 获取论文 论文降重及排版 论文发表 相关服务

  正文:

  ASP通过XMLHTTP获取远程图片流数据,并保存到本地,把第一张采集到的图片生成缩略图。

  具体代码如下:

  <%

  '==================================================

  '函数名:CheckDir2

  '作 用:检查文件夹是否存在

  '参 数:FolderPath ------文件夹地址

  '==================================================

  Function CheckDir2(byval FolderPath)

  dim fso

  folderpath=Server.MapPath(".")&"\"&folderpath

  Set fso = Server.CreateObject("Scripting.FileSystemObject")

  If fso.FolderExists(FolderPath) then

  '存在

  CheckDir2 = True

  Else

  '不存在

  CheckDir2 = False

  End if

  Set fso = nothing

  End Function

  '==================================================

  '函数名:MakeNewsDir2

  '作 用:创建新的文件夹

  '参 数:foldername ------文件夹名称

  '==================================================

  Function MakeNewsDir2(byval foldername)

  dim fso

  Set fso = Server.CreateObject("Scripting.FileSystemObject")

  fso.CreateFolder(Server.MapPath(".") &"\" &foldername)

  If fso.FolderExists(Server.MapPath(".") &"\" &foldername) Then

  MakeNewsDir2 = True

  Else

  MakeNewsDir2 = False

  End If

  Set fso = nothing

  End Function

  '==================================================

  '函数名:DefiniteUrl

  '作 用:将相对地址转换为绝对地址

  '参 数:PrimitiveUrl ------要转换的相对地址

  '参 数:ConsultUrl ------当前网页地址

  '==================================================

  Function DefiniteUrl(Byval PrimitiveUrl,Byval ConsultUrl)

  Dim ConTemp,PriTemp,Pi,Ci,PriArray,ConArray

  If PrimitiveUrl="" or ConsultUrl="" or PrimitiveUrl="$Falsecontentquot; Then

  DefiniteUrl="$Falsecontentquot;

  Exit Function

  End If

  If Left(ConsultUrl,7)<>"HTTP://" And Left(ConsultUrl,7)<>"http://" Then

  ConsultUrl= "http://" & ConsultUrl

  End If

  ConsultUrl=Replace(ConsultUrl,"://",":\\")

  If Right(ConsultUrl,1)<>"/" Then

  If Instr(ConsultUrl,"/")>0 Then

  If Instr(Right(ConsultUrl,Len(ConsultUrl)-InstrRev(ConsultUrl,"/")),".")>0 then

  Else

  ConsultUrl=ConsultUrl & "/"

  End If

  Else

  ConsultUrl=ConsultUrl & "/"

  End If

  End If

  ConArray=Split(ConsultUrl,"/")

  If Left(PrimitiveUrl,7) = "http://" then

  DefiniteUrl=Replace(PrimitiveUrl,"://",":\\")

  ElseIf Left(PrimitiveUrl,1) = "/" Then

  DefiniteUrl=ConArray(0) & PrimitiveUrl

  ElseIf Left(PrimitiveUrl,2)="./" Then

  DefiniteUrl=ConArray(0) & Right(PrimitiveUrl,Len(PrimitiveUrl)-1)

  ElseIf Left(PrimitiveUrl,3)="../" then

  Do While Left(PrimitiveUrl,3)="../"

  PrimitiveUrl=Right(PrimitiveUrl,Len(PrimitiveUrl)-3)

  Pi=Pi+1

  Loop

  For Ci=0 to (Ubound(ConArray)-1-Pi)

  If DefiniteUrl<>"" Then

  DefiniteUrl=DefiniteUrl & "/" & ConArray(Ci)

  Else

  DefiniteUrl=ConArray(Ci)

  End If

  Next

  DefiniteUrl=DefiniteUrl & "/" & PrimitiveUrl

  Else

  If Instr(PrimitiveUrl,"/")>0 Then

  PriArray=Split(PrimitiveUrl,"/")

  If Instr(PriArray(0),".")>0 Then

  If Right(PrimitiveUrl,1)="/" Then

  DefiniteUrl="http:\\" & PrimitiveUrl

  Else

  If Instr(PriArray(Ubound(PriArray)-1),".")>0 Then

  DefiniteUrl="http:\\" & PrimitiveUrl

  Else

  DefiniteUrl="http:\\" & PrimitiveUrl & "/"

  End If

  End If

  Else

  If Right(ConsultUrl,1)="/" Then

  DefiniteUrl=ConsultUrl & PrimitiveUrl

  Else

  DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & PrimitiveUrl

  End If

  End If

  Else

  If Instr(PrimitiveUrl,".")>0 Then

  If Right(ConsultUrl,1)="/" Then

  If right(PrimitiveUrl,3)=".cn" or right(PrimitiveUrl,3)="com" or right(PrimitiveUrl,3)="net" or right(PrimitiveUrl,3)="org" Then

  DefiniteUrl="http:\\" & PrimitiveUrl & "/"

  Else

  DefiniteUrl=ConsultUrl & PrimitiveUrl

  End If

  Else

  If right(PrimitiveUrl,3)=".cn" or right(PrimitiveUrl,3)="com" or right(PrimitiveUrl,3)="net" or right(PrimitiveUrl,3)="org" Then

  DefiniteUrl="http:\\" & PrimitiveUrl & "/"

  Else

  DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl

  End If

  End If

  Else

  If Right(ConsultUrl,1)="/" Then

  DefiniteUrl=ConsultUrl & PrimitiveUrl & "/"

  Else

  DefiniteUrl=Left(ConsultUrl,InstrRev(ConsultUrl,"/")) & "/" & PrimitiveUrl & "/"

  End If

  End If

  End If

  End If

  If Left(DefiniteUrl,1)="/" then

  DefiniteUrl=Right(DefiniteUrl,Len(DefiniteUrl)-1)

  End if

  If DefiniteUrl<>"" Then

  DefiniteUrl=Replace(DefiniteUrl,"//","/")

  DefiniteUrl=Replace(DefiniteUrl,":\\","://")

  Else

  DefiniteUrl="$Falsecontentquot;

  End If

  End Function

  '==================================================

  '函数名:ReplaceSaveRemoteFile

  '作 用:替换、保存远程文件

  '参 数:ConStr ------ 要替换的字符串

  '参 数:StarStr ----- 前导

  '参 数:OverStr -----

  '参 数:IncluL ------

  '参 数:IncluR ------

  '参 数:SaveTf ------ 是否保存文件,False不保存,True保存

  '参 数:SaveFilePath- 保存文件夹

  '参 数: TistUrl------ 当前网页地址

  '==================================================

  Function ReplaceSaveRemoteFile(ConStr,StartStr,OverStr,IncluL,IncluR,SaveTf,SaveFilePath,TistUrl)

  If ConStr="$Falsecontentquot; or ConStr="" Then

  ReplaceSaveRemoteFile="$Falsecontentquot;

  Exit Function

  End If

  Dim TempStr,TempStr2,ReF,Matches,Match,Tempi,TempArray,TempArray2,OverTypeArray

  Set ReF = New Regexp

  ReF.IgnoreCase = True

  ReF.Global = True

  ReF.Pattern = "("&StartStr&").+?("&OverStr&")"

  Set Matches =ReF.Execute(ConStr)

  For Each Match in Matches

  If Instr(TempStr,Match.Value)=0 Then

  If TempStr<>"" then

  TempStr=TempStr & "$Arraycontentquot; & Match.Value

  Else

  TempStr=Match.Value

  End if

  End If

  Next

  Set Matches=nothing

  Set ReF=nothing

  If TempStr="" or IsNull(TempStr)=True Then

  ReplaceSaveRemoteFile=ConStr

  Exit function

  End if

  If IncluL=False then

  TempStr=Replace(TempStr,StartStr,"")

  End if

  If IncluR=False then

  If Instr(OverStr,"|")>0 Then

  OverTypeArray=Split(OverStr,"|")

  For Tempi=0 To Ubound(OverTypeArray)

  TempStr=Replace(TempStr,OverTypeArray(Tempi),"")

  Next

  Else

  TempStr=Replace(TempStr,OverStr,"")

  End If

  End if

  TempStr=Replace(TempStr,"""","")

  TempStr=Replace(TempStr,"'","")

  Dim RemoteFile,RemoteFileurl,SaveFileName,SaveFileType,ArrSaveFileName,RanNum

  If Right(SaveFilePath,1)="/" then

  SaveFilePath=Left(SaveFilePath,Len(SaveFilePath)-1)

  End If

  If SaveTf=True then

  If CheckDir2(SaveFilePath)=False Then

  If MakeNewsDir2(SaveFilePath)=False Then

  SaveTf=False

  End If

  End If

  End If

  SaveFilePath=SaveFilePath & "/"

  '图片转换/保存

  TempArray=Split(TempStr,"$Arraycontentquot;)

  For Tempi=0 To Ubound(TempArray)

  RemoteFileurl=DefiniteUrl(TempArray(Tempi),TistUrl)

  If RemoteFileurl<>"$Falsecontentquot; And SaveTf=True Then'保存图片

  ArrSaveFileName = Split(RemoteFileurl,".")

  SaveFileType=ArrSaveFileName(Ubound(ArrSaveFileName))'文件类型

  RanNum=Int(900*Rnd)+100

  SaveFileName = SaveFilePath&year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum&"."&SaveFileType

  Call SaveRemoteFile(SaveFileName,RemoteFileurl)

  ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)

  ElseIf RemoteFileurl<>"$Falsecontentquot; and SaveTf=False Then'不保存图片

  SaveFileName=RemoteFileUrl

  ConStr=Replace(ConStr,TempArray(Tempi),SaveFileName)

  End If

  If RemoteFileUrl<>"$Falsecontentquot; Then

  If UploadFiles="" then

  UploadFiles=SaveFileName

  Else

  UploadFiles=UploadFiles & "|" & SaveFileName

  End if

  End If

  Next

  ReplaceSaveRemoteFile=ConStr

  End function

  '==================================================

  '过程名:SaveRemoteFile

  '作 用:保存远程的文件到本地

  '参 数:LocalFileName ------ 本地文件名

  '参 数:RemoteFileUrl ------ 远程文件URL

  '==================================================

  sub SaveRemoteFile(LocalFileName,RemoteFileUrl)

  dim Ads,Retrieval,GetRemoteData

  Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")

  With Retrieval

  .Open "Get", RemoteFileUrl, False, "", ""

  .Send

  GetRemoteData = .ResponseBody

  End With

  Set Retrieval = Nothing

  Set Ads = Server.CreateObject("Adodb.Stream")

  With Ads

  .Type = 1

  .Open

  .Write GetRemoteData

  .SaveToFile server.MapPath(LocalFileName),2

  .Cancel()

  .Close()

  End With

  Set Ads=nothing

  end sub

  '==================================================

  '过程名:GetImg

  '作 用:取得文章中第一张图片

  '参 数:str ------ 文章内容

  '参 数:strpath ------ 保存图片的路径

  '==================================================

  Function GetImg(str,strpath)

  set objregEx = new RegExp

  objregEx.IgnoreCase = true

  objregEx.Global = true

  zzstr=""&strpath&"(.+?)\.(jpg|gif|png|bmp)"

  objregEx.Pattern = zzstr

  set matches = objregEx.execute(str)

  for each match in matches

  retstr = retstr &"|"& Match.Value

  next

  if retstr<>"" then

  Imglist=split(retstr,"|")

  Imgone=replace(Imglist(1),strpath,"")

  GetImg=Imgone

  else

  GetImg=""

  end if

  end function

  %>

  例:

  程序代码

  <form id="form1" name="form1" method="post" action="?action=test">

  <textarea name="body" cols="50" rows="5" id="body">

  <img height="180" src="/uploadfile/201401/3/7D18597766.jpg" width="240" border="0" />

  <img class="left"src="/uploadfile/201401/3/3D185910480.gif" width="114" />

  <img height="60" src="/uploadfile/201401/3/5D185910533.jpg" width="120" border="0" />

  <img height="60" alt="中国维和人数大国之首" src="/uploadfile/201401/3/1D185911531.jpg" width="120" border="0" />

  </textarea>

  <input type="submit" name="Submit" value="提交" />

  </form>

  <%

  if request.QueryString("action")="test" then

  '图片开始的字符串

  FilesStartStr="src="

  '图片结束的字符串

  FilesOverStr="gif|jpg|bmp"

  '保存图片的文件夹

  FilesPath="qq"

  '取得保存图片的网站URL 自动判断是绝对 还是相对路径

  NewsUrl="http://news.163.com"

  '取得文章内容

  Content =Request.Form("body")

  '开始保存图片

  Content=ReplaceSaveRemoteFile(Content,FilesStartStr,FilesOverStr,False,True,True,FilesPath,NewsUrl)

  '对新闻中的第一张图片创建缩略图

  if GetImg(Content,FilesPath)<>"" then

  Imgsrc=GetImg(Content,FilesPath)

  Imgsrc=replace(Imgsrc,FilesPath,"")

  Set Jpeg = Server.CreateObject("Persits.Jpeg")

  Path = Server.MapPath(""&FilesPath&"") & "\"&Imgsrc&""

  Jpeg.Open Path

  '如果图片宽小于等于120 高小于等于90 则不创建缩略图

  if Jpeg.OriginalWidth<=120 and Jpeg.Height<=90 then

  Jpeg.Width = Jpeg.OriginalWidth

  Jpeg.Height = Jpeg.OriginalHeight

  Smallimg=FilesPath&""&GetImg(Content,FilesPath)

  else

  '图片宽度高度/2

  Jpeg.Width = Jpeg.OriginalWidth / 2

  Jpeg.Height = Jpeg.OriginalHeight / 2

  Jpeg.Save Server.MapPath(""&FilesPath&"") & "\small_"&Imgsrc&""

  Smallimg=""&FilesPath&"/small_"&Imgsrc&""

  end if

  end if

  '显示结果

  response.Write("新闻中的第一张图片是:")

  response.Write("<img src="&FilesPath&"/"&GetImg(Content,FilesPath)&">")

  response.Write("<br>新闻中的第一张图片的缩略图是:")

  response.Write("<img src="&Smallimg&">")

  response.Write("<br>新的新闻内容(图片为本地):<br>")

  Response.Write(Content)

  Response.End()

  end if

  %>

  • 下一篇资讯: basehref使用方法详解
  • 设为首页 | 加入收藏 | 网学首页 | 原创论文 | 计算机原创
    版权所有 网学网 [Myeducs.cn] 您电脑的分辨率是 像素
    Copyright 2008-2020 myeducs.Cn www.myeducs.Cn All Rights Reserved 湘ICP备09003080号 常年法律顾问:王律师