一个广告作弊程序代码

ASP/Visual Basic代码

<%
'链接部分
Dim url,iurl,isNewDay
url = "[url]http://vip.ads99.net/banner468-0-b.php?userid=hackneeao&size=468x60[/url]"
iurl = "[url]http://vip.ads99.net/click.php?userid=hackneeao[/url]"
ClickNum = 80 '每天点击数
vIP = Request.ServerVariables("Remote_Addr")
CacheName = "Neeao" '缓存前缀，可以修改
DayCacheName = CacheName & "lastDay"
LastIPCacheName = CacheName & "LastIp"
ClickNumCacheName = CacheName & "ClickNum"
'防止查看本文件
ComeUrl = lcase(request.ServerVariables("HTTP_REFERER"))
if ComeUrl="" then
response.write "<br><p align=center><font color='red'>对不起，为了系统安全，不允许直接输入地址访问本文件。</font></p>"
response.End
End If
'第一次运行赋值
if isempty(Application(DayCacheName)) then Application(DayCacheName)=Date()
if isempty(Application(LastIPCacheName)) then Application(LastIPCacheName)="#202.196.176.222#"
if isempty(Application(ClickNumCacheName)) then Application(ClickNumCacheName)=0
'Application(LastIPCacheName) = "#202.196.176.222#"
'response.write Application(DayCacheName)
'response.write Application(ClickNumCacheName)
' 是否新的一天
if DateValue(Application(DayCacheName)) < DateValue(now()) then
Application(DayCacheName) = Date()
Application(LastIPCacheName) = "#202.196.176.222#"
Application(ClickNumCacheName) = 0
End If
If Application(ClickNumCacheName)>=ClickNum Then response.End
'是否刷新
if instr(Application(LastIPCacheName),"#" & vIP & "#") then
response.End
Else
' 更新最近需要防刷的IP
Application.Lock
Application(LastIPCacheName)=Application(LastIPCacheName) & "#" & vIP & "#"
Application.UnLock
Dim J,UrlNum,html
html= getHTTPPage(url)
urls=RegExpExecute(html)
links = Split(urls,"$$$")
For i = 0 To UBound(links)
If InStr(links(i),iurl)>0 Then
linkurl = links(i)
End If
Next
j = 3
Randomize
UrlNum = Int((20 * Rnd) + 1)
If UrlNum Mod j = 0 Then
response.write "document.write(""<script src="&linkurl"></script>"");"
Application.Lock
Application(ClickNumCacheName)=Application(ClickNumCacheName)+1
Application.UnLock
End If
End If
'获取链接函数
Function getHTTPPage(url)
Dim Http
Set Http=server.createobject("MSXML2.XMLHTTP")
Http.open "GET",url,false
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 BytesToBstr(body,Cset)
Dim objstream
Set objstream = Server.CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode =3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
Set objstream = nothing
End Function
'提取链接函数
Function RegExpExecute(strng)
Dim regEx, Match, Matches
Set regEx = New RegExp
regEx.Pattern = "((http|https):(\/\/|\\\\)((\w)+[.]){1,}(net|com|cn|org|cc|tv|([0-9]{1,3}))(((\/[\~]*|\\[\~]*)(\w)+)|[.](\w)+)*(((([?](\w)+){1}[=]*))*((\w)+){1}([\&](\w)+[\=](\w)+)*)*)"
regEx.IgnoreCase = true
regEx.Global = True
Set Matches = regEx.Execute(strng)
For Each Match in Matches
values=values&Match.Value"$$$"
Next
RegExpExecute = values
End Function
%>

更多的一个广告作弊程序代码请到论坛查看: http://BBS.TC711.COM

【双击滚屏】【评论】【收藏】【打印】【关闭】来源：互联网日期：2007-6-28