<%
'=========================================================
' ClassName: Wh_BmpText
' Version:1.0
' Date: 2005-1-15
'=========================================================
' Web: http://vcc5.vicp.net
' Email: wuyingke5155@163.com
' Oicq:54883661
'=========================================================
Class Wh_BmpText
private offset
private sBMP
private width
private height
private bitcont
private imagesize
private lines
private Conn,rs,Font,Letter(12),FPath
    private Sub AddFont(sText)
        Set Font = Server.CreateObject("Scripting.Dictionary")
        For I = 1 to Len(sText)
            chrs = chrs & "'" & Mid(sText,I,1) & "',"
        Next
        Call DBconn()
        Set Rs = Conn.execute("Select * From Font Where chrs in(" & Left(chrs,Len(chrs) -1) & ")")
        If Rs.eof Then Rs.close : Set Rs = Nothing : Call DBclose() : Exit Sub
        do while not rs.eof
            arr = split(rs("font")," ")
            Font.Add "f" & rs("Chrs"),arr
            Rs.movenext
        loop
        Rs.close
        Set Rs = Nothing
        Call DBclose()
    end Sub
    
    public Sub DrawTextNS(lX,lY,sText,color)
        Dim Rs,I,Chrs
        Dim iTemp1
        Dim iTemp2
        Dim iTemp3
        Dim bChar
        if lx = "" or ly = "" or sText = "" or color = "" Then exit Sub
        Call AddFont(sText)
        y=0
        for iTemp1 = 1 to len(sText)
            for iTemp2 = 0 to UBound(Letter) - 1
                x = 0
                for iTemp3 = 1 to len(Font("f" & Mid(sText,iTemp1,1))(iTemp2))
                    bChar = Mid(Font("f" & Mid(sText,iTemp1,1))(iTemp2),iTemp3,1)
                    If bChar <> "0" Then
                        Pixel(lX + x,lY + y) = CLng(color)
                    End If
                    x = x +1
                next
                y = y +1
            next
        next
        Font.removeall
    End Sub

    public Sub DrawTextWE(lX,lY,sText,color)
        Dim Rs,I,Chrs
        Dim iTemp1
        Dim iTemp2
        Dim iTemp3
        Dim bChar
        if lx = "" or ly = "" or sText = "" or color = "" Then exit Sub
        Call AddFont(sText)    
        For iTemp1 = 0 to UBound(Letter) - 1
            x = 0
            For iTemp2 = 1 to len(sText)
                For iTemp3 = 1 to Len(Font("f" & Mid(sText,iTemp2,1))(iTemp1))
                    bChar = Mid(Font("f" & Mid(sText,iTemp2,1))(iTemp1),iTemp3,1)
                    If bChar <> "0" Then
                        Pixel(lX + x,lY + iTemp1) = CLng(color)
                    End If
                    x = x +1
                next
            next
        next
        Font.removeall
    End Sub
    
    public property let FontPath(val)
        If val <> "" Then FPath = val
    End property

    public property let Pixel(X,Y,colorindex)
        dim temp
        X = int(X)
        Y = int(Y)
        colorindex = int(colorindex)
        If (X<=width) and (X>0) and (Y<=height) and (Y>0) Then
            temp = (height-Y)*lines+X-1+offset
            sBMP = midB(sBMP,1,temp) & ChrB(colorindex) & midb(sBMP,temp + 2,lenb(sBMP)-temp+2)
        End If
    End property

    public Sub loadBMP(filename)
        dim obj,image
        set obj=server.createobject("adodb.stream")
        obj.Type = 1 ' adTypeBinary
        obj.Open
        obj.LoadFromFile filename
        image = obj.Read
        obj.Close
        set obj = Nothing
        If midb(image,1,2) = (ChrB(Asc("B")) & ChrB(Asc("M"))) Then
            offset = getlong(midb(image,11,4))
            width = getlong(midb(image,19,4))
            height = getlong(midb(image,23,4))
            bitcont = getword(midb(image,29,2))
            imagesize = getlong(midb(image,35,4))
            lines = imagesize / height
            If bitcont = 8 Then
                sBMP = image
            End If
        End If
    End Sub
    
    public Sub write
        If lenb(sBMP)>0 Then
            Response.ContentType = "image/bmp"
            Response.AddHeader "Content-Disposition","filename=Wh_BmpText.bmp"
            Response.BinaryWrite sBMP
        End If
    End Sub

    private Function GetLong(sValue)
        GetLong = 0
        If LenB(sValue) >= 4 Then
            GetLong = ShIftLeft(GetWord(MidB(sValue,3,2)),16) or GetWord(MidB(sValue,1,2))
        End If
    End Function

    private Function GetWord(sValue)
        GetWord = ShIftLeft(AscB(RightB(sValue,1)),8) or AscB(LeftB(sValue,1))
    End Function

    private Function ShIftLeft(lValue,lBits)
        ShIftLeft = lValue * (2^lBits)
    End Function

    private Function ShIftRight(lValue,lBits)
        ShIftRight = int(lValue / (2^lBits))
    End Function

    private Sub DBConn()
        set Conn=server.createobject("adodb.Connection")
        Conn.Connectionstring="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FPath
        Conn.open
    end Sub

    private Sub DBclose()
        if isobject(Conn) Then Conn.close : set Conn = Nothing
    End Sub
    
End Class
%>

<!--#include file="Wh_BmpText.asp" -->
<%
uppage = Request.ServerVariables("HTTP_REFERER")
addr = Request.ServerVariables("REMOTE_ADDR")
mexp = Request.ServerVariables("HTTP_USER_AGENT")

Dim objbmp
Set objbmp = New Wh_bmpText
objbmp.FontPath = server.mappath("font_12.asp")
objbmp.loadBMP(server.mappath("bb.bmp"))

ms = split(mexp,";")
objbmp.DrawTextWE 2,14,"     您当前电脑信息",15
objbmp.DrawTextWE 2,28," IP是:" & addr,15
objbmp.DrawTextWE 2,42," 浏览器类型:" & ms(1),15
objbmp.DrawTextWE 2,56," 系统:" & left(ms(2),len(ms(2)) -1),15
objbmp.DrawTextWE 2,70,"       Aspxhome.com",15

objbmp.write()
set objbmp=nothing
%>