本程序采用动网论坛格式数据库,可从动网论坛的data目录找到 数据库文件为:I***dress.MDB
'------------------------------------
'File: Ip.asp
<%R***onse.ContentType = "image/gif"
ConnDatabase
Dim tempip,myipnumeber,sql,rs1
Dim country,city
tempip=ReqIP
tempip = Split(tempip,".")
if Ubound(tempip)=3 then
For i=0 To Ubound(tempip)
tempip(i)=left(tempip(i),3)
if isnumeric(tempip(i)) then
tempip(i)=cint(tempip(i))
else
tempip(i)=0
end if
next
myipnumeber=tempip(0)*256*256*256+tempip(1)*256*256+tempip(2)*256+tempip(3)
End If
sql="select country,city from DV_Address where IP1<="&myipnumeber&" and IP2>="&myipnumeber
set rs***onn.execute(sql)
if not rs1.eof Then
country = rs1(0)
city = rs1(1)
Else
country = "51***o.Com"
city = ""
End If
rs***lose : Set rs1 = Nothing
CloseDatabase
Dim LocalFile,TargetFile
LocalFile = Se***r.MapPath("Ip.gif")
Dim Jpeg
Set Jpeg = Se***r.CreateObject("Pe***ts.Jpeg")
If -2147221005=Err then
Re***nse.write "没有这个组件,请安装!" '检查是否安装AspJpeg组件
Re***nse.End()
End If
Jp***Open (LocalFile) '打开图片
If er***umber then
Re***nse.write"打开图片失败,请检查路径!"
Re***nse.End()
End if
Dim aa
aa***eg.Binary '将原始数据赋给aa
'=========加文字水印====http:***w.devdao.com/=============
Jp***Canvas.Font.Color = &H000000 '水印文字颜色
Jp***Canvas.Font.Family = "宋体" '字体
Jp***Canvas.Font.Bold = False '是否加粗
Jp***Canvas.Font.Size = 12 '字体大小
Jp***Canvas.Font.ShadowColor = &Hffffff '阴影色彩
Jp***Canvas.Font.ShadowYOffset = 1
Jp***Canvas.Font.ShadowXOffset = 1
Jp***Canvas.Brush.Solid = False
Jp***Canvas.Font.Quality = 4 ' '输出质量
Jp***Canvas.PrintText 30,30,"-------------------------------------" '水印位置及文字
Jp***Canvas.PrintText 30,50," 你的IP: "& ReqIP
Jp***Canvas.PrintText 30,70," 你的位置: "&country&" "&city
Jp***Canvas.PrintText 30,90," 操作系统: "&ClientInfo(0)
Jp***Canvas.PrintText 30,110," 浏 览 器: "&RegExpFilter("Microsoft® ", ClientInfo(1), 0, "")
Jp***Canvas.PrintText 30,130,"-------------------------------------"
Jp***Canvas.PrintText 30,145,"个性签名来自风易在线 www.downcodes.com"
bb***eg.Binary '将文字水印处理后的值赋给bb,这时,文字水印没有不透明度
'============调整文字透明度================
Set MyJpeg = Se***r.CreateObject("Pe***ts.Jpeg")
MyJp***OpenBinary aa
Set Logo = Se***r.CreateObject("Pe***ts.Jpeg")
Lo***OpenBinary bb
My***g.DrawImage 0,0, Logo, 0.9 '0.3是透明度
cc***Jpeg.Binary '将最终结果赋值给cc,这时也可以生成目标图片了
Re***nse.BinaryWrite cc '将二进输出给浏览器
set aa=nothing
set bb=nothing
set cc=nothing
Jp***close : Set Jpeg = Nothing
My***g.Close : Set MyJpeg = Nothing
Lo***Close : Set Logo = Nothing
%>
'--------------------------------------------------
'File: conn.asp
<%dim conn,dbpath,UserIP
sub ConnDatabase
On Error Resume next
set co***server.createobject("ad***.connection")
DBPath = Se***r.MapPath("IP.MDB")
co***Open "Pr***der=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBPath
If Err Then
er***lear
Set Conn = Nothing
Re***nse.Write "数据库正在更新中,请稍后再试!"
Re***nse.End
End If
End Sub
Sub CloseDatabase
Co***close
Set Conn = Nothing
End Sub%>
'-------------------------------------------------
'File: co***g.asp
<%
Dim User_Agent
User_Agent = Re***st.ServerVariables("HTTP_USER_AGENT")
' ============================================
' 获取客户端配置
' ============================================
Public Function ClientInfo(sType)
If sType = 0 Then
If InStr(User_Agent, "Windows 98") Then
ClientInfo = "Windows 98"
ElseIf InStr(User_Agent, "Win 9x 4.90") Then
ClientInfo = "Windows ME"
ElseIf InStr(User_Agent, "Windows NT 5.0") Then
ClientInfo = "Windows 2000"
ElseIf InStr(User_Agent, "Windows NT 5.1") Then
ClientInfo = "Windows XP"
ElseIf InStr(User_Agent, "Windows NT 5.2") Then
ClientInfo = "Windows 2003"
ElseIf InStr(User_Agent, "Windows NT") Then
ClientInfo = "Windows NT"
ElseIf InStr(User_Agent, "unix") or InStr(User_Agent, "Linux") or InStr(User_Agent, "SunOS") or InStr(User_Agent, "BSD") Then
ClientInfo = "Unix & Linux"
Else
ClientInfo = "Other"
End If
ElseIf sType = 1 Then
If InStr(User_Agent, "MSIE 7") Then
ClientInfo = "Microsoft® Internet Explorer 7.0"
ElseIf InStr(User_Agent, "MSIE 6") Then
ClientInfo = "Microsoft® Internet Explorer 6.0"
ElseIf InStr(User_Agent, "MSIE 5") Then
ClientInfo = "Microsoft® Internet Explorer 5.0"
ElseIf InStr(User_Agent, "MSIE 4") Then
ClientInfo = "Microsoft® Internet Explorer 4.0"
ElseIf InStr(User_Agent, "Netscape") Then
ClientInfo = "Netscape®"
ElseIf InStr(User_Agent, "Opera") Then
ClientInfo = "Opera®"
Else
ClientInfo = "Other"
End If
End If
End Function
' ============================================
' 按照指定的正则表达式替换字符
' ============================================
Public Function RegExpFilter(Patrn, Str, sType, ReplaceWith)
Dim RegEx
Set RegEx = New RegExp
If sType = 1 Then
Re***.Global = True
Else
Re***.Global = False
End If
Re***.Pattern = Patrn
Re***.IgnoreCase = True
RegExpFilter = Re***.Replace(Str, ReplaceWith)
End Function
Public Function ReqIP()
ReqIP = Re***st.ServerVariables("HTTP_X_FORWARDED_FOR")
If ReqIP = "" or IsNull(ReqIP) Then ReqIP = Re***st.ServerVariables("REMOTE_ADDR")
End Function
%>