当前位置：ASP技术首页 >> ASP应用 >> ASP的自定义实用函数表(2)

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

2006-02-15 08:00:00 作者：来源：互联网浏览次数：0 文字大小：【大】【中】【小】

简介：　　'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 = Cod...

关键字：函数实用 ASP

　　'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)

End If

NewCode = 1

Dim Been

For cecb = 1 To CodeLen

Been = CodeLen + Asc(Mid(CodeStr,cecb,1)) * cecb

NewCode = NewCode * Been

CodeStr = NewCode

NewCode = Empty

For cec = 1 To Len(CodeStr)

NewCode = NewCode & CfsCode(Mid(CodeStr,cec,3))

For cec = 20 To Len(NewCode) - 18 Step 2

CfsEnCode = CfsEnCode & Mid(NewCode,cec,1)

End Function

Function CfsCode(Word)

For cc = 1 To Len(Word)

CfsCode = CfsCode & Asc(Mid(Word,cc,1))

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

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

View of string with no HTML stripping:

</p> <p><%=Request("txtHTML")%></p> <p>

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

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 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

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 ""

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

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)

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("")

else

response.Write("")

end if

'调用递归函数，列出下级目录

call CategorySel(Category(0,l),snum,SelectedID)

set Category = nothing

end if

End Sub

Function Makeblank(num,Style)

if Style = 0 then

for i = 2 to num

TempStr = TempStr&" "

Makeblank = TempStr&"├"

else

for i = 2 to num

TempStr = TempStr&" "

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("http://search.tencent.com/cgi-bin/friend/oicq_find?oicq_no=";&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 & "
")

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

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

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)

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)

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)

End If

Else

Set objAttr = objDoc.createAttribute(attr)

objChild.setAttribute attr, val

End If

objParent.appendChild(objChild)

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

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

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

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

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 )

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) & ","

Image = Left( Image, Len( Image ) - 1 ) '去掉最后一个逗号

Image = Image & "};" & hc

Response.Write Image

end sub

call show_img(797436412)

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

责任编辑：admin

本文引用地址： http://www.3pcode.com/asp/2006/02/74734.htm

发表评论　加入收藏　告诉好友　打印本页　关闭窗口　返回顶部

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

最新文章

更多

推荐文章

更多

热点文章

更多