用ASP制作动态显IP图片心灵博客

支付宝内搜索 9155838 即可领现金红包每天都能领哦
效果如下图所示：

本程序采用动网论坛格式数据库,可从动网论坛的data目录找到 数据库文件为:IPaddress.MDB
&#39;------------------------------------
&#39;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="sel&#101;ct country,city from DV_Address wh&#101;re IP1<="&myipnumeber&" and IP2>="&myipnumeber
set rs1=conn.execute(sql)
if not rs1.eof Then
    country = rs1(0)
    city = rs1(1)
Else
    country = "Fcbu.Com"
    city = ""
End If
rs1.close : Set rs1 = Nothing
CloseDatabase

Dim LocalFile,TargetFile
LocalFile = Server.MapPath("Ip.gif") 
Dim Jpeg 
Set Jpeg = Server.Cr&#101;ateObject("Persits.Jpeg") 
If -2147221005=Err then 
Response.write "没有这个组件，请安装!" &#39;检查是否安装AspJpeg组件 
Response.End() 
End If 
Jpeg.Open (LocalFile) &#39;打开图片 
If err.number then 
Response.write"打开图片失败,请检查路径！" 
Response.End() 
End if 
Dim aa 
aa=Jpeg.Binary &#39;将原始数据赋给aa 

&#39;=========加文字水印================= 
Jpeg.Canvas.Font.Color = &H000000 &#39;水印文字颜色 
Jpeg.Canvas.Font.Family = "宋体" &#39;字体 
Jpeg.Canvas.Font.Bold = False &#39;是否加粗 
Jpeg.Canvas.Font.Size = 12 &#39;字体大小 
Jpeg.Canvas.Font.ShadowColor = &Hffffff &#39;阴影色彩 
Jpeg.Canvas.Font.ShadowYOffset = 1 
Jpeg.Canvas.Font.ShadowXOffset = 1 
Jpeg.Canvas.Brush.Solid = False 
Jpeg.Canvas.Font.Quality = 4 &#39; &#39;输出质量 
Jpeg.Canvas.PrintText 30,30,"-------------------------------------" &#39;水印位置及文字
Jpeg.Canvas.PrintText 30,50,"  你的ＩＰ: "& 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.***.com" &#39;这里改成你的网址
bb=Jpeg.Binary &#39;将文字水印处理后的值赋给bb，这时，文字水印没有不透明度 


&#39;============调整文字透明度================ 
Set MyJpeg = Server.Cr&#101;ateObject("Persits.Jpeg") 
MyJpeg.OpenBinary aa 

Set Logo = Server.Cr&#101;ateObject("Persits.Jpeg") 
Logo.OpenBinary bb 
MyJpeg.DrawImage 0,0, Logo, 0.9 &#39;0.3是透明度 
cc=MyJpeg.Binary &#39;将最终结果赋值给cc,这时也可以生成目标图片了 
Response.BinaryWrite cc &#39;将二进输出给浏览器 
set aa=nothing 
set bb=nothing 
set cc=nothing 
Jpeg.close : Set Jpeg = Nothing
MyJpeg.Close : Set MyJpeg = Nothing
Logo.Close : Set Logo = Nothing
%>

&#39;--------------------------------------------------
&#39;File: conn.asp

<%dim conn,dbpath,UserIP
sub ConnDatabase
    On Error Resume next
    set conn=server.cr&#101;ateobject("adodb.connection")
    DBPath = Server.MapPath("IPaddress.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%>

&#39;-------------------------------------------------
&#39;File: config.asp

<%
Dim User_Agent
User_Agent = Request.ServerVariables("HTTP_USER_AGENT")
    
&#39; ============================================
&#39; 获取客户端配置
&#39; ============================================
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") o&#114; InStr(User_Agent, "Linux")  o&#114; InStr(User_Agent, "SunOS")  o&#114; 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


&#39; ============================================
&#39; 按照指定的正则表达式替换字符
&#39; ============================================
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 = "" o&#114; IsNull(ReqIP) Then ReqIP = Request.ServerVariables("REMOTE_ADDR")
End Function
%>
更新于:2019-05-16 09:13:01 栏目:网站周边/代码关键词:
本站使用「署名 4.0 国际」创作共享协议，可转载、引用，但需署名作者且注明文章出处
用ASP制作动态显IP图片

推荐文章
