收藏本页
联系我们
论坛帮助

牛头网络技术论坛网管专区动网相关 → 复制文章时同时下载图片到服务器插件

垃圾帖子的防止方法 动网水印问题 sql里的字符替换方法 2003安全设置大全 短信检测提交问题

  共有335人关注过本帖树形打印

主题:复制文章时同时下载图片到服务器插件

帅哥,在线噢!
牛头

  1楼


头衔:站长
金币:5059
经验:6148
金钱:9145
等级:管理员
文章:572
精华:10
加为好友
发送短信
个性首页
复制文章时同时下载图片到服务器插件  发贴心情 Post By:2008-10-28 15:31:17 [只看该作者]

1.安装方法
  修改savepost.asp
  找到
 

If InStr(Content,"[/payto]") > 0 And InStr(Content,"[payto]") > 0 And InStr(Content,"(/seller)") > 0 And InStr(Content,"(seller)") > 0 Then isAlipayTopic = 2

  在下面插入
 
'--------------------牛头增加发帖下载远程图片插件开始------------------------------
  Dim niutou_pic_Remote
  niutou_pic_Remote=1 '是否开启远程下载图片功能1为开启,0为关闭
  If niutou_pic_Remote=1 Then
  GetImgSrc(Content)
  Dim pic_Remote,pic_local,kkk
  pic_Remote=Split(all_pic_Remote,"|||")
  pic_local=Split(all_pic_local,"|||")
  For kkk=0 To UBound(pic_Remote)
      Content=Replace(Content,pic_Remote(kkk),pic_local(kkk))
  Next
  End If

 
  再在此文件savepost.asp中的最后%>之前插入
 
'--------------------牛头增加发帖下载远程图片插件函数开始------------------------------
Dim all_pic_Remote,all_pic_local
all_pic_Remote="":all_pic_local=""
function GetImgSrc(str) '取得img 标签内容
    dim tmp,objRegExp,Matches,Match
    Set objRegExp = New Regexp
    objRegExp.IgnoreCase = True    '忽略大小写
    objRegExp.Global = True        '全文搜索 !关键!
    objRegExp.Pattern ="<img(.*?)src=""http://(.*?)""(.*?)>"
    Set Matches =objRegExp.Execute(str)
 Response.Write "<ol>"
 
    For Each Match in Matches
        Dim cjimgurl
  cjimgurl="http://"&objRegExp.Replace(Match.Value,"$2")
  saveimage cjimgurl
  all_pic_Remote=all_pic_Remote&cjimgurl&"|||"
  Response.Write "<li>图片:"&cjimgurl&"下载本地成功</li>"
    Next
    Response.Write "</ol>"
end Function


Function saveimage(from)
    Dim geturl,objStream,imgs
    geturl=trim(from)
 Dim from_filename
 from_filename=Split(geturl,"/")
    imgs=getHTTPPage1(geturl) '取得图片的具休内容的过程
    Set objStream = Server.CreateObject("ADODB.Stream") '建立ADODB.Stream对象,必须要ADO 2.5以上版本
    objStream.Type =1 '以二进制模式打开
    objStream.Open
    objstream.write imgs '将字符串内容写入缓冲
    objstream.SaveToFile server.mappath(Createurlnewfile(from_filename(UBound(from_filename)))),2 '-将缓冲的内容写入文件
    objstream.Close()'关闭对象
    Set objstream=Nothing
End Function

Function getHTTPPage1(url)
    on error resume next
    Dim http
    Set http=server.createobject("MSXML2.XMLHTTP") ' 使用xmlhttp的方法来获得图片的内容
    Http.open "GET",url,false
    Http.send()
    If Http.readystate<>4 then
    Exit Function
    End If
    getHTTPPage1=Http.responseBody
    Set http=Nothing
    If err.number<>0 Then err.Clear
End Function
Function getHTTPPage(url)
    Dim Http
    Set Http=server.createobject("MSXML2.XMLHTTP")
    Http.open "GET",url,False
 On Error Resume Next
    Http.send()
    If Http.readystate<>4 Then
        Exit Function
    End if
    getHTTPPage=bytesToBSTR(Http.responseBody,"gb2312")
    Set http=Nothing
    If err.number<>0 Then err.Clear
End Function
Function CreatePath(PathValue)
 Dim objFSO,Fsofolder,uploadpath
 '以年月创建上传文件夹,格式:2003-8
 uploadpath = year(now) & "-" & month(now)
 If Right(PathValue,1)<>"/" Then PathValue = PathValue&"/"
 On Error Resume Next
 Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
  If objFSO.FolderExists(Server.MapPath(PathValue & uploadpath))=False Then
   objFSO.CreateFolder Server.MapPath(PathValue & uploadpath)
  End If
  If Err.Number = 0 Then
   CreatePath = PathValue & uploadpath & "/"
  Else
   CreatePath = PathValue
  End If
 Set objFSO = Nothing
End Function

'为使文件不重名,用系统时间+随机数,作为文件名  
Function Createurlnewfile(filename)
 Dim ranNum,CreateName
 Randomize
    ranNum=int(999*rnd)  
    CreateName=year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum  
 Createurlnewfile= CreatePath("uploadfile")&CreateName&filename
 all_pic_local=all_pic_local&Createurlnewfile&"|||"
End Function
'--------------------牛头增加发帖下载远程图片插件函数结束------------------------------

 

这样上传覆盖savepost.asp,您发帖时帖子里有图片时就会一起下载到您的uploadfile目录相应的目录下了

我亲测可以用

 

*****************需要在html模式下才有效*******************

 

演示网址:http://bbs.niutou.net

 

2008-10-23日更新

 下载信息  [文件大小:   下载次数: ]
点击浏览该文件:复制文章同时下载远程图片到服务器插件.rar

[此贴子已经被作者于2008-10-28 15:37:38编辑过]


在线咨询技术 [牛头][早起的鸟儿有虫吃!]
 高速双线主机 支持(0中立(0反对(0回到顶部
帅哥哟,离线,有人找我吗?
『日月大师』

  2楼


头衔:
金币:0
经验:130
金钱:236
等级:新手上路
文章:8
精华:0
加为好友
发送短信
个性首页
  发贴心情 Post By:2008-10-29 9:57:23 [只看该作者]

这也是一个好东东!

 高速双线主机 支持(0中立(0反对(0回到顶部
帅哥,在线噢!
牛头

  3楼


头衔:站长
金币:5059
经验:6148
金钱:9145
等级:管理员
文章:572
精华:10
加为好友
发送短信
个性首页
  发贴心情 Post By:2008-12-5 16:09:06 [只看该作者]

好像不是很完美,有时会出错


在线咨询技术 [牛头][早起的鸟儿有虫吃!]
 牛头网电脑学院,尽显英雄本色 支持(0中立(0反对(0回到顶部