| 導購 | 订阅 | 在线投稿
分享
 
 
 

asp制作顯示IP圖片

來源:互聯網  2008-06-01 06:46:21  評論

本程序采用動網論壇格式數據庫,可從動網論壇的data目錄找到 數據庫文件爲:IPaddress.MDB

'------------------------------------

'File: Ip.asp

<!--#include file="conn.asp"-->

<!--#include file="inc/config.asp"-->

<%Response.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 rs1=conn.execute(sql)

if not rs1.eof Then

country = rs1(0)

city = rs1(1)

Else

country = "51Tiao.Com"

city = ""

End If

rs1.close : Set rs1 = Nothing

CloseDatabase

Dim LocalFile,TargetFile

LocalFile = Server.MapPath("Ip.gif")

Dim Jpeg

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

If -2147221005=Err then

Response.write "沒有這個組件,請安裝!" '檢查是否安裝AspJpeg組件

Response.End()

End If

Jpeg.Open (LocalFile) '打開圖片

If err.number then

Response.write"打開圖片失敗,請檢查路徑!"

Response.End()

End if

Dim aa

aa=Jpeg.Binary '將原始數據賦給aa

'=========加文字水印====http://www.devdao.com/=============

Jpeg.Canvas.Font.Color = &H000000 '水印文字顔色

Jpeg.Canvas.Font.Family = "宋體" '字體

Jpeg.Canvas.Font.Bold = False '是否加粗

Jpeg.Canvas.Font.Size = 12 '字體大小

Jpeg.Canvas.Font.ShadowColor = &Hffffff '陰影色彩

Jpeg.Canvas.Font.ShadowYOffset = 1

Jpeg.Canvas.Font.ShadowXOffset = 1

Jpeg.Canvas.Brush.Solid = False

Jpeg.Canvas.Font.Quality = 4 ' '輸出質量

Jpeg.Canvas.PrintText 30,30,"-------------------------------------" '水印位置及文字

Jpeg.Canvas.PrintText 30,50," 你的IP: "& ReqIP

Jpeg.Canvas.PrintText 30,70," 你的位置: "&country&" "&city

Jpeg.Canvas.PrintText 30,90," 操作系統: "&ClientInfo(0)

Jpeg.Canvas.PrintText 30,110," 浏 覽 器: "&RegExpFilter("Microsoft<sup>®</sup> ", ClientInfo(1), 0, "")

Jpeg.Canvas.PrintText 30,130,"-------------------------------------"

Jpeg.Canvas.PrintText 30,145,"個性簽名來自風易在線 www.knowsky.com"

bb=Jpeg.Binary '將文字水印處理後的值賦給bb,這時,文字水印沒有不透明度

'============調整文字透明度================

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

MyJpeg.OpenBinary aa

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

Logo.OpenBinary bb

MyJpeg.DrawImage 0,0, Logo, 0.9 '0.3是透明度

cc=MyJpeg.Binary '將最終結果賦值給cc,這時也可以生成目標圖片了

Response.BinaryWrite cc '將二進輸出給浏覽器

set aa=nothing

set bb=nothing

set cc=nothing

Jpeg.close : Set Jpeg = Nothing

MyJpeg.Close : Set MyJpeg = Nothing

Logo.Close : Set Logo = Nothing

%>

'--------------------------------------------------

'File: conn.asp

<%dim conn,dbpath,UserIP

sub ConnDatabase

On Error Resume next

set conn=server.createobject("adodb.connection")

DBPath = Server.MapPath("IP.MDB")

conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBPath

If Err Then

err.Clear

Set Conn = Nothing

Response.Write "數據庫正在更新中,請稍後再試!"

Response.End

End If

End Sub

Sub CloseDatabase

Conn.close

Set Conn = Nothing

End Sub%>

'-------------------------------------------------

'File: config.asp

<%

Dim User_Agent

User_Agent = Request.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<sup>®</sup> Internet Explorer 7.0"

ElseIf InStr(User_Agent, "MSIE 6") Then

ClientInfo = "Microsoft<sup>®</sup> Internet Explorer 6.0"

ElseIf InStr(User_Agent, "MSIE 5") Then

ClientInfo = "Microsoft<sup>®</sup> Internet Explorer 5.0"

ElseIf InStr(User_Agent, "MSIE 4") Then

ClientInfo = "Microsoft<sup>®</sup> Internet Explorer 4.0"

ElseIf InStr(User_Agent, "Netscape") Then

ClientInfo = "Netscape<sup>®</sup>"

ElseIf InStr(User_Agent, "Opera") Then

ClientInfo = "Opera<sup>®</sup>"

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

RegEx.Global = True

Else

RegEx.Global = False

End If

RegEx.Pattern = Patrn

RegEx.IgnoreCase = True

RegExpFilter = RegEx.Replace(Str, ReplaceWith)

End Function

Public Function ReqIP()

ReqIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")

If ReqIP = "" or IsNull(ReqIP) Then ReqIP = Request.ServerVariables("REMOTE_ADDR")

End Function

%>

本程序采用動網論壇格式數據庫,可從動網論壇的data目錄找到 數據庫文件爲:IPaddress.MDB '------------------------------------ 'File: Ip.asp <!--#include file="conn.asp"--> <!--#include file="inc/config.asp"--> <%Response.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 rs1=conn.execute(sql) if not rs1.eof Then country = rs1(0) city = rs1(1) Else country = "51Tiao.Com" city = "" End If rs1.close : Set rs1 = Nothing CloseDatabase Dim LocalFile,TargetFile LocalFile = Server.MapPath("Ip.gif") Dim Jpeg Set Jpeg = Server.CreateObject("Persits.Jpeg") If -2147221005=Err then Response.write "沒有這個組件,請安裝!" '檢查是否安裝AspJpeg組件 Response.End() End If Jpeg.Open (LocalFile) '打開圖片 If err.number then Response.write"打開圖片失敗,請檢查路徑!" Response.End() End if Dim aa aa=Jpeg.Binary '將原始數據賦給aa '=========加文字水印====http://www.devdao.com/============= Jpeg.Canvas.Font.Color = &H000000 '水印文字顔色 Jpeg.Canvas.Font.Family = "宋體" '字體 Jpeg.Canvas.Font.Bold = False '是否加粗 Jpeg.Canvas.Font.Size = 12 '字體大小 Jpeg.Canvas.Font.ShadowColor = &Hffffff '陰影色彩 Jpeg.Canvas.Font.ShadowYOffset = 1 Jpeg.Canvas.Font.ShadowXOffset = 1 Jpeg.Canvas.Brush.Solid = False Jpeg.Canvas.Font.Quality = 4 ' '輸出質量 Jpeg.Canvas.PrintText 30,30,"-------------------------------------" '水印位置及文字 Jpeg.Canvas.PrintText 30,50," 你的IP: "& ReqIP Jpeg.Canvas.PrintText 30,70," 你的位置: "&country&" "&city Jpeg.Canvas.PrintText 30,90," 操作系統: "&ClientInfo(0) Jpeg.Canvas.PrintText 30,110," 浏 覽 器: "&RegExpFilter("Microsoft<sup>®</sup> ", ClientInfo(1), 0, "") Jpeg.Canvas.PrintText 30,130,"-------------------------------------" Jpeg.Canvas.PrintText 30,145,"個性簽名來自風易在線 www.knowsky.com" bb=Jpeg.Binary '將文字水印處理後的值賦給bb,這時,文字水印沒有不透明度 '============調整文字透明度================ Set MyJpeg = Server.CreateObject("Persits.Jpeg") MyJpeg.OpenBinary aa Set Logo = Server.CreateObject("Persits.Jpeg") Logo.OpenBinary bb MyJpeg.DrawImage 0,0, Logo, 0.9 '0.3是透明度 cc=MyJpeg.Binary '將最終結果賦值給cc,這時也可以生成目標圖片了 Response.BinaryWrite cc '將二進輸出給浏覽器 set aa=nothing set bb=nothing set cc=nothing Jpeg.close : Set Jpeg = Nothing MyJpeg.Close : Set MyJpeg = Nothing Logo.Close : Set Logo = Nothing %> '-------------------------------------------------- 'File: conn.asp <%dim conn,dbpath,UserIP sub ConnDatabase On Error Resume next set conn=server.createobject("adodb.connection") DBPath = Server.MapPath("IP.MDB") conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBPath If Err Then err.Clear Set Conn = Nothing Response.Write "數據庫正在更新中,請稍後再試!" Response.End End If End Sub Sub CloseDatabase Conn.close Set Conn = Nothing End Sub%> '------------------------------------------------- 'File: config.asp <% Dim User_Agent User_Agent = Request.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<sup>®</sup> Internet Explorer 7.0" ElseIf InStr(User_Agent, "MSIE 6") Then ClientInfo = "Microsoft<sup>®</sup> Internet Explorer 6.0" ElseIf InStr(User_Agent, "MSIE 5") Then ClientInfo = "Microsoft<sup>®</sup> Internet Explorer 5.0" ElseIf InStr(User_Agent, "MSIE 4") Then ClientInfo = "Microsoft<sup>®</sup> Internet Explorer 4.0" ElseIf InStr(User_Agent, "Netscape") Then ClientInfo = "Netscape<sup>®</sup>" ElseIf InStr(User_Agent, "Opera") Then ClientInfo = "Opera<sup>®</sup>" 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 RegEx.Global = True Else RegEx.Global = False End If RegEx.Pattern = Patrn RegEx.IgnoreCase = True RegExpFilter = RegEx.Replace(Str, ReplaceWith) End Function Public Function ReqIP() ReqIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR") If ReqIP = "" or IsNull(ReqIP) Then ReqIP = Request.ServerVariables("REMOTE_ADDR") End Function %>
󰈣󰈤
王朝萬家燈火計劃
期待原創作者加盟
 
 
 
>>返回首頁<<
 
 
 
 
 熱帖排行
 
 
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有