分享
 
 
 

asp制作显示IP图片

王朝asp·作者佚名  2008-06-01
窄屏简体版  字體: |||超大  

本程序采用动网论坛格式数据库,可从动网论坛的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

%>

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有