ASP中一种效率极高的分类算法（一） 
 
 
 
(2002年04月29日22:55:00 阅读： 1 )
 
 
在网站建设中，分类算法的应用非常的普遍。在设计一个电子商店时，要涉及到商品分类；在设计发布系统时，要涉及到栏目或者频道分类；在设计软件下载这样的程序时，要涉及到软件的分类；如此等等。可以说，分类是一个很普遍的问题。 

我常常面试一些程序员，而且我几乎毫无例外地要问他们一些关于分类算法的问题。下面的举几个我常常询问的问题。你认为你可以很轻松地回答么^_^. 

1、分类算法常常表现为树的表示和遍历问题。那么，请问：如果用数据库中的一个Table来表达树型分类，应该有几个字段？
2、如何快速地从这个Table恢复出一棵树；
3、如何判断某个分类是否是另一个分类的子类；
4、如何查找某个分类的所有产品；
5、如何生成分类所在的路径。
6、如何新增分类； 

在不限制分类的级数和每级分类的个数时，这些问题并不是可以轻松回答的。本文试图解决这些问题。 

分类的数据结构
我们知道：分类的数据结构实际上是一棵树。在《数据结构》课程中，大家可能学过Tree的算法。由于在网站建设中我们大量使用数据库，所以我们将从Tree在数据库中的存储谈起。 

为简化问题，我们假设每个节点只需要保留Name这一个信息。我们需要为每个节点编号。编号的方法有很多种。在数据库中常用的就是自动编号。这在Access、SQL Server、Oracle中都是这样。假设编号字段为ID。 

为了表示某个节点ID1是另外一个节点ID2的父节点，我们需要在数据库中再保留一个字段，说明这个分类是属于哪个节点的儿子。把这个字段取名为FatherID。如这里的ID2，其FatherID就是ID1。 

这样，我们就得到了分类Catalog的数据表定义： 

Create Table [Catalog]( 

　　　　[ID] [int]　NOT NULL, 

　　　　[Name] [nvarchar](50) NOT NULL, 

　　　　[FatherID]　[int] NOT NULL 

); 

约定：我们约定用-1作为最上面一层分类的父亲编码。编号为-1的分类。这是一个虚拟的分类。它在数据库中没有记录。 

如何恢复出一棵树
上面的Catalog定义的最大优势，就在于用它可以轻松地恢复出一棵树—分类树。为了更清楚地展示算法，我们先考虑一个简单的问题：怎样显示某个分类的下一级分类。我们知道，要查询某个分类FID的下一级分类，SQL语句非常简单： 

select Name from catalog where FatherID=FID 

显示这些类别时，我们简单地用< LI>来做到： 

< % 

REM oConn---数据库连接，调用GetChildren时已经打开 

REM FID-----当前分类的编号 

Function GetChildren(oConn,FID) 

　　　　　　　　 strSQL = "select ID,Name from catalog where FatherID="&FID 

　　　　　　　　 set rsCatalog = oConn.Execute(strSQL) 

%> 

　　　　　　　　 < UL> 

< % 

　　　　　　　　 Do while not rsCatalog.Eof　　　  

%> 

　　　　　　　　 < LI>< %=rsCatalog("Name")%> 

< % 

　　　　　　　　 Loop 

%> 

　　　　　　　　 < /UL> 

< %　　　　　  

　　　　　　　　 rsCatalog.Close 

End Function 

%> 

现在我们来看看如何显示FID下的所有分类。这需要用到递归算法。我们只需要在GetChildren函数中简单地对所有ID进行调用：GetChildren(oConn,Catalog(“ID”))就可以了。 

< % 

REM oConn---数据库连接，已经打开 

REM FID-----当前分类的编号 

Function GetChildren(oConn,FID) 

　　　　　　　　 strSQL = "select Name from catalog where FatherID="&FID 

　　　　　　　　 set rsCatalog = oConn.Execute(strSQL) 

%> 

　　　　　　　　 < UL> 

< % 

　　　　　　　　 Do while not rsCatalog.Eof　　　  

%> 

　　　　　　　　　　　　　　　　　　 < LI> 

　　　　　　　　　　　　　　　　< %=GetChildren(oConn,Catalog("ID"))%> 

< % 

　　　　　　　　 Loop 

%> 

　　　　　　　　 < /UL> 

< %　　　　　  

　　　　　　　　 rsCatalog.Close 

End Function 

%> 

修改后的GetChildren就可以完成显示FID分类的所有子分类的任务。要显示所有的分类，只需要如此调用就可以了： 

< % 

REM strConn--连接数据库的字符串，请根据情况修改 

set oConn = Server.CreateObject("ADODB.Connection") 

oConn.Open strConn 

=GetChildren(oConn,-1) 

oConn.Close 

%> 

如何查找某个分类的所有产品；
现在来解决我们在前面提出的第四个问题。第三个问题留作习题。我们假设产品的数据表如下定义： 

Create Table Product( 

　　　　　　[ID] [int] NOT NULL, 

　　　　　　[Name] [nvchar] NOT NULL, 

　　　　　　[FatherID]　[int] NOT NULL 

); 

其中，ID是产品的编号，Name是产品的名称，而FatherID是产品所属的分类。 

对第四个问题，很容易想到的办法是：先找到这个分类FID的所有子类，然后查询所有子类下的所有产品。实现这个算法实际上很复杂。代码大致如下： 

< % 

Function GetAllID(oConn,FID) 

　　　　 Dim strTemp 

　　　　 If FID=-1 then 

　　　　　　　　　 strTemp = "" 

　　　　 else 

　　　　　　　　　 strTemp ="," 

　　　　 end if 

　　　　 strSQL = "select Name from catalog where FatherID="&FID 

　　　　 set rsCatalog = oConn.Execute(strSQL) 

　　　　 Do while not rsCatalog.Eof　　 

　　　　　　　　　 strTemp=strTemp&rsCatalog("ID")&GetAllID(oConn,Catalog("ID"))　REM 递归调用 

　　　　 Loop 

　　　　 rsCatalog.Close
分类算法要解决的问题
在网站建设中，分类算法的应用非常的普遍。在设计一个电子商店时，要涉及到商品分类；在设计发布系统时，要涉及到栏目或者频道分类；在设计软件下载这样的程序时，要涉及到软件的分类；如此等等。可以说，分类是一个很普遍的问题。 

我常常面试一些程序员，而且我几乎毫无例外地要问他们一些关于分类算法的问题。下面的举几个我常常询问的问题。你认为你可以很轻松地回答么^_^. 

1、分类算法常常表现为树的表示和遍历问题。那么，请问：如果用数据库中的一个Table来表达树型分类，应该有几个字段？
2、如何快速地从这个Table恢复出一棵树；
3、如何判断某个分类是否是另一个分类的子类；
4、如何查找某个分类的所有产品；
5、如何生成分类所在的路径。
6、如何新增分类； 

在不限制分类的级数和每级分类的个数时，这些问题并不是可以轻松回答的。本文试图解决这些问题。 

分类的数据结构
我们知道：分类的数据结构实际上是一棵树。在《数据结构》课程中，大家可能学过Tree的算法。由于在网站建设中我们大量使用数据库，所以我们将从Tree在数据库中的存储谈起。 

为简化问题，我们假设每个节点只需要保留Name这一个信息。我们需要为每个节点编号。编号的方法有很多种。在数据库中常用的就是自动编号。这在Access、SQL Server、Oracle中都是这样。假设编号字段为ID。 

为了表示某个节点ID1是另外一个节点ID2的父节点，我们需要在数据库中再保留一个字段，说明这个分类是属于哪个节点的儿子。把这个字段取名为FatherID。如这里的ID2，其FatherID就是ID1。 

这样，我们就得到了分类Catalog的数据表定义： 

Create Table [Catalog]( 

　　　　[ID] [int]　NOT NULL, 

　　　　[Name] [nvarchar](50) NOT NULL, 

　　　　[FatherID]　[int] NOT NULL 

); 

约定：我们约定用-1作为最上面一层分类的父亲编码。编号为-1的分类。这是一个虚拟的分类。它在数据库中没有记录。 

如何恢复出一棵树
上面的Catalog定义的最大优势，就在于用它可以轻松地恢复出一棵树—分类树。为了更清楚地展示算法，我们先考虑一个简单的问题：怎样显示某个分类的下一级分类。我们知道，要查询某个分类FID的下一级分类，SQL语句非常简单： 

select Name from catalog where FatherID=FID 

显示这些类别时，我们简单地用〈 LI〉来做到： 

〈% 

REM oConn---数据库连接，调用GetChildren时已经打开 

REM FID-----当前分类的编号 

Function GetChildren(oConn,FID) 

　　　　　　　　 strSQL = "select ID,Name from catalog where FatherID="&FID 

　　　　　　　　 set rsCatalog = oConn.Execute(strSQL) 

%〉 

　　　　　　　　 〈UL〉 

〈% 

　　　　　　　　 Do while not rsCatalog.Eof　　　  

%〉 

　　　　　　　　 〈LI〉〈%=rsCatalog("Name")%〉 

〈% 

　　　　　　　　 Loop 

%〉 

　　　　　　　　 〈/UL〉 

〈%　　　　　  

　　　　　　　　 rsCatalog.Close 

End Function 

%〉 

现在我们来看看如何显示FID下的所有分类。这需要用到递归算法。我们只需要在GetChildren函数中简单地对所有ID进行调用：GetChildren(oConn,Catalog(“ID”))就可以了。 

〈% 

REM oConn---数据库连接，已经打开 

REM FID-----当前分类的编号 

Function GetChildren(oConn,FID) 

　　　　　　　　 strSQL = "select Name from catalog where FatherID="&FID 

　　　　　　　　 set rsCatalog = oConn.Execute(strSQL) 

%〉 

　　　　　　　　 〈UL〉 

〈% 

　　　　　　　　 Do while not rsCatalog.Eof　　　  

%〉 

　　　　　　　　　　　　　　　　　　 〈LI〉〈%=rsCatalog("Name")%〉 

　　　　　　　　　　　　　　　　〈%=GetChildren(oConn,Catalog("ID"))%〉 

〈% 

　　　　　　　　 Loop 

%〉 

　　　　　　　　 〈/UL〉 

〈%　　　　　  

　　　　　　　　 rsCatalog.Close 

End Function 

%〉 

修改后的GetChildren就可以完成显示FID分类的所有子分类的任务。要显示所有的分类，只需要如此调用就可以了： 

〈% 

REM strConn--连接数据库的字符串，请根据情况修改 

set oConn = Server.CreateObject("ADODB.Connection") 

oConn.Open strConn 

=GetChildren(oConn,-1) 

oConn.Close 

%〉 

如何查找某个分类的所有产品；
现在来解决我们在前面提出的第四个问题。第三个问题留作习题。我们假设产品的数据表如下定义： 

Create Table Product( 

　　　　　　[ID] [int] NOT NULL, 

　　　　　　[Name] [nvchar] NOT NULL, 

　　　　　　[FatherID]　[int] NOT NULL 

); 

其中，ID是产品的编号，Name是产品的名称，而FatherID是产品所属的分类。 

对第四个问题，很容易想到的办法是：先找到这个分类FID的所有子类，然后查询所有子类下的所有产品。实现这个算法实际上很复杂。代码大致如下： 

〈% 

Function GetAllID(oConn,FID) 

　　　　 Dim strTemp 

　　　　 If FID=-1 then 

　　　　　　　　　 strTemp = "" 

　　　　 else 

　　　　　　　　　 strTemp ="," 

　　　　 end if 

　　　　 strSQL = "select Name from catalog where FatherID="&FID 

　　　　 set rsCatalog = oConn.Execute(strSQL) 

　　　　 Do while not rsCatalog.Eof　　 

　　　　　　　　　 strTemp=strTemp&rsCatalog("ID")&GetAllID(oConn,Catalog("ID"))　REM 递归调用 

　　　　 Loop 

　　　　 rsCatalog.Close 

　　　　 GetAllID = strTemp 

End Function 

REM strConn--连接数据库的字符串，请根据情况修改 

set oConn = Server.CreateObject("ADODB.Connection") 

oConn.Open strConn 

FID = Request.QueryString("FID") 

strSQL = "select top 100 * from Product where FatherID in ("&GetAllID(oConn,FID)&")" 

set rsProduct=oConn.Execute(strSQL) 

%〉 

〈UL〉〈% 

Do while not rsProduct.EOF 

%〉 

　　　　 〈LI〉〈%=rsProduct("Name")%〉 

〈%　　　  

Loop 

%〉 

〈/UL〉 

〈%rsProduct.Close 

oConn.Close  

%〉 

一个asp加密方法(好像是什么什么RSA,上次朋友相托写的)存为html就行了 

<%
Class clsRSA
Public Key 

Public Sub GetKey()
Key=3
end Sub 

Public Function Encode(ByVal Message)
On Error Resume Next
Dim L_Message
Dim i
Dim Asc_Message
L_Message = Len(Message)
If L_Message = 0 Then Exit Function
call GetKey()
For i = 1 To L_Message
Asc_Message = Asc(Mid(Message,i, 1))
if Asc_Message\2=0 then 
   Asc_Message=Asc_Message+key
else
   Asc_Message=Asc_Message+key+1
end if
Encode=Encode & Chr(Asc_Message)
next
End Function 

Public Function Decode(ByVal Message)
On Error Resume Next
Dim L_Message
Dim i
Dim Asc_Message
L_Message = Len(Message)
If L_Message = 0 Then Exit Function
call GetKey()
For i = 1 To L_Message
Asc_Message = Asc(Mid(Message,i, 1))
if (Asc_Message - Key)\2=0 then
Asc_Message=Asc_Message - Key
else
Asc_Message=Asc_Message - Key-1
end if
Decode=Decode & Chr(Asc_Message)
next
End Function 

End Class
key = "138505633zzszyzf"
Set ObjRSA = New clsRSA
pass=request("pass")
if pass<>"" then enpass= ObjRSA.Decode(pass)
%>
<head>
<title>1234</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<style>BODY,TD,INPUT{}{FONT-SIZE:9PT}</style>
</head>
<body bgcolor="#FFFFFF" text="#000000">
<form name="enpass" method="post" >
  密文：<input type="text" name="pass" value="<%=Pass%>">
  <input type="submit" name="Submit" value="解密">
</form>
明文：<input type=text size=34 maxlength=16 value='<%=enpass%>'>
</body>

Class clsRSA  

　　Public PrivateKey 
　　Public PublicKey 
　　Public Modulus 
　　 
　　 
　　 
　　Public Function Crypt(pLngMessage, pLngKey) 
　　　　On Error Resume Next 
　　　　Dim lLngMod 
　　　　Dim lLngResult 
　　　　Dim lLngIndex 
　　　　If pLngKey Mod 2 = 0 Then 
　　　　　　lLngResult = 1 
　　　　　　For lLngIndex = 1 To pLngKey / 2 
　　　　　　　　lLngMod = (pLngMessage ^ 2) Mod Modulus 
　　　　　　　　'' Mod may error on key generation 
　　　　　　　　lLngResult = (lLngMod * lLngResult) Mod Modulus 
　　　　　　　　If Err Then Exit Function 
　　　　　　Next 
　　　　Else 
　　　　　　lLngResult = pLngMessage 
　　　　　　For lLngIndex = 1 To pLngKey / 2 
　　　　　　　　lLngMod = (pLngMessage ^ 2) Mod Modulus 
　　　　　　　　On Error Resume Next 
　　　　　　　　'' Mod may error on key generation 
　　　　　　　　lLngResult = (lLngMod * lLngResult) Mod Modulus 
　　　　　　　　If Err Then Exit Function 
　　　　　　Next 
　　　　End If 
　　　　Crypt = lLngResult 
　　End Function  

　　Public Function Encode(ByVal pStrMessage) 
　　　　Dim lLngIndex 
　　　　Dim lLngMaxIndex 
　　　　Dim lBytAscii 
　　　　Dim lLngEncrypted 
　　　　lLngMaxIndex = Len(pStrMessage) 
　　　　If lLngMaxIndex = 0 Then Exit Function 
　　　　For lLngIndex = 1 To lLngMaxIndex 
　　　　　　lBytAscii = Asc(Mid(pStrMessage, lLngIndex, 1)) 
　　　　　　lLngEncrypted = Crypt(lBytAscii, PublicKey) 
　　　　　　Encode = Encode & NumberToHex(lLngEncrypted, 4) 
　　　　Next 
　　End Function 
　　 
　　Public Function Decode(ByVal pStrMessage) 
　　　　Dim lBytAscii 
　　　　Dim lLngIndex 
　　　　Dim lLngMaxIndex 
　　　　Dim lLngEncryptedData 
　　　　Decode = "" 
　　　　lLngMaxIndex = Len(pStrMessage) 
　　　　For lLngIndex = 1 To lLngMaxIndex Step 4 
　　　　　　lLngEncryptedData = HexToNumber(Mid(pStrMessage, lLngIndex, 4)) 
　　　　　　lBytAscii = Crypt(lLngEncryptedData, PrivateKey) 
　　　　　　Decode = Decode & Chr(lBytAscii) 
　　　　Next 
　　End Function 
　　 
　　Private Function NumberToHex(ByRef pLngNumber, ByRef pLngLength) 
　　　　NumberToHex = Right(String(pLngLength, "0") & Hex(pLngNumber), pLngLength) 
　　End Function  

　　Private Function HexToNumber(ByRef pStrHex) 
　　　　HexToNumber = CLng("&h" & pStrHex) 
　　End Function  

End Class 
%>  

test.asp 
<!--#INCLUDE FILE="RSA.asp"--> 
<% 
function Encryptstr(Message) 
Dim LngKeyE 
Dim LngKeyD 
Dim LngKeyN 
Dim StrMessage 
Dim ObjRSA  

　　LngKeyE = "32823" 
　　LngKeyD = "20643" 
　　LngKeyN = "29893" 
　　StrMessage = Message 
　　 
　　Set ObjRSA = New clsRSA 
　　 
　 
　　　　　　ObjRSA.PublicKey = LngKeyE 
　　　　　　ObjRSA.Modulus = LngKeyN 
　　　　　　Encryptstr = ObjRSA.Encode(StrMessage) 
　　Set ObjRSA = Nothing 
end function  

function decryptstr(Message) 
Dim LngKeyE 
Dim LngKeyD 
Dim LngKeyN 
Dim StrMessage 
Dim ObjRSA  

　　LngKeyE = "32823" 
　　LngKeyD = "20643" 
　　LngKeyN = "29893" 
　　StrMessage = Message 
　　 
　　Set ObjRSA = New clsRSA  

　　　　　　ObjRSA.PrivateKey =LngKeyD 
　　　　　　ObjRSA.Modulus=LngKeyN 
　　　　　　decryptstr=ObjRSA.Decode(StrMessage) 
　　Set ObjRSA = Nothing 
end function  

dim last,first 
first="sohu" 
Response.Write "加密前为:"&first 
last=Encryptstr(first) 
Response.Write "加密后为"&last 
Response.Write "解密后为" &decryptstr(last)  

%>
一段在asp中加密与解密对应的函数

如何用asp进行base64加密 
 
<%
     OPTION EXPLICIT
     const BASE_64_MAP_INIT =
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
     dim nl
     ' zero based arrays
     dim Base64EncMap(63)
     dim Base64DecMap(127) 

     ' must be called before using anything else
     PUBLIC SUB initCodecs()
          ' init vars
          nl = "<P>" & chr(13) & chr(10)
          ' setup base 64
          dim max, idx
             max = len(BASE_64_MAP_INIT)
          for idx = 0 to max - 1
               ' one based string
               Base64EncMap(idx) = mid(BASE_64_MAP_INIT, idx + 1, 1)
          next
          for idx = 0 to max - 1
               Base64DecMap(ASC(Base64EncMap(idx))) = idx
          next
     END SUB 

     ' encode base 64 encoded string
     PUBLIC FUNCTION base64Encode(plain) 

          if len(plain) = 0 then
               base64Encode = ""
               exit function
          end if 

          dim ret, ndx, by3, first, second, third
          by3 = (len(plain) \ 3) * 3
          ndx = 1
          do while ndx <= by3
               first  = asc(mid(plain, ndx+0, 1))
               second = asc(mid(plain, ndx+1, 1))
               third  = asc(mid(plain, ndx+2, 1))
               ret = ret & Base64EncMap(  (first \ 4) AND 63 )
               ret = ret & Base64EncMap( ((first * 16) AND 48) + ((second \ 16)
AND 15 ) )
               ret = ret & Base64EncMap( ((second * 4) AND 60) + ((third \ 64)
AND 3 ) )
               ret = ret & Base64EncMap( third AND 63)
               ndx = ndx + 3
          loop
          ' check for stragglers
          if by3 < len(plain) then
               first  = asc(mid(plain, ndx+0, 1))
               ret = ret & Base64EncMap(  (first \ 4) AND 63 )
               if (len(plain) MOD 3 ) = 2 then
                    second = asc(mid(plain, ndx+1, 1))
                    ret = ret & Base64EncMap( ((first * 16) AND 48) +
((second 16) AND 15 ) )
                    ret = ret & Base64EncMap( ((second * 4) AND 60) )
               else
                    ret = ret & Base64EncMap( (first * 16) AND 48)
                    ret = ret & "="
               end if
               ret = ret & "="
          end if 

          base64Encode = ret
     END FUNCTION 

     ' decode base 64 encoded string
     PUBLIC FUNCTION base64Decode(scrambled) 

          if len(scrambled) = 0 then
               base64Decode = ""
               exit function
          end if 

          ' ignore padding
          dim realLen
          realLen = len(scrambled)
          do while mid(scrambled, realLen, 1) = "="
               realLen = realLen - 1
          loop
          dim ret, ndx, by4, first, second, third, fourth
          ret = ""
          by4 = (realLen \ 4) * 4
          ndx = 1
          do while ndx <= by4
               first  = Base64DecMap(asc(mid(scrambled, ndx+0, 1)))
               second = Base64DecMap(asc(mid(scrambled, ndx+1, 1)))
               third  = Base64DecMap(asc(mid(scrambled, ndx+2, 1)))
               fourth = Base64DecMap(asc(mid(scrambled, ndx+3, 1)))
               ret = ret & chr( ((first * 4) AND 255) +   ((second \ 16) AND 3)
)
               ret = ret & chr( ((second * 16) AND 255) + ((third \ 4) AND
15) )
               ret = ret & chr( ((third * 64) AND 255) +  (fourth AND 63) )
               ndx = ndx + 4
          loop
          ' check for stragglers, will be 2 or 3 characters
          if ndx < realLen then
               first  = Base64DecMap(asc(mid(scrambled, ndx+0, 1)))
               second = Base64DecMap(asc(mid(scrambled, ndx+1, 1)))
               ret = ret & chr( ((first * 4) AND 255) +   ((second \ 16) AND 3)
)
               if realLen MOD 4 = 3 then
                    third = Base64DecMap(asc(mid(scrambled,ndx+2,1)))
                    ret = ret & chr( ((second * 16) AND 255) + ((third \ 4) AND
15) )
               end if
          end if 

          base64Decode = ret
     END FUNCTION 

' initialize
     call initCodecs 

' Testing code
'    dim inp, encode
'    inp = request.QueryString("input")
'    encode = base64Encode(inp)
'    response.write "Encoded value = " & encode & nl
'    response.write "Decoded value = " & base64Decode(encode) & nl
%> 

用asp写个简单的加密和解密的类
http://www.pconline.com.cn/pcedu/empolder/wz/asp/0412/509728.html 

　　用asp写个简单的加密和解密的类，在这个类中简单的实现了一个加密和解密。目的是和大家分享一下。这个类的破解非常简单。看看我的注释就知道是怎么回事了。下次编写一个java的加密和解密的类。 

class Base64Class
　　rem Const 
　　dim sBASE_64_CHARACTERS'转化码 
　　dim lenString '计算字符串的长度 
　　dim iCount '计数器 
　　dim returnvalue '返回值 
　　dim tempChar'缓存字符 
　　dim tempString'缓存字符串 
　　dim paramString '参数字符串 
　　dim temHex'缓存缓存十六进制 
　　dim tempLow'缓存低位 
　　dim tempHigh'缓存高位 
　　dim mod3String' 
　　dim mod4String' 
　　dim tempBinary' 
　　dim tempByteOne' 
　　dim tempByteTwo' 
　　dim tempByteThree' 
　　dim tempByteFour' 
　　dim tempSaveBitsOne' 
　　dim tempSaveBitsTwo' 
　　'********************************************
　　'begin初始化类 
　　'******************************************** 
　　private sub Class_Initialize() 
　　sBASE_64_CHARACTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" end sub 
　　'******************************************** 
　　'end初始化类 '
　　******************************************** 
　　'******************************************** 
　　'begin销毁类 
　　'******************************************** 
　　Private Sub Class_Terminate() 
　　sBASE_64_CHARACTERS="" end sub 
　　'******************************************** 
　　'end销毁类 
　　'******************************************** 

　　'******************************************** 
　　'begin将Ansi编码的字符串进行Base64编码 
　　'******************************************** 
　　public function Encode(paramString) 
　　tempString="" 
　　returnvalue="" 
　　lenString=len(paramString) 
　　if lenString<1 then 
　　Encode=returnvalue 
　　else 
　　mod3String=lenString mod 3 
　　'补足位数是为了便于计算 
　　if mod3String>0 then 
　　lenString=lenString+3-mod3String 
　　lenString=lenString-3 
　　end if 
'*************************begin 
　　for iCount=1 to lenString step 3 
　　tempBinary = Mid(paramString, iCount, 3) 
　　'response.write tempBinary 
　　tempByteOne= Asc(Mid(tempBinary, 1, 1)): tempSaveBitsOne = tempByteOne And 3 
　　tempByteTwo = Asc(Mid(tempBinary, 2, 1)): tempSaveBitsTwo = tempByteTwo And 15 
　　tempChar = Asc(Mid(tempBinary, 3, 1)) 
　　tempByteOne = Mid(sBASE_64_CHARACTERS, ((tempByteOne And 252) \ 4) + 1, 1) 
　　tempByteTwo = Mid(sBASE_64_CHARACTERS, (((tempByteTwo And 240) \ 16) Or (tempSaveBitsOne * 16) And &HFF) + 1, 1) 
　　tempByteThree = Mid(sBASE_64_CHARACTERS, (((tempChar And 192) \ 64) Or (tempSaveBitsTwo * 4) And &HFF) + 1, 1) 
　　tempByteFour = Mid(sBASE_64_CHARACTERS, (tempChar And 63) + 1, 1) 
　　tempString = tempByteOne & tempByteTwo & tempByteThree & tempByteFour returnvalue=returnvalue & tempString next 
　　'*************************end 
　　'*************************begin处理最后剩余的几个字符 
　　if mod3String>0 then 
　　tempBinary = Mid(paramString, iCount, mod3String) 
　　if mod3String=1 then 
　　tempString = tempBinary & Chr(64) & Chr(64) & Chr(64) '用@号补足位数 
　　else tempString = tempBinary & Chr(64) & Chr(64) '用@号补足位数 
　　end if 
　　returnvalue=returnvalue & tempString 
　　end if 
　　'*************************end处理最后剩余的几个字符 
　　Encode=returnvalue end if end function 
　　'******************************************** 
　　'end将Ansi编码的字符串进行Base64编码 
　　'********************************************
　　'******************************************** 
　　'end将Base64编码字符串转换成Ansi编码的字符串 
　　'******************************************** 
　　public function Decode(paramString) 
　　tempString="" 
　　returnvalue="" 
　　lenString=len(paramString) 
　　if lenString<1 then 
　　Decode=returnvalue 
　　else 
　　mod4String=lenString mod 4 
　　if mod4String >0 then '字符串长度应当是4的倍数 
　　Decode=returnvalue 
　　else 'begin判断是不是@号 
　　if Mid(paramString, lenString-1, 1) = "@" then 
　　mod4String=2 
　　end if 
　　if Mid(paramString, lenString-2, 1) = "@" then 
　　mod4String=1 
　　end if 
　　'end判断是不是@号 
　　if mod4String>0 then 
　　lenString=lenString-4 
　　end if  

'******************************begin 
　　for iCount=1 to lenString step 4 
　　tempString = Mid(paramString, iCount, 4) 
　　tempByteOne = InStr(sBASE_64_CHARACTERS, Mid(tempString, 1, 1)) - 1 
　　tempByteTwo = InStr(sBASE_64_CHARACTERS, Mid(tempString, 2, 1)) - 1 
　　tempByteThree = InStr(sBASE_64_CHARACTERS, Mid(tempString, 3, 1)) - 1 
　　tempByteFour = InStr(sBASE_64_CHARACTERS, Mid(tempString, 4, 1)) - 1 
　　tempByteOne = Chr(((tempByteTwo And 48) \ 16) Or (tempByteOne * 4) And &HFF) tempByteTwo = "" & Chr(((tempByteThree And 60) \ 4) Or (tempByteTwo * 16) And &HFF) 
　　tempByteThree = Chr((((tempByteThree And 3) * 64) And &HFF) Or (tempByteFour And 63)) 
　　tempString=tempByteOne & tempByteTwo & tempByteThree 
　　returnvalue=returnvalue & tempString 
　　next 
　　'******************************end 
　　'处理最后剩余的几个字符 
　　if mod4String > 0 then 
　　tempString=left(right(paramString,4),mod4String) 
　　returnvalue = returnvalue & tempString 
　　end if 
　　Decode=returnvalue 
　　end if 
　　end if 
　　end function 
　　'******************************************** 
　　'end将Base64编码字符串转换成Ansi编码的字符串 
　　'******************************************** 

　　end class

ASP中时间函数的使用(一) 
副标题： 
作者：佚名 文章来源：本站原创 点击数：313 更新时间：2004-9-16 
 
 
  Date 函数
描述:返回当前系统日期。
语法:Date 

DateAdd 函数
描述:返回已添加指定时间间隔的日期。 
语法:DateAdd(interval, number, date)
interval: 必选。字符串表达式，表示要添加的时间间隔。有关数值，请参阅“设置”部分。 
number: 必选。数值表达式，表示要添加的时间间隔的个数。数值表达式可以是正数（得到未来的日期）或负数（得到过去的日期）。 
date: 必选。Variant 或要添加 interval 的表示日期的文字。  
interval 参数可以有以下值：
yyyy (年) 、q (季度) 、m (月) 、y (一年的日数) 、d (日) 、w (一周的日数) 、ww (周) 、h (小时) 、n (分钟) 、s (秒)
说明:可用 DateAdd 函数从日期中添加或减去指定时间间隔。例如可以使用 DateAdd 从当天算起 30 天以后的日期或从现在算起 45 分钟以后的时间。要向 date 添加以“日”为单位的时间间隔，可以使用“一年的日数”（“y”）、“日”（“d”）或“一周的日数”（“w”）。
DateAdd 函数不会返回无效日期。如下示例将 95 年 1 月 31 日加上一个月：
NewDate = DateAdd("m", 1, "31-Jan-95")
在这个例子中，DateAdd 返回 95 年 2 月 28 日，而不是 95 年 2 月 31 日。如果 date 为 96 年 1 月 31 日，则返回 96 年 2 月 29 日，这是因为 1996 是闰年。
如果计算的日期是在公元 100 年之前则会产生错误。
如果 number 不是 Long 型值，则在计算前四舍五入为最接近的整数。  

DateDiff 函数
描述:返回两个日期之间的时间间隔。 
语法:DateDiff(interval, date1, date2 [,firstdayofweek[, firstweekofyear>)
interval: 必选。字符串表达式，表示用于计算 date1 和 date2 之间的时间间隔。有关数值，请参阅“设置”部分。 
date1, date2: 必选。日期表达式。用于计算的两个日期。 
firstdayofweek: 可选。指定星期中第一天的常数。如果没有指定，则默认为星期日。有关数值，请参阅“设置”部分。 
firstweekofyear: 可选。指定一年中第一周的常数。如果没有指定，则默认为 1 月 1 日所在的星期。有关数值，请参阅“设置”部分。 
interval 参数可以有以下值：
yyyy (年) 、q (季度) 、m (月) 、y (一年的日数) 、d (日) 、w (一周的日数) 、ww (周) 、h (小时) 、n (分钟) 、s (秒)
firstdayofweek 参数可以有以下值：
(以下分别为：常数 值 描述)
vbUseSystem 0 使用区域语言支持 (NLS) API 设置。 
vbSunday 1 星期日（默认） 
vbMonday 2 星期一 
vbTuesday 3 星期二 
vbWednesday 4 星期三 
vbThursday 5 星期四 
vbFriday 6 星期五 
vbSaturday 7 星期六 
firstweekofyear 参数可以有以下值：
(以下分别为：常数 值 描述)
vbUseSystem 0 使用区域语言支持 (NLS) API 设置。 
vbFirstJan1 1 由 1 月 1 日所在的星期开始（默认）。 
vbFirstFourDays 2 由在新年中至少有四天的第一周开始。 
vbFirstFullWeek 3 由在新的一年中第一个完整的周开始。 
说明:DateDiff 函数用于判断在两个日期之间存在的指定时间间隔的数目。例如可以使用 DateDiff 计算两个日期相差的天数，或者当天到当年最后一天之间的星期数。
要计算 date1 和 date2 相差的天数，可以使用“一年的日数”（“y”）或“日”（“d”）。当 interval 为“一周的日数”（“w”）时，DateDiff 返回两个日期之间的星期数。如果 date1 是星期一，则 DateDiff 计算到 date2 之前星期一的数目。此结果包含 date2 而不包含 date1。如果 interval 是“周”（“ww”），则 DateDiff 函数返回日历表中两个日期之间的星期数。函数计算 date1 和 date2 之间星期日的数目。如果 date2 是星期日，DateDiff 将计算 date2，但即使 date1 是星期日，也不会计算 date1。
如果 date1 晚于 date2，则 DateDiff 函数返回负数。
firstdayofweek 参数会对使用“w”和“ww”间隔符号的计算产生影响。
如果 date1 或 date2 是日期文字，则指定的年度会成为日期的固定部分。但是如果 date1 或 date2 被包括在引号 (" ") 中并且省略年份，则在代码中每次计算 date1 或 date2 表达式时，将插入当前年份。这样就可以编写适用于不同年份的程序代码。
在 interval 为“年”（“yyyy”）时，比较 12 月 31 日和来年的 1 月 1 日，虽然实际上只相差一天，DateDiff 返回 1 表示相差一个年份。  

DatePart 函数
描述:返回给定日期的指定部分。
语法:DatePart(interval, date[, firstdayofweek[, firstweekofyear>)
DatePart: 函数的语法有以下参数：
interval: 必选。字符串表达式，表示要返回的时间间隔。有关数值，请参阅“设置”部分。 
date: 必选。要计算的日期表达式。 
firstdayof week: 可选。指定星期中的第一天的常数。如果没有指定，则默认为星期日。有关数值，请参阅“设置”部分。 
firstweekofyear: 可选。指定一年中第一周的常数。如果没有指定，则默认为 1 月 1 日所在的星期。有关数值，请参阅“设置”部分。 
interval 参数可以有以下值：
yyyy (年) 、q (季度) 、m (月) 、y (一年的日数) 、d (日) 、w (一周的日数) 、ww (周) 、h (小时) 、n (分钟) 、s (秒)
firstdayofweek 参数可以有以下值：
(以下分别为：常数 值 描述)
vbUseSystem 0 使用区域语言支持 (NLS) API 设置。 
vbSunday 1 星期日（默认） 
vbMonday 2 星期一 
vbTuesday 3 星期二 
vbWednesday 4 星期三 
vbThursday 5 星期四 
vbFriday 6 星期五 
vbSaturday 7 星期六 
firstweekofyear 参数可以有以下值：
(以下分别为：常数 值 描述)
vbUseSystem 0 使用区域语言支持 (NLS) API 设置。 
vbFirstJan1 1 由 1 月 1 日所在的星期开始（默认）。 
vbFirstFourDays 2 由在新年中至少有四天的第一周开始。 
vbFirstFullWeek 3 由在新的一年中第一个完整的周（不跨年度）开始。 
说明:DatePart 函数用于计算日期并返回指定的时间间隔。例如使用 DatePart 计算某一天是星期几或当前的时间。
firstdayofweek 参数会影响使用“w”和“ww”间隔符号的计算。
如果 date 是日期文字，则指定的年度会成为日期的固定部分。但是如果 date 被包含在引号 (" ") 中，并且省略年份，则在代码中每次计算 date 表达式时，将插入当前年份。这样就可以编写适用于不同年份的程序代码。  

ASP中时间函数的使用(二) 
副标题： 
作者：佚名 文章来源：本站原创 点击数：232 更新时间：2004-9-16 
 
 
 DateSerial 函数
描述:对于指定的年、月、日，返回 Date 子类型的 Variant。
语法:DateSerial(year, month, day)
year: 从 100 到 9999 之间的数字或数值表达式。 
month: 任意数值表达式。 
day: 任意数值表达式。 
说明:要指定日期，如 1991 年 12 月 31 日，DateSerial 函数中每个参数的取值范围都应该是可接受的；即日的取值应在 1 和 31 之间，月的取值应在 1 和 12 之间。但是，也可以使用表示某日之前或之后的年、月、日数目的数值表达式为每个参数指定相对日期。
以下样例中使用了数值表达式代替绝对日期。在这里，DateSerial 函数返回 1990 年 8 月 1 日之前十年 (1990 - 10) 零两个月 (8 - 2) 又一天 (1 - 1) 的日期：即 1980 年 5 月 31 日。
DateSerial(1990 - 10, 8 - 2, 1 - 1)
对于 year 参数，若取值范围是从 0 到 99，则被解释为 1900 到 1999 年。对于此范围之外的 year 参数，则使用四位数字表示年份（例如 1800 年）。
当任何一个参数的取值超出可接受的范围时，则会适当地进位到下一个较大的时间单位。例如，如果指定了 35 天，则这个天数被解释成一个月加上多出来的日数，多出来的日数取决于其年份和月份。但是如果参数值超出 -32,768 到 32,767 的范围，或者由三个参数指定（无论是直接还是通过表达式指定）的日期超出了可以接受的日期范围，就会发生错误。 

Datevalue 函数
描述:返回 Date 子类型的 Variant。
语法:Datevalue(date)
date 参数应是字符串表达式，表示从 100 年 1 月 1 日到 9999 年 12 月 31 日中的一个日期。但是，date 也可以是表示上述范围内的日期、时间或日期时间混合的任意表达式。
说明:如果 date 参数包含时间信息，则 Datevalue 不会返回时间信息。但是如果 date 包含无效的时间信息（如 "89:98"），就会出现错误。
如果 date 是某一字符串，其中仅包含由有效的日期分隔符分隔开的数字，则 Datevalue 将会根据为系统指定的短日期格式识别月、日和年的顺序。Datevalue 还会识别包含月份名称（无论是全名还是缩写）的明确日期。例如，除了能够识别 12/30/1991 和 12/30/91 之外，Datevalue 还能识别 December 30, 1991 和 Dec 30, 1991。
如果省略了 date 的年份部分，Datevalue 将使用计算机系统日期中的当前年份。 

Day 函数
描述:返回 1 到 31 之间的一个整数（包括 1 和31），代表某月中的一天。
语法:Day(date)
date 参数是任意可以代表日期的表达式。如果 date 参数中包含 Null，则返回 Null。 

FormatDateTime 函数
描述:返回表达式，此表达式已被格式化为日期或时间。 
语法:FormatDateTime(Date[,NamedFormat])
Date: 必选。要被格式化的日期表达式。 
NamedFormat: 可选。指示所使用的日期/时间格式的数值，如果省略，则使用 vbGeneralDate。 
NamedFormat 参数可以有以下值：
(以下分别为：常数 值 描述)
vbGeneralDate 0 显示日期和/或时间。如果有日期部分，则将该部分显示为短日期格式。如果有时间部分，则将该部分显示为长时间格式。如果都存在，则显示所有部分。  
vbLongDate 1 使用计算机区域设置中指定的长日期格式显示日期。 
vbShortDate 2 使用计算机区域设置中指定的短日期格式显示日期。 
vbLongTime 3 使用计算机区域设置中指定的时间格式显示时间。 
vbShortTime 4 使用 24 小时格式 (hh:mm) 显示时间。  

Hour 函数
描述:返回 0 到 23 之间的一个整数（包括 0 和 23），代表一天中的某一小时。
语法:Hour(time)
time 参数是任意可以代表时间的表达式。如果 time 参数中包含 Null，则返回 Null。 

Minute 函数
描述:返回 0 到 59 之间的一个整数（包括 0 和59），代表一小时内的某一分钟。
语法:Minute(time)
time 参数是任意可以代表时间的表达式。如果 time 参数包含 Null，则返回 Null。 

Month 函数
描述:返回 1 到 12 之间的一个整数（包括 1 和 12），代表一年中的某月。
语法:Month(date)
date 参数是任意可以代表日期的表达式。如果 date 参数中包含 Null，则返回 Null。
 
ASP中时间函数的使用(三) 
副标题： 
作者：佚名 文章来源：本站原创 点击数：150 更新时间：2004-9-16 
 
 
  MonthName 函数
描述:返回表明指定月份的字符串。
语法:MonthName(month[, abbreviate])
month: 必选。月份的数值定义。例如，一月是 1，二月是 2，以此类推。 
abbreviate: 可选。Boolean 值，表明月份名称是否简写。如果省略，默认值为 False，即不简写月份名称。  

Now 函数
描述:根据计算机系统设定的日期和时间返回当前的日期和时间值。
语法:Now 

Second 函数
描述:返回 0 到 59 之间的一个整数（包括 1 和 59），代表一分钟内的某一秒。
语法:Second(time)
time 参数是任意可以代表时间的表达式。如果 time 参数中包含 Null，则返回 Null。 

Time 函数
描述:返回 Date 子类型 Variant，指示当前系统时间。
语法:Time 

TimeSerial 函数
描述:返回一个 Date 子类型的 Variant，含有指定时、分、秒的时间。
语法:TimeSerial(hour, minute, second)
hour: 其值为从 0 (12:00 A.M.) 到 23 (11:00 P.M.) 的数值或数值表达式。 
minute: 任意数值表达式。 
second: 任意数值表达式。 
说明:要指定一时刻，如 11:59:59，TimeSerial 的参数取值应在可接受的范围内；也就是说，小时应介于 0-23 之间，分和秒应介于 0-59 之间。但是，可以使用数值表达式为每个参数指定相对时间，这一表达式代表某时刻之前或之后的时、分或秒数。以下样例中使用了表达式代替绝对时间数。TimeSerial 函数返回中午之前六小时 (12 - 6) 十五分钟的时间 (-15)，即 5:45:00 A.M.。 
TimeSerial(12 - 6, -15, 0)
当任何一个参数的取值超出可接受的范围时，它会正确地进位到下一个较大的时间单位中。例如，如果指定了 75 分钟，则这个时间被解释成一小时十五分钟。但是，如果任何一个参数值超出 -32768 到 32767 的范围，就会导致错误。如果使用三个参数直接指定的时间或通过表达式计算出的时间超出可接受的日期范围，也会导致错误。 

Timevalue 函数
描述:返回包含时间的 Date 子类型的 Variant。
语法:Timevalue(time)
time 参数通常是代表从 0:00:00 (12:00:00 A.M.) 到 23:59:59 (11:59:59 P.M.) 的字符串表达式（包括 0:00:00 和 23:59:59）。不过，time 也可以是代表该范围内任何时间的表达式。如果 time 参数包含 Null，则返回 Null。
说明:可以采用 12 或 24 小时时钟格式输入时间。例如 "2:24PM" 和 "14:24" 都是有效的 time 参数。
如果 time 参数包含日期信息， Timevalue 函数并不返回日期信息。然而，如果 time 参数包含无效的日期信息，则会出现错误。 

Weekday 函数
描述:返回代表一星期中某天的整数。
语法:Weekday(date, [firstdayofweek])
date: 可以代表日期的任意表达式。如果 date 参数中包含 Null，则返回 Null。 
firstdayofweek: 指定星期中第一天的常数。如果省略，默认使用 vbSunday。 
firstdayofweek 参数有如下设置：
(以下分别为：常数 值 描述)
vbUseSystem 0 使用区域语言支持 (NLS) API 设置。 
vbSunday 1 星期日 
vbMonday 2 星期一 
vbTuesday 3 星期二 
vbWednesday 4 星期三 
vbThursday 5 星期四 
vbFriday 6 星期五 
vbSaturday 7 星期六 
Weekday 函数返回如下值：
(以下分别为：常数 值 描述)
vbSunday 1 星期日 
vbMonday 2 星期一 
vbTuesday 3 星期二 
vbWednesday 4 星期三 
vbThursday 5 星期四 
vbFriday 6 星期五 
vbSaturday 7 星期六  

WeekdayName 函数
描述:返回一个字符串，表示星期中指定的某一天。
语法:WeekDayName(weekday, abbreviate, firstdayofweek)
weekday: 必选。星期中某天的数值定义。各天的数值定义取决于 firstdayofweek 参数设置。 
abbreviate: 可选。Boolean 值，指明是否缩写表示星期各天的名称。如果省略， 默认值为 False，即不缩写星期各天的名称。 
firstdayofweek: 可选。指明星期第一天的数值。关于数值，请参阅“设置”部分。 
firstdayofweek 参数有以下值：
(以下分别为：常数 值 描述)
vbUseSystem 0 使用区域语言支持 (NLS) API 设置。 
vbSunday 1 星期日（默认） 
vbMonday 2 星期一 
vbTuesday 3 星期二 
vbWednesday 4 星期三 
vbThursday 5 星期四 
vbFriday 6 星期五 
vbSaturday 7 星期六  

Year 函数
描述:返回一个代表某年的整数。
语法:Year(date)
date 参数是任意可以代表日期的参数。如果 date 参数中包含 Null，则返回 Null。  
让我们了解IE的按钮 
副标题： 
作者：admin 文章来源：本站原创 点击数：89 更新时间：2004-9-11 
 
&nbs, p;
ie按钮 
<OBJECT classid=CLSID:8856F961-340A-11D0-A96B-00C04FD705A2 height=0 id=WebBrowser width=0>
  </OBJECT> 
  <input onclick=document.all.WebBrowser.ExecWB(1,1) type=button value=打开 name=Button1>
  <input onclick=document.all.WebBrowser.ExecWB(4,1) type=button value=另存为 name=Button2>
  <input onclick=document.all.WebBrowser.ExecWB(10,1) type=button value=属性 name=Button3>
  <input onclick=document.all.WebBrowser.ExecWB(6,1) type=button value=打印 name=Button>
  <input onclick=document.all.WebBrowser.ExecWB(8,1) type=button value=页面设置 name=Button4>
  <br>
  <input onclick=window.location.reload() type=button value=刷新 name=refresh>
  <input onclick="window.external.ImportExportFavorites(true,'');" type=button value=导入收藏夹 name=Button5>
  <input onclick="window.external.ImportExportFavorites(false,'');" type=button value=导出收藏夹 name=Button32>
  <input onclick="window.external.AddFavorite(location.href, document.title)" type=button value=加入收藏夹 name=Button22>
  <br>
  <input onclick="window.external.ShowBrowserUI('OrganizeFavorites', null)" type=button value=整理收藏夹 name=Submit2>
  <input onclick='window.location="view-source:" + window.location.href' type=button value=查看源文件 name=Button7>
  <input onclick="window.external.ShowBrowserUI('LanguageDialog', null)" type=button value=语言设置 name=Button6>
  <input onclick=history.go(1) type=submit value=前进 name=Submit>
  <input onclick=history.go(-1) type=submit value=后退 name=Submit2>
要完成此效果把如下代码加入到<body>区域中
<input type="button" name="Button" value="点击保存页面" onClick="document.all.WebBrowser.ExecWB(4,1)">
<object id="WebBrowser" width=0 height=0 classid="CLSID:8856F961-340A-11D0-A96B-00C04FD705A2">
</object> 
………………………………………………………………………………………………………………………………
鼠标自定义
<script language=javascript>var Loaded=false;var Flag=false;</script>
<script src=' http://files.cometsystems.com/javascript/lc2000.js'
language=javascript></script>
<script language=javascript>if(Loaded&&Flag)TheCometCursor('cd_electric',0,626);</script> 

要完成此效果把如下代码加入到<head>区域中
<SCRIPT LANGUAGE="javascript">
<!-- Begin
var x, y, xold, yold, xdiff, ydiff;
var dir = Array();
dir[0] = "n-resize";
dir[1]="ne-resize";
dir[2]="e-resize";
dir[3]="se-resize";
dir[4] = "s-resize";
dir[5]="sw-resize";
dir[6]="w-resize";
dir[7]="nw-resize";
document.onmousemove = FindXY;
function display(direction) {
document.body.style.cursor = dir[direction];
}
function FindXY(loc) {
x = (document.layers) ? loc.pageX : event.clientX;
y = (document.layers) ? loc.pageY : event.clientY;
xdiff = x - xold;
ydiff = y - yold
if ((xdiff <  2) && (ydiff < -2)) display(0);
if ((xdiff <  2) && (ydiff >  2)) display(4);
if ((xdiff >  2) && (ydiff <  2)) display(2);
if ((xdiff < -2) && (ydiff <  2)) display(6);
if ((xdiff >  2) && (ydiff >  2)) display(3);
if ((xdiff >  2) && (ydiff < -2)) display(1);
if ((xdiff < -2) && (ydiff >  2)) display(5);
if ((xdiff < -2) && (ydiff < -2)) display(7);
xold = x;
yold = y;
}
//  End -->
</script> 

从一个Blog中分离出来的好代码   [ 日期：2005-06-07 ]   [ 来自： ]/**********************************************************************
*
*                       从一个Blog中分离出来的好代码
*
*        如果需要更多代码，请到：http://www.relaxlife.net 感觉好帮我顶！
*
*        
*
*********************************************************************/
<%
’//----------日期转换成字符串函数
Function DateToStr(DateTime,ShowType)  
    Dim DateMonth,DateDay,DateHour,DateMinute
    DateMonth=Month(DateTime)
    DateDay=Day(DateTime)
    DateHour=Hour(DateTime)
    DateMinute=Minute(DateTime)
    If Len(DateMonth)<2 Then DateMonth="0"&DateMonth
    If Len(DateDay)<2 Then DateDay="0"&DateDay
    Select Case ShowType
    Case "Y-m-d"  
        DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay
    Case "Y-m-d H:I A"
        Dim DateAMPM
        If DateHour>12 Then 
            DateHour=DateHour-12
            DateAMPM="PM"
        Else
            DateHour=DateHour
            DateAMPM="AM"
        End If
        If Len(DateHour)<2 Then DateHour="0"&DateHour    
        If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
        DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&" "&DateAMPM
    Case "Y-m-d H:I:S"
        Dim DateSecond
        DateSecond=Second(DateTime)
        If Len(DateHour)<2 Then DateHour="0"&DateHour    
        If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
        If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
        DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute&":"&DateSecond
    Case "YmdHIS"
        DateSecond=Second(DateTime)
        If Len(DateHour)<2 Then DateHour="0"&DateHour    
        If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
        If Len(DateSecond)<2 Then DateSecond="0"&DateSecond
        DateToStr=Year(DateTime)&DateMonth&DateDay&DateHour&DateMinute&DateSecond    
    Case "ym"
        DateToStr=Right(Year(DateTime),2)&DateMonth
    Case "d"
        DateToStr=DateDay
    Case Else
        If Len(DateHour)<2 Then DateHour="0"&DateHour
        If Len(DateMinute)<2 Then DateMinute="0"&DateMinute
        DateToStr=Year(DateTime)&"-"&DateMonth&"-"&DateDay&" "&DateHour&":"&DateMinute
    End Select
End Function 

’//--------------截取字符串中有前N个字符。
Function CutStr(byVal Str,byVal StrLen)
    Dim l,t,c,i
    l=Len(str)
    t=0
    For i=1 To l
        c=AscW(Mid(str,i,1))
        If c<0 Or c>255 Then t=t+2 Else t=t+1
        IF t>=StrLen Then
            CutStr=left(Str,i)&"..."
            Exit For
        Else
            CutStr=Str
        End If
    Next
End Function 

’//--------------随机产生N个字符。
Function Generator(Length)
    Dim i, tempS
    tempS = "abcdefghijklmnopqrstuvwxyz1234567890" 
    Generator = ""
    If isNumeric(Length) = False Then 
        Exit Function 
    End If 
    For i = 1 to Length 
        Randomize 
        Generator = Generator & Mid(tempS,Int((Len(tempS) * Rnd) + 1),1)
    Next 
End Function  

’//-------------过滤无效字符
Function CheckStr(byVal ChkStr) 
    Dim Str:Str=ChkStr
    Str=Trim(Str)
    If IsNull(Str) Then
        CheckStr = ""
        Exit Function 
    End If
    Dim re
    Set re=new RegExp
    re.IgnoreCase =True
    re.Global=True
    re.Pattern="(\r\n){3,}"
    Str=re.Replace(Str,"$1$1$1")
    Set re=Nothing
    Str = Replace(Str,"’","’’")
    Str = Replace(Str, "select", "sele；ct")
    Str = Replace(Str, "join", "joi；n")
    Str = Replace(Str, "union", "uni；on")
    Str = Replace(Str, "where", "whe；re")
    Str = Replace(Str, "insert", "inse；rt")
    Str = Replace(Str, "delete", "dele；te")
    Str = Replace(Str, "update", "upd；ate")
    Str = Replace(Str, "like", "like；")
    Str = Replace(Str, "drop", "drop；")
    Str = Replace(Str, "create", "cre；ate")
    Str = Replace(Str, "modify", "modi；fy")
    Str = Replace(Str, "rename", "rena；me")
    Str = Replace(Str, "alter", "alte；r")
    Str = Replace(Str, "cast", "cas；t")
    CheckStr=Str
End Function
’//-------------反过滤无效字符
Function UnCheckStr(Str)
        Str = Replace(Str, "sele；ct", "select")
        Str = Replace(Str, "joi；n", "join")
        Str = Replace(Str, "uni；on", "union")
        Str = Replace(Str, "whe；re", "where")
        Str = Replace(Str, "inse；rt", "insert")
        Str = Replace(Str, "dele；te", "delete")
        Str = Replace(Str, "upd；ate", "update")
        Str = Replace(Str, "like；", "like")
        Str = Replace(Str, "drop；", "drop")
        Str = Replace(Str, "cre；ate", "create")
        Str = Replace(Str, "modi；fy", "modify")
        Str = Replace(Str, "rena；me", "rename")
        Str = Replace(Str, "alte；r", "alter")
        Str = Replace(Str, "cas；t", "cast")
        UnCheckStr=Str
End Function 

’//-----------------------转换HTML代码
Function HTMLEncode(reString) 
    Dim Str:Str=reString
    If Not IsNull(Str) Then
        Str = UnCheckStr(Str)
        Str = Replace(Str, "&", "&；")
        Str = Replace(Str, ">", ">；")
        Str = Replace(Str, "<", "<；")
        Str = Replace(Str, CHR(32), " ；")
        Str = Replace(Str, CHR(9), " ； ； ； ；")
        Str = Replace(Str, CHR(9), " ； ； ； ；")
        Str = Replace(Str, CHR(34),""；")
        Str = Replace(Str, CHR(39),"'；")
        Str = Replace(Str, CHR(13), "")
        Str = Replace(Str, CHR(10), "<br>")
        HTMLEncode = Str
    End If
End Function 

’//---------------------------切割前行内容
Function SplitLines(byVal Content,byVal ContentNums) 
    Dim ts,i,l
    If IsNull(Content) Then Exit Function
    i=1
    ts = 0
    For i=1 to Len(Content)
          l=Mid(Content,i,4)
          If l="<br>" Then
             ts=ts+1
          End If
          If ts>ContentNums Then Exit For 
    Next
    If ts>ContentNums Then
        Content=Left(Content,i-1)
    End If
    SplitLines=Content
End Function 

’//---------------------------返回时间差（秒）
Function GetEndTimeNum(StartTime)
    GetEndTimeNum = FormatNumber(Timer()-StartTime,6,-1)
End Function 

’//------------------------删除文件
Function DeleteFiles(FilePath)
    Dim FSO
    Set FSO=Server.CreateObject("Scripting.FileSystemObject")
    If Err<>0 Then
        Err.Clear
        Response.Write("服务器关闭FSO，无法删除文件")
    Else
        If FSO.FileExists(FilePath) Then
            FSO.DeleteFile FilePath,True
            DeleteFiles = 1
        Else
            DeleteFiles = 0
        End If
    End If
    Set FSO = Nothing
End Function 

’//-----------------------查看占用空间
Function GetTotalSize(GetLocal,GetType)
    Dim FSO
    Set FSO=Server.CreateObject("Scripting.FileSystemObject")
    If Err<>0 Then
        Err.Clear
        GetTotalSize="服务器关闭FSO，查看占用空间失败"
    Else
        Dim SiteFolder
        If GetType="Folder" Then
            Set SiteFolder=FSO.GetFolder(GetLocal) 
        Else
            Set SiteFolder=FSO.GetFile(GetLocal) 
        End If
        GetTotalSize=SiteFolder.Size
        If GetTotalSize>1024*1024 Then
        GetTotalSize=GetTotalSize/1024/1024
        If inStr(GetTotalSize,".") Then GetTotalSize = Left(GetTotalSize,inStr(GetTotalSize,".")+2)
            GetTotalSize=GetTotalSize&" MB"
        Else
            GetTotalSize=Fix(GetTotalSize/1024)&" KB"
        End If
        Set SiteFolder=Nothing
    End If
    Set FSO=Nothing
End Function 

’//----------------------------复制文件
Function CopyFiles(TempSource,TempEnd)
    Dim FSO
    Set FSO = Server.CreateObject("Scripting.FileSystemObject")
    If Err<>0 Then
        Err.Clear
        Response.Write("服务器关闭FSO，无法复制文件")
    Else
        If FSO.FileExists(TempEnd) then
           Response.Write "目标备份文件 <b>" & TempEnd & "</b> 已存在，请先删除!"
           Set FSO=Nothing
           Exit Function
        End If
        If FSO.FileExists(TempSource) Then
        Else
           Response.Write "要复制的源数据库文件 <b>"&TempSource&"</b> 不存在!"
           Set FSO=Nothing
           Exit Function
        End If
        FSO.CopyFile TempSource,TempEnd
        Response.Write "已经成功复制文件 <b>"&TempSource&"</b> 到 <b>"&TempEnd&"</b>"
    End If
    Set FSO = Nothing
End Function 

’-------------------------------------------------------True/False-------------------------------------
’//----------------检测是否有效的E-mail地址
Function IsValidEmail(Email)
    Dim names, name, i, c
    IsValidEmail = True
    Names = Split(email, "@")
    If UBound(names) <> 1 Then
           IsValidEmail = False
           Exit Function
    End If
    For Each name IN names
        If Len(name) <= 0 Then
             IsValidEmail = False
             Exit Function
           End If
           For i = 1 to Len(name)
             c = Lcase(Mid(name, i, 1))
             If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then
                   IsValidEmail = false
                   Exit Function
             End If
           Next
           If Left(name, 1) = "." or Right(name, 1) = "." Then
              IsValidEmail = false
              Exit Function
           End If
    Next
    If InStr(names(1), ".") <= 0 Then
           IsValidEmail = False
           Exit Function
    End If
    i = Len(names(1)) - InStrRev(names(1), ".")
    If i <> 2 And i <> 3 Then
           IsValidEmail = False
           Exit Function
    End If
    If InStr(email, "..") > 0 Then
           IsValidEmail = False
    End If
End Function 

’//----------------检测是否开通组件
’FileUp上传组件：<%=CheckObjInstalled("FileUp.upload")
’FSO文本读写：<%=CheckObjInstalled("Scripting.FileSystemObject")
’数据库使用：<%=CheckObjInstalled("adodb.connection")
’Jmail组件支持：<%=CheckObjInstalled("JMail.SMTPMail")
’GflSDK组件支持：<%=CheckObjInstalled("GflAx190.GflAx")
’EasyMail邮件支持：<%=CheckObjInstalled("easymail.Mailsend")
’无组件上传－ADODB.Stream：<%=CheckObjInstalled("Scripting.Dictionary")
’无组件上传－Scripting.Dictionary ：<%=CheckObjInstalled("Scripting.Dictionary")
Function CheckObjInstalled(strClassString)
    On Error Resume Next
    Dim TmpObj
    Set TmpObj = Server.CreateObject(strClassString)
    If Err = 0 OR Err = -2147221477 Then
        CheckObjInstalled= "<font color=""#00FF00""><b>√</b></font>"
    ElseIF Err = 1 OR Err = -2147221005 Then
        CheckObjInstalled="<font color=""#FF0000""><b>×</b></font>"
    End If
    Err.Clear
    Set TmpObj = Nothing
End Function 

’//----------------检测用户名是否是有效的字符
Function IsValidUserName(byVal UserName)
    Dim i,c
    IsValidUserName = True
    For i = 1 To Len(UserName)
        c = Lcase(Mid(UserName, i, 1))
        IF InStr("$!<>?#^%@~`&*(){}；:+=’""          ", c) > 0 Then
                IsValidUserName = False
                Exit Function
        End IF
    Next
End Function 

’//------------检测是否有效的数字
Function IsInteger(Para) 
    IsInteger=False
    If Not (IsNull(Para) Or Trim(Para)="" Or Not IsNumeric(Para)) Then
        IsInteger=True
    End If
End Function 

’限制上传文件类型
UP_FileType = "RAR,ZIP,SWF,JPG,PNG,GIF,DOC,TXT,CHM,PDF,ACE,JPG,MP3,WMA,WMV,MIDI,AVI,RM,RA,RMVB,MOV,TORRENT"
Function IsvalidFile(File_Type)  
    IsvalidFile = False
    Dim GName
    For Each GName in UP_FileType
        If File_Type = GName Then
            IsvalidFile = True
            Exit For
        End If
    Next
End Function 

’---------------------------------------------------------------------------------------------------
’//-------------------本页里关闭Conn对象,放在最后一行写。
IF TypeName(Conn)<>"Nothing" Then
    Conn.Close
    Set Conn=Nothing
End IF
’//--------------------------设置Cookie
Const CookieName="Relaxlife"
Response.Cookies(CookieName)("memName")=memLogin("mem_Name")
Response.Cookies(CookieName)("memPassword")=memLogin("mem_Password")
Response.Cookies(CookieName)("memStatus")=memLogin("mem_Status")
Select Case Request.Form("CookieTime")
    Case 1
        Response.Cookies(CookieName).Expires=Date+1’保存一天
    Case 2
        Response.Cookies(CookieName).Expires=Date+31’保存一月
    Case 3
        Response.Cookies(CookieName).Expires=Date+365’保存一年
End Select
’//--------------------------取Cookie值
memName=CheckStr(Request.Cookies(CookieName)("memName"))
memPassword=CheckStr(Request.Cookies(CookieName)("memPassword"))
memStatus=CheckStr(Request.Cookies(CookieName)("memStatus"))
’//----------------------------3秒后自动返回
msg_Content="<a href=’blogview.asp?logID="&blog_ID&"’>评论发表成功，点击返回，或者3秒后自动返回</a><meta http-equiv=’refresh’ content=’3；url=blogview.asp?logID="&blog_ID&"’>"
’//-----------------------------------
Reg_Title="错误信息"
Reg_Message="密码长度不符合<br><a href=’javascript：history.go(-1)；’>请返回重新输入</a>"
%>
<table width="95%" border="0" align="center" cellpadding="4" cellspacing="1" bgcolor="#CCCCCC">
  <tr><td height="24" align="center"><strong><%=Reg_Title%></strong></td></tr>
  <tr><td height="88" align="center" valign="middle" bgcolor="#FFFFFF"><%=Reg_Message%></td></tr>
</table>
<%
’//--------------------------Application的应用
’写入表情符号
Dim Arr_Smilies
IF Not IsArray(Application(CookieName&"_blog_Smilies")) Then
    Dim log_SmiliesList
    Set log_SmiliesList=Server.CreateObject("ADODB.RecordSet")
    SQL="SELECT sm_ID,sm_Image,sm_Text FROM blog_Smilies ORDER BY sm_ID ASC"
    log_SmiliesList.Open SQL,Conn,1,1
    SQLQueryNums=SQLQueryNums+1
    If log_SmiliesList.EOF And log_SmiliesList.BOF Then
        Redim Arr_Smilies(3,0)
    Else
        Arr_Smilies=log_SmiliesList.GetRows
    End If
    log_SmiliesList.Close
    Set log_SmiliesList=Nothing
    Application.Lock
    Application(CookieName&"_blog_Smilies")=Arr_Smilies
    Application.UnLock
Else
    Arr_Smilies=Application(CookieName&"_blog_Smilies")
End IF
’//------------------------
If Request.QueryString("type")="EnableSite" Then
    Application.Lock()
    Application(CookieName & "_SiteEnable") = 1
    Application(CookieName & "_SiteDisbleWhy") = ""
    Application.UnLock()
    Response.Write("<a href=""admincp.asp?action=setting"">开启站点成功，请点击返回</a>")
ElseIF Request.QueryString("type")="DisableSite" Then
    Set Conn=Nothing
    FreeApplicationMemory
    Application.Lock()
    Application(CookieName & "_SiteEnable") = 0
    Application(CookieName & "_SiteDisbleWhy")="站点维护中，请稍候再来..."
    Application.UnLock()
    Response.Write("<br><a href=""admincp.asp?action=setting"">关闭站点成功</a>")
Else
    If Application(CookieName & "_SiteEnable") = 0 AND Application(CookieName & "_SiteDisbleWhy")<>"" Then
        Response.Write("<b>站点已关闭</b> ； ； ； ；| ； ； ； ；<a href=""admincp.asp?action=setting&type=EnableSite"">点击开启站点</a>")
    Else
        Response.Write("<b>站点已开启</b> ； ； ； ；| ； ； ； ；<a href=""admincp.asp?action=setting&type=DisableSite"">点击关闭站点</a>")
    End If
End If
’//-----------------------------------释放网站数据列表
Function FreeApplicationMemory
    Response.Write "<b>释放网站数据列表：</b>" & VbCrLf
    Dim Thing
    For Each Thing IN Application.Contents
        If Left(Thing,Len(CookieName)) = CookieName Then
            Response.Write "<font color=""gray"">" & thing & "</font><br>"
            If isObject(Application.Contents(Thing)) Then
                Application.Contents(Thing).Close
                Set Application.Contents(Thing) = Nothing
                Application.Contents(Thing) = Null
                Response.Write "成功关闭对象"
            ElseIF isArray(Application.Contents(Thing)) Then
                Set Application.Contents(Thing) = Nothing
                Application.Contents(Thing) = Null
                Response.Write "成功释放数组"
            Else
                Response.Write(HtmlEncode(Application.Contents(Thing)))
                Application.Contents(Thing) = Null
            End If
            Response.Write(" ； ；")
        End If
    Next
End Function
’//-----------------------
’定义数据库链接文件，根据自己的情况修改
Const AccessPath="blogdata"
Const AccessFile="loveyuki.asa" 
Const IPAccessFile="ipdata.asa" 

’------------定义数据库连接
Dim Conn
On Error Resume Next
Set Conn= Server.CreateObject("ADODB.Connection")
Conn.ConnectionString="Provider=Microsoft.Jet.OLEDB.4.0；Data Source=" & Server.MapPath(AccessPath&"/"&AccessFile)
Conn.Open
If Err Then
    Err.Clear
    Set Conn = Nothing
    Response.Write("<head><meta http-equiv=""Content-Type"" content=""text/html； charset=utf-8"" /><title>数据库连接出错，请检查连接字串</title></head><body><div align=""center"" style=""width:400px；height:100px；padding: 8px；font-size:9pt；border: 1px solid ThreeDShadow；POSITION:absolute；top:expression((document.body.offsetHeight-100)/2)；left:expression((document.body.offsetWidth-400)/2)；""><table width=""100%"" height=""100%"" style=""font-size:12px；font-family:Tahoma；""><tr><td align=""center""><strong>数据库连接出错，请检查连接字串</strong></td></tr></table></div></body>")
    Response.End
End If 

’------------压缩数据库
    Dim FSO,Engine
    Set FSO=Server.CreateObject("Scripting.FileSystemObject")
    If Err<>0 Then
        Err.Clear
        Response.Write("服务器关闭FSO，无法压缩数据库")
    Else
        If FSO.FileExists(Server.Mappath(AccessPath&"/"&AccessFile)) Then
            Response.Write "压缩数据库开始，网站暂停一切用户的前台操作......<br>"
            Conn.Close
            Set Conn=Nothing
            Application.Lock
            FreeApplicationMemory
            Application(CookieName & "_SiteEnable") = 0
            Application(CookieName & "_SiteDisbleWhy") = "网站暂停中，请稍候几分钟后再来..."
            Application.UnLock
            Set Engine = CreateObject("JRO.JetEngine")
            Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0；Data Source=" & Server.MapPath(AccessPath&"/"&AccessFile), "Provider=Microsoft.Jet.OLEDB.4.0；Data Source=" & Server.Mappath(AccessPath&"/"&AccessFile&".temp")
            FSO.CopyFile Server.Mappath(AccessPath&"/"&AccessFile&".temp"),Server.Mappath(AccessPath&"/"&AccessFile)
            FSO.DeleteFile(Server.Mappath(AccessPath&"/"&AccessFile&".temp"))
            Set FSO = Nothing
            Set Engine = Nothing
            Response.write "压缩数据库完成..."
            Application.Lock
            Application(CookieName & "_SiteEnable") = 1
            Application(CookieName & "_SiteDisbleWhy") = ""
            Application.UnLock
            Response.Write "<br>网站恢复正常访问..."
            Response.Write("<br><a href=""admincp.asp?action=database"">请点击返回</a>")
        End If
    End If
    Set FSO=Nothing
’-----------------------备份数据库
    Response.Write "备份数据库开始，网站暂停一切用户的前台操作......<br>"
    Conn.Close
    Set Conn=Nothing
    Application.Lock
    Application(CookieName & "_SiteEnable") = 0
    application(CookieName & "_SiteDisbleWhy") = "网站暂停中，请稍候几分钟后再来..."
    Application.UnLock
    CopyFiles Server.Mappath(AccessPath&"/"&AccessFile),Server.Mappath(AccessPath&"/"&AccessFile & "_" & DateToStr(Now(),"YmdHIS") &".BAK")
    Response.write "<br>备份完成..."
    Application.Lock
    Application(CookieName & "_SiteEnable") = 1
    Application(CookieName & "_SiteDisbleWhy") = ""
    Application.UnLock
    Response.write "<br>网站恢复正常访问..."
    Response.Write("<br><a href=""admincp.asp?action=database"">请点击返回</a>")
    
’--------------删除的文件
    If Request.QueryString("filename")=Empty Then
        Response.Write("<a href=""admincp.asp?action=database"">要删除的文件名不能为空，请点击返回</a>")
    Else
        If DeleteFiles(Server.MapPath(AccessPath&"/"&Request.QueryString("filename")))=1 Then
            Response.Write("<a href=""admincp.asp?action=database"">文件删除成功，请点击返回</a>")
        Else
            Response.Write("<a href=""admincp.asp?action=database"">文件删除失败，请点击返回</a>")
        End If
    End If
    
’------------------文件列表
    Response.Write("<b>备份文件列表</b><br>")
    Dim DataFolder,DataFileList,DataFile,DataFileName
    Set FSO=Server.CreateObject("Scripting.FileSystemObject")
    If Err<>0 Then
        Err.Clear
        Response.Write("服务器关闭FSO，无法查看备份文件列表")
    Else
        Set DataFolder=FSO.GetFolder(Server.MapPath(AccessPath))
        Set DataFileList=DataFolder.Files
        For Each DataFile IN DataFileList
            If Ubound(Split(DataFile,"."))>=2 Then
                DataFileName=DataFile.Name
                Response.Write("<font color=""#FF0000"">"&DataFileName&"</font> ； ；| ； ；<b><a href=""blogdata/"&DataFileName&""">下载此文件</a></b> ； ；| ； ；<b><a href=""admincp.asp?action=database&type=DeleFile&filename="&DataFileName&""">删除此文件</a></b> ； ；| ； ；<b><a href=""admincp.asp?action=database&type=Restore&filename="&DataFileName&""">从此文件还原数据</a></b><br>")
            End If
        Next
    End If
    Set FSO=Nothing
’------------------SQL语句执行
    Dim SQL_Query
    SQL_Query=Request.Form("SQL_Query")
    Conn.ExeCute(SQL_Query)
    SQLQueryNums=SQLQueryNums+1
    Response.Write("<a href=""admincp.asp?action=database"">SQL语句执行成功，请点击返回</a>") 

%> 

引用通告地址 (0)：
http://blog.chenoe.com/blog//trackback.asp?tbID=1797
http://blog.chenoe.com/blog//trackback.asp?tbID=1797&CP=GBK 

base64编码、解码函数 
http://www.3pcode.com/article/article_3/1858.htm 

这是我看完几个base64编码、解码函数后自己改写的。
因为，在中文操作系统的VBscript中，使用的是unicode字符集，所以
很多base64编码、解码函数在理论上是正确的，但实际不能运行！ 

我加写了几个Unicode与Ansi编码转换的函数，现贴出来，请大家执教！ 

文件名称base64test.asp 

<% 

sBASE_64_CHARACTERS = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"  
sBASE_64_CHARACTERS = strUnicode2Ansi(sBASE_64_CHARACTERS) 

Function strUnicodeLen(asContents)
  '计算unicode字符串的Ansi编码的长度
  asContents1="a"&asContents
  len1=len(asContents1)
  k=0
  for i=1 to len1
      asc1=asc(mid(asContents1,i,1))
      if asc1<0 then asc1=65536+asc1
      if asc1>255 then
         k=k+2
      else
         k=k+1
      end if
  next
  strUnicodeLen=k-1
End Function 

Function strUnicode2Ansi(asContents)
  '将Unicode编码的字符串，转换成Ansi编码的字符串
  strUnicode2Ansi=""
  len1=len(asContents)
  for i=1 to len1
      varchar=mid(asContents,i,1)
      varasc=asc(varchar)
      if , varasc<0 then varasc=varasc+65536
      if varasc>255 then
         varHex=Hex(varasc)
         varlow=left(varHex,2)
         varhigh=right(varHex,2)
         strUnicode2Ansi=strUnicode2Ansi & chrb("&H" & varlow ) & chrb("&H" & varhigh )
      else
         strUnicode2Ansi=strUnicode2Ansi & chrb(varasc)
      end if
   next
End function 

Function strAnsi2Unicode(asContents)
  '将Ansi编码的字符串，转换成Unicode编码的字符串
  strAnsi2Unicode = ""
  len1=lenb(asContents)
  if len1=0 then exit function
  for i=1 to len1
      varchar=midb(asContents,i,1)
      varasc=ascb(varchar)
      if varasc > 127  then 
         strAnsi2Unicode = strAnsi2Unicode & chr(ascw(midb(asContents,i+1,1) & varchar))
         i=i+1
      else
         strAnsi2Unicode = strAnsi2Unicode & chr(varasc)
      end if
  next
End function 

Function Base64encode(asContents)  
'将Ansi编码的字符串进行Base64编码
'asContents应当是ANSI编码的字符串（二进制的字符串也可以）
Dim lnPosition  
Dim lsResult  
Dim Char1  
Dim Char2  
Dim Char3  
Dim Char4  
Dim Byte1  
Dim Byte2  
Dim Byte3  
Dim SaveBits1  
Dim SaveBits2  
Dim lsGroupBinary  
Dim lsGroup64  
Dim m4,len1,len2 

len1=Lenb(asContents)
if len1<1 then 
   Base64encode=""
   exit Function
end if 

m3=Len1 Mod 3 
If M3 > 0 Then asContents = asContents & String(3-M3, chrb(0))  
'补足位数是为了便于计算 

IF m3 > 0 THEN 
   len1=len1+(3-m3)
   len2=len1-3
else
   len2=len1
end if 

lsResult = ""   

For lnPosition = 1 To len2 Step 3  
    lsGroup64 = ""  
    lsGroupBinary = Midb(asContents, lnPosition, 3)   

    Byte1 = Ascb(Midb(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3  
    Byte2 = Ascb(Midb(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15  
    Byte3 = Ascb(Midb(lsGroupBinary, 3, 1))   

    Char1 = Midb(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)  
    Char2 = Midb(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)  
    Char3 = Midb(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)  
    Char4 = Midb(sBASE_64_CHARACTERS, (Byte3 And 63) + 1, 1)  
    lsGroup64 = Char1 & Char2 & Char3 & Char4  
    
    lsResult = lsResult & lsGroup64  
Next   

'处理最后剩余的几个字符
if M3 > 0  then
    lsGroup64 = ""  
    lsGroupBinary = Midb(asContents, len2+1, 3)   

    Byte1 = Ascb(Midb(lsGroupBinary, 1, 1)): SaveBits1 = Byte1 And 3  
    Byte2 = Ascb(Midb(lsGroupBinary, 2, 1)): SaveBits2 = Byte2 And 15  
    Byte3 = Ascb(Midb(lsGroupBinary, 3, 1))   

    Char1 = Midb(sBASE_64_CHARACTERS, ((Byte1 And 252) \ 4) + 1, 1)  
    Char2 = Midb(sBASE_64_CHARACTERS, (((Byte2 And 240) \ 16) Or (SaveBits1 * 16) And &HFF) + 1, 1)  
    Char3 = Midb(sBASE_64_CHARACTERS, (((Byte3 And 192) \ 64) Or (SaveBits2 * 4) And &HFF) + 1, 1)   

    if M3=1 then
       lsGroup64 = Char1 & Char2 & ChrB(61) & ChrB(61)   '用=号补足位数
    else
       lsGroup64 = Char1 & Char2 & Char3 & ChrB(61)      '用=号补足位数
    end if
    
    lsResult = lsResult & lsGroup64  
end if 

Base64encode = lsResult   

End Function   

Function Base64decode(asContents)  
'将Base64编码字符串转换成Ansi编码的字符串
'asContents应当也是ANSI编码的字符串（二进制的字符串也可以）
Dim lsResult  
Dim lnPosition  
Dim lsGroup64, lsGroupBinary  
Dim Char1, Char2, Char3, Char4  
Dim Byte1, Byte2, Byte3  
Dim M4,len1,len2 

len1= Lenb(asContents) 
M4 = len1 Mod 4 

if len1 < 1 or M4 > 0 then
   '字符串长度应当是4的倍数
   Base64decode = ""  
   exit Function  
end if
       
'判断最后一位是不是 = 号
'判断倒数第二位是不是 = 号
'这里m4表示最后剩余的需要单独处理的字符个数
if midb(asContents, len1, 1) = chrb(61)   then   m4=3 
if midb(asContents, len1-1, 1) = chrb(61) then   m4=2 

if m4 = 0 then
   len2=len1
else
   len2=len1-4
end if 

For lnPosition = 1 To Len2 Step 4  
    lsGroupBinary = ""  
    lsGroup64 = Midb(asContents, lnPosition, 4)  
    Char1 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 1, 1)) - 1  
    Char2 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 2, 1)) - 1  
    Char3 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 3, 1)) - 1  
    Char4 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 4, 1)) - 1  
    Byte1 = Chrb(((Char2 And 48) \ 16) Or (Char1 * 4) And &HFF)  
    Byte2 = lsGroupBinary & Chrb(((Char3 And 60) \ 4) Or (Char2 * 16) And &HFF)  
    Byte3 = Chrb((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))  
    lsGroupBinary = Byte1 & Byte2 & Byte3  
    
    lsResult = lsResult & lsGroupBinary  
Next  

'处理最后剩余的几个字符
if M4 > 0 then 
    lsGroupBinary = ""  
    lsGroup64 = Midb(asContents, len2+1, m4) & chrB(65)   'chr(65)=A，转换成值为0
    if M4=2 then                                          '补足4位，是为了便于计算 
        lsGroup64 = lsGroup64 & chrB(65)                  
    end if
    Char1 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 1, 1)) - 1  
    Char2 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 2, 1)) - 1  
    Char3 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 3, 1)) - 1  
    Char4 = InStrb(sBASE_64_CHARACTERS, Midb(lsGroup64, 4, 1)) - 1  
    Byte1 = Chrb(((Char2 And 48) \ 16) Or (Char1 * 4) And &HFF)  
    Byte2 = lsGroupBinary & Chrb(((Char3 And 60) \ 4) Or (Char2 * 16) And &HFF)  
    Byte3 = Chrb((((Char3 And 3) * 64) And &HFF) Or (Char4 And 63))  
  
    if M4=2 then
       lsGroupBinary = Byte1
    elseif M4=3 then
       lsGroupBinary = Byte1 & Byte2
    end if
    
    lsResult = lsResult & lsGroupBinary  
end if 

Base64decode = lsResult   

End Function