ASP的自定义实用函数表(2)

'CFS編碼加密
Function CfsEnCode(CodeStr)

Dim CodeLen
Dim CodeSpace
Dim NewCode

CodeLen = 30
CodeSpace = CodeLen - Len(CodeStr)

If Not CodeSpace < 1 Then
For cecr = 1 To CodeSpace
CodeStr = CodeStr & Chr(21)
Next
End If

NewCode = 1

Dim Been
For cecb = 1 To CodeLen
Been = CodeLen + Asc(Mid(CodeStr,cecb,1)) * cecb
NewCode = NewCode * Been
Next

CodeStr = NewCode
NewCode = Empty

For cec = 1 To Len(CodeStr)
NewCode = NewCode & CfsCode(Mid(CodeStr,cec,3))
Next

For cec = 20 To Len(NewCode) - 18 Step 2
CfsEnCode = CfsEnCode & Mid(NewCode,cec,1)
Next

End Function


Function CfsCode(Word)
For cc = 1 To Len(Word)
CfsCode = CfsCode & Asc(Mid(Word,cc,1))
Next
CfsCode = Hex(CfsCode)
End Function


編碼函式 CfsEncode() 的使用：

Var = CfsEncode(字串來源)

範例：
<%Dim SourceDim Var1Source = "test"Var1 = CfsEncode(Source)Response.Write Var1%>

-------------------------------------------
用正则表达式写的HTML分离函数
存成.asp文件，执行，你用ASPHTTP抓内容的时候用这个很爽，当然自己要改进一下了
<%
Option Explicit

Function stripHTML(strHTML)
'Strips the HTML tags from strHTML

Dim objRegExp, strOutput
Set objRegExp = New Regexp

objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<.+?>"

'Replace all HTML tag matches with the empty string
strOutput = objRegExp.Replace(strHTML, "")

'Replace all < and > with < and >
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")

stripHTML = strOutput 'Return the value of strOutput

Set objRegExp = Nothing
End Function


%>

Enter an HTML String:

<%=Request("txtHTML")%>

<% if Len(Request("txtHTML")) > 0 then %>

---

View of string with no HTML stripping:

<BR><%=Request("txtHTML")%><BR>

View of string with HTML stripping:

<%=StripHTML(Request("txtHTML"))%>

<% End If %>

---------------------------------------
如何检测备注字段的字节数
视服务器操作系统语种不同,而采取不同的方法:  
1.E文下,len(rs("field")),就行了.len("中文abc")=7  
2.Z文下,复杂一点,len("中文abc")=5  
lenB("中文abc")=10,所以需要自己写程序判断其长度.  
function  strLen(str)  
dim  i,l,t,c  
l=len(str)  
t=l  
for  i=1  to  l  
c=asc(mid(str,i,1))  
if  c<0  then  c=c+65536  
if  c>255  then  
t=t+1  
end  if  
next  
strLen=t  
end  function

------------------------------------
FSO自写自用的几个函数
''''使用FSO修改文件特定内容的函数
function FSOchange(filename,Target,String)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FiletempData = objCountFile.ReadAll
objCountFile.Close
FiletempData=Replace(FiletempData,Target,String)
Set objCountFile=objFSO.CreateTextFile(Server.MapPath(filename),True)
objCountFile.Write FiletempData
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
''''使用FSO读取文件内容的函数
function FSOFileRead(filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
''''使用FSO读取文件某一行的函数
function FSOlinedit(filename,lineNum)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
  exit function
else
  FSOlinedit = temparray(lineNum-1)
end if
end if
end function
''''使用FSO写文件某一行的函数
function FSOlinewrite(filename,lineNum,Linecontent)
if linenum < 1 then exit function
dim fso,f,temparray,tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
  exit function
else
  temparray(lineNum-1) = lineContent
end if
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.write tempcnt
end if
f.close
set f = nothing
end function
''''使用FSO添加文件新行的函数
function FSOappline(filename,Linecontent)
dim fso,f
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),8,1)
f.write chr(13)&chr(10)&Linecontent
f.close
set f = nothing
end function
''''读文件最后一行的函数
function FSOlastline(filename)
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
  FSOlastline = temparray(ubound(temparray))
end if
end function
还有，创建文件夹：
sub CreateFolder(Foldername)
Set afso = Server.CreateObject("Scripting.FileSystemObject")
  if afso.folderexists(server.mappath(Foldername))=true then
  else
   afso.createfolder(server.mappath(foldername))
  end if
set afso=nothing
end sub

用法，createfolder(foldername)




----------------------------------------
''检查字符串是否包含非法字符串
FUNCTION BadWords(strContent)
DIM objRegExp
Set objRegExp = new RegExp
objRegExp.IgnoreCase = true
objRegExp.Global = true
objRegExp.Pattern = "李.{0,10}某.{0,10}人|他.{0,10}妈.{0,10}的|你.{0,10}他.{0,10}妈.{0,10}的|我操.{0,10}你妈"
BadWords = objRegExp.Test(strContent)
Set objRegExp = Nothing
END FUNCTION



---------------------------------------
取得网站的URL的根目录
'******************************
'||Function GetRootDir()
'||Created by Cj, 2000/8/28
'||取得网站的URL的根目录
'******************************
Function GetRootDir()
If Application("RootDir") <> "" And Not isNull(Application("RootDir")) then
  GetRootDir = Application("RootDir")
  Exit Function
End if

dim strRoot, intRootEnd
strRoot = Request.ServerVariables("SCRIPT_NAME")
intRootEnd = Instr(2, strRoot, "/")
if intRootEnd > 1 then
  strRoot = Left(strRoot, intRootEnd)
End if
Application.Lock()
  Application("RootDir") = strRoot
Application.UnLock()
GetRootDir = strRoot      
End Function


------------------------------------
这是一个后台管理的文章发布系统里的一个将copy的文字转换成html代码的函数，如果是空格会自动加 如果换行会自动加
也可以自己直接写HTML代码
<%
'自建Asp函数库

'HTML/*********************
'将部分字符串转化为Html代码
function htmlencode2(str)
    dim result
    dim l
    if isNULL(str) then
       htmlencode2=""
       exit function
    end if
    l=len(str)
    result=""
dim i
for i = 1 to l
     select case mid(str,i,1)
            case "'"
                 result=result+"’"
            'case ""
            '     result=result+">"
               case chr(13)
                 result=result+"
"
            'case chr(34)
            '     result=result+""
            case "&"
                 result=result+"&"
               case chr(32)            
                 'result=result+" "
                 if i+1<=l and i-1>0 then
                    if mid(str,i+1,1)=chr(32) or mid(str,i+1,1)=chr(9) or mid(str,i-1,1)=chr(32) or mid(str,i-1,1)=chr(9)  then                      
                       result=result+" "
                    else
                       result=result+" "
                    end if
                 else
                    result=result+" "                    
                 end if
            case chr(9)
                 result=result+"    "
            case else
                 result=result+mid(str,i,1)
         end select
       next
       htmlencode2=result
end function

'字符串验证**************

'Emailcheck
Function isEmail(val)
isEmail=False
if len(val)>0 then
  if instr(val,"@")>0 and instr(val,".")>0 and len(val)>5 then
  else
   exit function
  end if
else
  exit function
end if
isEmail=true
end function

%>

----------------------------------------
无级分类的函数，分表格显示与下拉列表显示两种：
数据库Db_category: CategoryID | ParentID | CategoryName
调用：Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
Category.asp:
<%
Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
'style = 1 , 以表格显示
'style = 2 , 以下拉列表显示
if Style = 0 then
  response.write ""
  response.write ""
  response.write ""
  response.write ""
  response.write ""
  response.write ""
  call CategoryList(CategoryID,num,Action)
  response.write "

分类ID

上级ID

分类名称

操作

"
else
  response.write ""
  response.write " ---产品根目录--- "
  call CategorySel(CategoryID,num,SelectedID)
  response.write ""
end if
end sub
Sub CategoryList(ParentID,num,Action)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&ParentID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
  Category = rs.getrows
end if
rs.close
set rs=nothing
snum = num + 1
str = Makeblank(snum,0)
if isArray(Category) then
  for l=0 to ubound(Category,2)
   response.Write("")
   for k=0 to ubound(Category,1)
    if k = ubound(Category,1) then  '当显示CategoryName 时加[],其他不加
     response.Write(""&str&" [ "&Category(k,l)&"] "&"")
    else
     response.Write("  "&Category(k,l)&" "&"")
    end if
   next
   if Action = 1 then      '添加目录
    response.Write(" 添加子类 ")
   elseif Action = 2 then  '修改目录
    response.Write(" 修改类别 ")
   elseif Action = 3 then  '删除目录
    response.Write(" 删除类别 ")
   else       '没有操作，仅浏览
    response.Write(" --------- ")
   end if
   '调用递归函数，列出下级目录
   call CategoryList(Category(0,l),snum,Action)
  next
set Category = nothing
end if
End Sub
Sub CategorySel(CategoryID,num,SelectedID)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&CategoryID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
  Category = rs.getrows
end if
rs.close
set rs = nothing
snum = num + 1
str = Makeblank(snum,1)
if isArray(Category) then
  for l=0 to ubound(Category,2)
   if Category(0,l) = SelectedID then  '当显示已选择的ID时加[Selected],表示已选择
    response.Write(""&str&Category(2,l)&"")
   else
    response.Write(""&str&Category(2,l)&"")
   end if
   '调用递归函数，列出下级目录
   call CategorySel(Category(0,l),snum,SelectedID)
  next
  set Category = nothing
end if
End Sub
Function Makeblank(num,Style)
if Style = 0 then
  for i = 2 to num
   TempStr = TempStr&"  "
  next
  Makeblank = TempStr&"├"  
else
  for i = 2 to num
   TempStr = TempStr&"  "
  next
  Makeblank = TempStr&"└ "
end if
'不同的表格线:└┌┍┕┎┖┐┘┑┙┒┚┓┛├ ┤┝ ┥┞ ┦┼ ╄ ┽ ╅┣ ┫
End function
%>

----------------------------------------
qq在线显示程序核心代码
<%
Function GetURL(url)
Set Retrieval = CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "GET", url, False, "", ""
.Send
GetURL = .ResponseText
End With
Set Retrieval = Nothing
End Function  

Function qqonline(qqid)
Dim T,Start,Length,PicURL
'找到该用户界面的源代码
T=GetURL("";&qqid)
'查找字符串ShowResult(的位置
Start=Instr(1,T,"ShowResult("+chr(34))
'查找字符串http://的位置
Start=Instr(Start,T,"http://"/;)
'查找包含字符串的长度
Length=Instr(Start,T,chr(34)+","+chr(34))-Start
PicURL=Mid(T,Start,Length)
pic_right=right(picurl,5)
pic_left=left(pic_right,1)
if pic_left="2" then
qqonline="在线"
else
qqonline="离线"
end if
End Function
%><%=qqonline(24080411)%>

------------------------------------------
vbs类生成xml文件
有两文件:
objXML.asp:测试文件
clsXML.asp:vbs类文件
代码:
objXML.asp

<%@ Language=VBScript %>
<% Option Explicit %>

<%
Dim objXML, strPath, str
Set objXML = New clsXML

strPath = Server.MapPath(".") & "\New.xml"

objXML.createFile strPath, "Root"
'Or If using an existing XML file:
'objXML.File = "C:\File.xml"

objXML.createRootChild "Images"

'Here only one attribute is added to the Images/Image Node
objXML.createChildNodeWAttr "Images", "Image", "id", "1"
objXML.updateField "Images//Image[@id=1]", "super.gif"
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 31, 30)
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 30, 29)
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 31, 85)

'Notice that all three job nodes have size 24, all of those
'nodes will be updated
objXML.updateField "Jobs[@Size=24]", "24's"

'Notice that only two nodes have the specified XPath, hence
'only two new child nodes will be added
objXML.createChildNodeWAttr "Jobs[@Size=24 and @Length=31]", "Specs", _
Array("Wood", "Metal", "Color"), _
Array("Cedar", "Aluminum", "Green")

'It is always important to iterate through all of the nodes
'returned by this XPath query.
For Each str In objXML.getField("Jobs[@Size=24]")
Response.Write(str & "
")
Next
Set objXML = Nothing

Response.Redirect "New.xml"
%>

clsXML.asp:

<%
Class clsXML
'strFile must be full path to document, ie C:\XML\XMLFile.XML
'objDoc is the XML Object
Private strFile, objDoc

'*********************************************************************
' Initialization/Termination
'*********************************************************************

'Initialize Class Members
Private Sub Class_Initialize()
strFile = ""
End Sub

'Terminate and unload all created objects
Private Sub Class_Terminate()
Set objDoc = Nothing
End Sub

'*********************************************************************
' Properties
'*********************************************************************

'Set XML File and objDoc
Public Property Let File(str)
Set objDoc = Server.CreateObject("Microsoft.XMLDOM")
objDoc.async = False
strFile = str
objDoc.Load strFile
End Property

'Get XML File
Public Property Get File()
File = strFile
End Property

'*********************************************************************
' Functions
'*********************************************************************

'Create Blank XML File, set current obj File to newly created file
Public Function createFile(strPath, strRoot)
Dim objFSO, objTextFile
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile(strPath, True)
objTextFile.WriteLine("")
objTextFile.WriteLine("<" & strRoot & "/>")
objTextFile.Close
Me.File = strPath
Set objTextFile = Nothing
Set objFSO = Nothing
End Function

'Get XML Field(s) based on XPath input from root node
Public Function getField(strXPath)
Dim objNodeList, arrResponse(), i
Set objNodeList = objDoc.documentElement.selectNodes(strXPath)
ReDim arrResponse(objNodeList.length)
For i = 0 To objNodeList.length - 1
arrResponse(i) = objNodeList.item(i).Text
Next
getField = arrResponse
End Function

'Update existing node(s) based on XPath specs
Public Function updateField(strXPath, strData)
Dim objField
For Each objField In objDoc.documentElement.selectNodes(strXPath)
objField.Text = strData
Next
objDoc.Save strFile
Set objField = Nothing
updateField = True
End Function

'Create node directly under root
Public Function createRootChild(strNode)
Dim objChild
Set objChild = objDoc.createNode(1, strNode, "")
objDoc.documentElement.appendChild(objChild)
objDoc.Save strFile
Set objChild = Nothing
End Function

'Create a child node under root node with attributes
Public Function createRootNodeWAttr(strNode, attr, val)
Dim objChild, objAttr
Set objChild = objDoc.createNode(1, strNode, "")
If IsArray(attr) And IsArray(val) Then
If UBound(attr)-LBound(attr) <> UBound(val)-LBound(val) Then
Exit Function
Else
Dim i
For i = LBound(attr) To UBound(attr)
Set objAttr = objDoc.createAttribute(attr(i))
objChild.setAttribute attr(i), val(i)
Next
End If
Else
Set objAttr = objDoc.createAttribute(attr)
objChild.setAttribute attr, val
End If
objDoc.documentElement.appendChild(objChild)
objDoc.Save strFile
Set objChild = Nothing
End Function

'Create a child node under the specified XPath Node
Public Function createChildNode(strXPath, strNode)
Dim objParent, objChild
For Each objParent In objDoc.documentElement.selectNodes(strXPath)
Set objChild = objDoc.createNode(1, strNode, "")
objParent.appendChild(objChild)
Next
objDoc.Save strFile
Set objParent = Nothing
Set objChild = Nothing
End Function

'Create a child node(s) under the specified XPath Node with attributes
Public Function createChildNodeWAttr(strXPath, strNode, attr, val)
Dim objParent, objChild, objAttr
For Each objParent In objDoc.documentElement.selectNodes(strXPath)
Set objChild = objDoc.createNode(1, strNode, "")
If IsArray(attr) And IsArray(val) Then
If UBound(attr)-LBound(attr) <> UBound(val)-LBound(val) Then
Exit Function
Else
Dim i
For i = LBound(attr) To UBound(attr)
Set objAttr = objDoc.createAttribute(attr(i))
objChild.SetAttribute attr(i), val(i)
Next
End If
Else
Set objAttr = objDoc.createAttribute(attr)
objChild.setAttribute attr, val
End If
objParent.appendChild(objChild)
Next
objDoc.Save strFile
Set objParent = Nothing
Set objChild = Nothing
End Function

'Delete the node specified by the XPath
Public Function deleteNode(strXPath)
Dim objOld
For Each objOld In objDoc.documentElement.selectNodes(strXPath)
objDoc.documentElement.removeChild objOld
Next
objDoc.Save strFile
Set objOld = Nothing
End Function
End Class
%>


--------------------------------------------
利用ASP怎么实现对指定文件夹下的内容（包括子文件夹的）进行搜索？
搜索出来的结果再分页显示？
这是Lshdic以前写过的,在Lshdic2002中有更详细的FSO对象浏览器

做成ASP你可以手工改一改，这里方便浏览

------------------------------------------
身份证真伪
'id 省份证号
'birthday生日,yyyy-mm-dd格式
'sex性别,值为"男:1","女:0"
id = "460102800925121"
birthday = "1980-09-25"
sex = 1

IF idcard_check(id,birthday,sex) Then
   response.write "不错"
else
   response.write "**"
End if

Function idcard_check(id,birthday,sex)
If len(id)<>15 and len(id)<>18 then
    idcard_check=false
    Exit Function
Else
    For i=1 to len(id)
       temp=mid(id,i,1)
       If temp<"0" or temp>"9" Then
           idcard_check=False
           Exit Function
       End if
    Next
    bdl=left(birthday,4) & mid(birthday,6,2) & mid(birthday,9,2)
    bds=mid(birthday,3,2) & mid(birthday,6,2) & mid(birthday,9,2)
    If len(id)=15 Then
        If mid(id,7,6)<>bds Then
            idcard_check=False
            Exit Function
        End if
        If int(mid(id,15,1)) Mod 2 = 1 And sex=1 Then
            idcard_check=True
            Exit Function
  ElseIf int(mid(id,15,1)) Mod 2 = 0 And sex=0 Then
            idcard_check=True
            Exit Function
  Else
      idcard_check=False
            Exit Function
        End if
    Else
        If mid(id,7,8)<>bdl Then
            idcard_check=False
            Exit Function
        End if
        If int(mid(id,17,1)) Mod 2 = 1 And sex=1 Then
            idcard_check=False
            Exit Function
  ElseIf int(mid(id,17,1)) Mod 2 = 0 And sex=0 Then
            idcard_check=False
            Exit Function
  Else
   idcard_check=False
            Exit Function
        End if
    End if
End if
idcard_check=True
End function
11="北京"
12="天津"
13="河北"
14="山西"
15="内蒙古"
21="辽宁"
22="吉林"
23="黑龙江"
31="上海"
32="江苏"
33="浙江"
34="安徽"
35="福建"
36="江西"
37="山东"
41="河南"
42="湖北"
43="湖南"
44="广东"
45="广西"
46="海南"
50="重庆"
51="四川"
52="贵州"
53="云南"
54="西藏"
61="陕西"
62="甘肃"
63="青海"
64="宁夏"
65="新疆"
71="台湾"
81="香港"
82="澳门"
91="国外"


-------------------------------------------
检测上载图片尺寸的
用aspjpeg组件
up.htm

请选择您要上传的gif图片:

up.asp
<%
FormSize = Request.TotalBytes
FormData = Request.BinaryRead( FormSize )
bncrlf=chrb(13) & chrb(10)
divider=leftb(formdata,instrb(formdata,bncrlf)-1)
datastart=instrb(formdata,bncrlf & bncrlf)+4
dataend=instrb(datastart+1,formdata,divider)-datastart
Image=midb(formdata,datastart,dataend)
head_version = Ascb( midb( Image,1,3 ) )
head_subversion = Ascb( midb( Image,4,3 ) )
head_width_l = Ascb( midb( Image,7,1 ) )
head_width_h = Ascb( midb( Image,8,1 ) )
head_height_l = Ascb( midb( Image,9,1 ) )
head_height_h = Ascb( midb( Image,10,1 ) )
head_colors = Ascb( midb( Image, 11, 1 ) )
head_width_h = head_width_h * 256
head_height_h = head_height_h * 256
head_colors = head_colors And &H07
Response.Write "图像大小为" & head_width_h + head_width_l & "x" & head_height_h + head_height_l _
& "x" & 2^( head_colors + 1 )
%>  



-----------------------------------------------
程序说明:函数ShowChar(num)可根据num值返回0-9的位图。注意num取值范围0-9。当前只可生成一位数字代码，任意位数代码待续开放~
ShowChar(2)
function ShowChar(num)
dim tempstr
tempstr="0x3c,0x42,0x42,0x42,0x42,0x42,0x42,0x42,0x42,0x3c|0x20,0x30,0x28,0x20,0x20,0x20,0x20,0x20,0x20,0x20|0x3c,0x66,0x60,0x60,0x30,0x18,0x0c,0x06,0x06,0x7e|0x3c,0x42,0x40,0x40,0x38,0x40,0x40,0x40,0x42,0x3c|0x20,0x30,0x30,0x28,0x28,0x24,0x24,0x7e,0x20,0x20|0x7c,0x04,0x04,0x02,0x3e,0x42,0x40,0x40,0x42,0x3c|0x3c,0x42,0x02,0x02,0x3a,0x46,0x42,0x42,0x42,0x3c|0x7e,0x20,0x20,0x10,0x10,0x08,0x08,0x04,0x04,0x04|0x3c,0x42,0x42,0x42,0x3c,0x42,0x42,0x42,0x42,0x3c|0x3c,0x42,0x42,0x42,0x5c,0x40,0x40,0x40,0x22,0x1c"
CharItem=split(tempstr,"|")
Response.ContentType ="image/x-xbitmap"
response.write "#define counter_width 8"&chr(10)&chr(13)
response.write "#define counter_height 10"&chr(10)&chr(13)
response.write "static unsigned char counter_bits[]={"&chr(10)&chr(13)
response.write CharItem(num)
response.write "};"&chr(10)&chr(13)
end function
%>
------------------------------------------------------------
<%
sub show_img(num)
Dim Image
Dim Width, Height
Dim digtal
Dim Length
Dim sort
Dim imgdata(10,10)
imgdata(0,1)="0x3c":imgdata(0,2)="0x42":imgdata(0,3)="0x42":imgdata(0,4)="0x42":imgdata(0,5)="0x42":imgdata(0,6)="0x42":imgdata(0,7)="0x42":imgdata(0,8)="0x42":imgdata(0,9)="0x42":imgdata(0,10)="0x3c"
imgdata(1,1)="0x20":imgdata(1,2)="0x30":imgdata(1,3)="0x28":imgdata(1,4)="0x20":imgdata(1,5)="0x20":imgdata(1,6)="0x20":imgdata(1,7)="0x20":imgdata(1,8)="0x20":imgdata(1,9)="0x20":imgdata(1,10)="0x20"
imgdata(2,1)="0x3c":imgdata(2,2)="0x66":imgdata(2,3)="0x60":imgdata(2,4)="0x60":imgdata(2,5)="0x30":imgdata(2,6)="0x18":imgdata(2,7)="0x0c":imgdata(2,8)="0x06":imgdata(2,9)="0x06":imgdata(2,10)="0x7e"
imgdata(3,1)="0x3c":imgdata(3,2)="0x42":imgdata(3,3)="0x40":imgdata(3,4)="0x40":imgdata(3,5)="0x38":imgdata(3,6)="0x40":imgdata(3,7)="0x40":imgdata(3,8)="0x40":imgdata(3,9)="0x42":imgdata(3,10)="0x3c"
imgdata(4,1)="0x20":imgdata(4,2)="0x30":imgdata(4,3)="0x30":imgdata(4,4)="0x28":imgdata(4,5)="0x28":imgdata(4,6)="0x24":imgdata(4,7)="0x24":imgdata(4,8)="0x7e":imgdata(4,9)="0x20":imgdata(4,10)="0x20"
imgdata(5,1)="0x7c":imgdata(5,2)="0x04":imgdata(5,3)="0x04":imgdata(5,4)="0x02":imgdata(5,5)="0x3e":imgdata(5,6)="0x42":imgdata(5,7)="0x40":imgdata(5,8)="0x40":imgdata(5,9)="0x42":imgdata(5,10)="0x3c"
imgdata(6,1)="0x3c":imgdata(6,2)="0x42":imgdata(6,3)="0x02":imgdata(6,4)="0x02":imgdata(6,5)="0x3a":imgdata(6,6)="0x46":imgdata(6,7)="0x42":imgdata(6,8)="0x42":imgdata(6,9)="0x42":imgdata(6,10)="0x3c"
imgdata(7,1)="0x7e":imgdata(7,2)="0x20":imgdata(7,3)="0x20":imgdata(7,4)="0x10":imgdata(7,5)="0x10":imgdata(7,6)="0x08":imgdata(7,7)="0x08":imgdata(7,8)="0x04":imgdata(7,9)="0x04":imgdata(7,10)="0x04"
imgdata(8,1)="0x3c":imgdata(8,2)="0x42":imgdata(8,3)="0x42":imgdata(8,4)="0x42":imgdata(8,5)="0x3c":imgdata(8,6)="0x42":imgdata(8,7)="0x42":imgdata(8,8)="0x42":imgdata(8,9)="0x42":imgdata(8,10)="0x3c"
imgdata(9,1)="0x3c":imgdata(9,2)="0x42":imgdata(9,3)="0x42":imgdata(9,4)="0x42":imgdata(9,5)="0x5c":imgdata(9,6)="0x40":imgdata(9,7)="0x40":imgdata(9,8)="0x40":imgdata(9,9)="0x22":imgdata(9,10)="0x1c"


Length = 10 '自定计数器长度
Redim sort( Length )
digital =right(string(length,"0")&num,length)

For I = 1 To Len( digital )
  sort(I) = Mid( digital, I, 1 )
Next
Width = 8 * Len( digital )   '图像的宽度
Height = 10  '图像的高度，在本例中为固定值
Response.ContentType="image/x-xbitmap"
hc=chr(13) & chr(10)
Image = "#define counter_width " & Width & hc
Image = Image & "#define counter_height " & Height & hc
Image = Image & "static unsigned char counter_bits[]={" & hc
For I = 1 To Height
  For J = 1 To Length
   Image = Image & imgdata(sort(J),I) & ","
  Next
Next
Image = Left( Image, Len( Image ) - 1 ) '去掉最后一个逗号
Image = Image & "};" & hc
Response.Write Image
end sub

call show_img(797436412)
%>
注：num不能超过15位，且只能显示10位。当然，大家可以修改Length的值来显示15位。