ASP实现生成图片功能的实现

 

 由于网站需要采用全新的模式，改进某些功能，只有用户在我们网站报名，如果是已经合作的培训机构的话，就可以生成一张电子优惠卷，这个优惠卷可以下载下来，然后拿去打印即可拿去培训机构实现学费优惠。

首先需要一个图片模板，模板用

PS已经做好了。剩下的只需要网页程序生成这样的图片即可。那么如何生成呢？？？

于是在网上找到了这样一个实例，这个类非常的简单好用。

在要这个功能的页面先包含这个文件。

<!--#include file="Inc/Wh_BmpText.asp" -->

然后定义这个对象new一个

Dim objbmpSet objbmp = New Wh_bmpTextobjbmp.FontPath = server.mappath("DataBase/Font_12.asp")objbmp.loadBMP(server.mappath("Skins/IpImg.bmp"))

然后设置背景的图片是哪个，还有字体文件是使用哪个

设置好以后，从表单提交数据，然后在这里接收数据

dim thename,idnum,sex,lesson,moneythename=request.Form("thename")idnum=request.Form("idnum")sex=request.Form("sex")lesson=request.Form("lesson")money=request.Form("money")

接收以后，进行字符串的写入

objbmp.DrawTextWE 180, 18, "培训打折网", 50objbmp.DrawTextWE 20, 26, "-----------------------------------", 50objbmp.DrawTextWE 24, 36, "姓名:" & thename, 50objbmp.DrawTextWE 24, 52, "身份证号:"& idnum , 50objbmp.DrawTextWE 24, 68, "性别:" & sex, 50objbmp.DrawTextWE 24, 84, "所报课程:" & lesson, 50objbmp.DrawTextWE 24, 100, "返回学费:" & money & "元", 50objbmp.DrawTextWE 20, 110, "-----------------------------------", 50objbmp.DrawTextWE 30, 144, "Made by Tomosawa", 50 objbmp.write()set objbmp = nothing

写在图片上。

刚开始怎么弄页面就是出不来，真是邪了门了，难道是request写错了？

仔细看也没有错误啊！由于我这里ASP没有调试工具，不能一步步调试，只能从源代码慢慢看了。

去掉所有的request然后，直接写入静态的图片

把中间的注释起来。诶？有图片生成了，但是一加上就又没有了。真是很邪。然后把上面的request都要了，然后把下面的只加一个

objbmp.DrawTextWE 24, 36, "姓名:" & thename, 50

结果又显示不出来了。果然是这些语句的问题啊。

然后把后面的变量去掉再试，依然出不来！！！！！！！！

那还真是奇怪了呵，怎么写个字符串都写不上去啊。

仔细研究了一番，终于知道答案了。。。。。。。。

问题就出在“姓名：”这个字符串上。

他这个类里面字体设置，并不是windows的TTF或者TTC或者FON字体文件。而是一个access数据库文件，把扩展名改为mdb后，打开一看，哇，果然。

原来刚才的字符串里面有全角的冒号，它里面没有这个符号，结果就出错。

然后把符号全部改为英文半角，问题解决。

真是的，看来这个家伙的这个东西是有BUG的，而且字体库不保证完全。将就着用一用吧！

全部写好，测试一下，哈哈，终于出来了！

下面是这个类的代码

Class Wh_BmpTextprivate offsetprivate sBMPprivate widthprivate heightprivate bitcontprivate imagesizeprivate linesprivate Conn,rs,Font,Letter(12),FPathprivate Sub AddFont(sText)Dim i, Chrs, arrSet Font = Server.CreateObject("Scripting.Dictionary")For I = 1 to Len(sText)chrs = chrs & "'" & Mid(sText,I,1) & "',"NextCall 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 Subdo while not rs.eofarr = split(rs("font")," ")Font.Add "f" & rs("Chrs"),arrRs.movenextloopRs.closeSet Rs = NothingCall DBclose()end Subpublic Sub DrawTextNS(lX,lY,sText,color)Dim Rs,I,ChrsDim iTemp1Dim iTemp2Dim iTemp3Dim bCharif lx = "" or ly = "" or sText = "" or color = "" Then exit SubCall AddFont(sText)y=0for iTemp1 = 1 to len(sText)for iTemp2 = 0 to UBound(Letter) - 1x = 0for 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" ThenPixel(lX + x,lY + y) = CLng(color)End Ifx = x +1nexty = y +1nextnextFont.removeallEnd Subpublic Sub DrawTextWE(lX,lY,sText,color)Dim Rs,I,ChrsDim iTemp1Dim iTemp2Dim iTemp3Dim bCharDim xif lx = "" or ly = "" or sText = "" or color = "" Then exit SubCall AddFont(sText)For iTemp1 = 0 to UBound(Letter) - 1x = 0For 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" ThenPixel(lX + x,lY + iTemp1) = CLng(color)End Ifx = x +1nextnextnextFont.removeallEnd Subpublic property let FontPath(val)If val <> "" Then FPath = valEnd propertypublic property let Pixel(X,Y,colorindex)dim tempX = int(X)Y = int(Y)colorindex = int(colorindex)If (X<=width) and (X>0) and (Y<=height) and (Y>0) Thentemp = (height-Y)*lines+X-1+offsetsBMP = midB(sBMP,1,temp) & ChrB(colorindex) & midb(sBMP,temp + 2,lenb(sBMP)-temp+2)End IfEnd propertypublic Sub loadBMP(filename)dim obj,imageset obj=server.createobject("adodb.stream")obj.Type = 1 ' adTypeBinaryobj.Openobj.LoadFromFile filenameimage = obj.Readobj.Closeset obj = NothingIf midb(image,1,2) = (ChrB(Asc("B")) & ChrB(Asc("M"))) Thenoffset = 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 / heightIf bitcont = 8 ThensBMP = imageEnd IfEnd IfEnd Subpublic Sub writeIf lenb(sBMP)>0 ThenResponse.ContentType = "image/bmp"Response.AddHeader "Content-Disposition","filename=Wh_BmpText.bmp"Response.BinaryWrite sBMPEnd IfEnd Subprivate Function GetLong(sValue)GetLong = 0If LenB(sValue) >= 4 ThenGetLong = ShIftLeft(GetWord(MidB(sValue,3,2)),16) or GetWord(MidB(sValue,1,2))End IfEnd Functionprivate Function GetWord(sValue)GetWord = ShIftLeft(AscB(RightB(sValue,1)),8) or AscB(LeftB(sValue,1))End Functionprivate Function ShIftLeft(lValue,lBits)ShIftLeft = lValue * (2^lBits)End Functionprivate Function ShIftRight(lValue,lBits)ShIftRight = int(lValue / (2^lBits))End Functionprivate Sub DBConn()set Conn=server.createobject("adodb.Connection")Conn.Connectionstring="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FPathConn.openend Subprivate Sub DBclose()if isobject(Conn) Then Conn.close : set Conn = NothingEnd SubEnd Class