ASP 把文字写入bmp文字的类

发布时间:2010年03月18日      浏览次数:781 次
这个是把相关信息写入bmp文件的类,从网上收集的,没有注释,所以也没仔细看,具体的不是很清楚,若有需要的可以研究下,有时间的话能加上注释发我一份更好!!
程序代码
<%
'=========================================================
' 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
%>
演示地址:http://www.94this.com.cn/myCode/asp2Bmp/showImg.asp
代码下载地址:http://www.94this.com.cn/myCode/asp2Bmp/asp2Bmp.rar
文章来源:http://www.94this.com.cn/article/130.htm
免责声明:本站相关技术文章信息部分来自网络,目的主要是传播更多信息,如果您认为本站的某些信息侵犯了您的版权,请与我们联系,我们会即时妥善的处理,谢谢合作!