超精华的asp代码大全第2/2页

 更新时间:2006年12月26日 00:00:00   投稿:mdxy-dxy  
这篇文章主要为大家分享几个超精华的asp代码,学习asp的朋友可以参考一下

列出你的所有Session变: 
<%@ Language=VBScript %> 
<% Option Explicit %> 
<% 
Response.Write "在你的程序中一共使用了 " & Session.Contents.Count & _ 
" 个Session变量<P>" 
Dim strName, iLoop 
For Each strName in Session.Contents 
'判断一个Session变量是否为数组 
If IsArray(Session(strName)) then 
'如果是数组,那么罗列出所有的数组元素内容 
For iLoop = LBound(Session(strName)) to UBound(Session(strName)) 
Response.Write strName & "(" & iLoop & ") - " & _ 
Session(strName)(iLoop) & "<BR>" 
Next 
Else 
'如果不是数组,那么直接显示 
Response.Write strName & " - " & Session.Contents(strName) & "<BR>" 
End If 
Next 
%> 
利用CDONTS发送邮件的ASP函数 
<% 
'Last Updated By Recon On 05/14/2001 
'On Error Resume Next 

'利用CDONTS组件在Win2k上发送邮件 

'发送普通邮件 
SendMail "admin@ny.com", "iamchn@263.net", "Normal Mail!", "Please check the attatchment!", 2, 0, "C:\Love.txt" 

'发送HTML邮件 
Dim m_fso, m_tf 
Dim m_strHTML 

Set m_fso = Server.CreateObject("SCRIPTING.FILESYSTEMOBJECT") 
Set m_tf = m_fso.OpenTextFile("C:\Mail.htm", 1) 
m_strHTML = m_tf.ReadAll 

'Write m_strHTML 
Set m_tf = Nothing 
Set m_fso = Nothing 

SendMail "admin@ny.com", "iamchn@263.net", "HTML Mail!", m_strHTML, 2, 1, Null 

'参数说明 
'strFrom : 发件人Email 
'strTo : 收件人Email 
'strSubject : 信件主题 
'strBody : 信件正文 
'lngImportance : 信件重要性 
' : 0 - 低重要性 
' : 0 - 中等重要性(默认) 
' : 0 - 高重要性 
'lngAType : 信件格式 
' : 为1时将邮件正文作为HTML(此时可以发送HTML邮件) 
'strAttach : 附件的路径 
Sub SendMail(strFrom, strTo, strSubject, strBody, lngImportance, lngAType, strAttach) 
Dim objMail 

Set objMail = Server.CreateObject("CDONTS.NEWMAIL") 
With objMail 

.From = strFrom 
.To = strTo 
.Subject = strSubject 
.Body = strBody 
.Importance = lngImportance 

If lngAType = 1 Then 
.BodyFormat = 0 
.MailFormat = 0 
End If 

If IsEmpty(strAttach) = False And IsNull(strAttach) = False Then 
.AttachFile strAttach 
End If 

.Send 
End With 
Set objMail = Nothing 
End Sub 
%> 
处理驱动器和文件夹 


使用 FileSystemObject (FSO) 对象模式,可以有计划地处理驱动器和文件夹,就像在 Windows 资源管理器中交互式地处理它们一样。可以复制和移动文件夹,获取有关驱动器和文件夹的信息,等等。 

获取有关驱动器的信息 
可以用 Drive 对象来获得有关各种驱动器的信息,这些驱动器是实物地或通过网络连接到系统上的。它的属性可以用来获得下面的信息内容: 

驱动器的总容量,以字节为单位(TotalSize 属性) 
驱动器的可用空间是多少,以字节为单位(AvailableSpace 或 FreeSpace 属性) 
哪个号被赋给了该驱动器(DriveLetter 属性) 
驱动器的类型是什么,如可移动的、固定的、网络的、CD-ROM 或 RAM 磁盘(DriveType 属性) 
驱动器的序列号(SerialNumber 属性) 
驱动器使用的文件系统类型,如 FAT、FAT32、NTFS 等等(FileSystem 属性) 
驱动器是否可以使用(IsReady 属性) 
共享和/或卷的名字(ShareName 和 VolumeName 属性) 
驱动器的路径或根文件夹(Path 和 RootFolder 属性) 
请考察示例代码,来领会如何在 FileSystemObject 中使用这些属性。 

Drive 对象用法示例 
使用 Drive 对象来收集有关驱动器的信息。在下面的代码中,没有对实际的 Drive 对象的引用;相反,使用 GetDrive 方法来获得现有 Drive 对象的引用(在这个例子中就是 drv)。 
下面示例示范了如何在 VBScript 中使用 Drive 对象: 

Sub ShowDriveInfo(drvPath) 
Dim fso, drv, s 
Set fso = CreateObject("Scripting.FileSystemObject") 
Set drv = fso.GetDrive(fso.GetDriveName(drvPath)) 
s = "Drive " & UCase(drvPath) & " - " 
s = s & drv.VolumeName & "<br/>" 
s = s & "Total Space: " & FormatNumber(drv.TotalSize / 1024, 0) 
s = s & " Kb" & "<br/>" 
s = s & "Free Space: " & FormatNumber(drv.FreeSpace / 1024, 0) 
s = s & " Kb" & "<br/>" 
Response.Write s 
End Sub 

下面的代码说明在 JScript 中实现同样的功能: 
function ShowDriveInfo1(drvPath) 

var fso, drv, s =""; 
fso = new ActiveXObject("Scripting.FileSystemObject"); 
drv = fso.GetDrive(fso.GetDriveName(drvPath)); 
s += "Drive " + drvPath.toUpperCase()+ " - "; 
s += drv.VolumeName + "<br/>"; 
s += "Total Space: " + drv.TotalSize / 1024; 
s += " Kb" + "<br/>"; 
s += "Free Space: " + drv.FreeSpace / 1024; 
s += " Kb" + "<br/>"; 
Response.Write(s); 


处理文件夹 
在下面的表中,描述了普通的文件夹任务和执行它们的方法。 
任务 方法 
创建文件夹。 FileSystemObject.CreateFolder 
删除文件夹。 Folder.Delete 或 FileSystemObject.DeleteFolder 
移动文件夹。 Folder.Move 或 FileSystemObject.MoveFolder 
复制文件夹。 Folder.Copy 或 FileSystemObject.CopyFolder 
检索文件夹的名字。 Folder.Name 
如果文件夹在驱动器上存在,则找出它。 FileSystemObject.FolderExists 
获得现有 Folder 对象的实例。 FileSystemObject.GetFolder 
找出文件夹的父文件夹名。 FileSystemObject.GetParentFolderName 
找出系统文件夹的路径。 FileSystemObject.GetSpecialFolder 


请考察示例代码,来看看在 FileSystemObject 中使用了多少种这些的方法和属性。 

下面的示例示范了如何在 VBScript 中使用 Folder 和 FileSystemObject 对象,来操作文件夹和获得有关它们的信息: 


Sub ShowFolderInfo() 
Dim fso, fldr, s 
' 获得 FileSystemObject 的实例。 
Set fso = CreateObject("Scripting.FileSystemObject") 
' 获得 Drive 对象。 
Set fldr = fso.GetFolder("c:") 
' 打印父文件夹名字。 
Response.Write "Parent folder name is: " & fldr & "<br/>" 
' 打印驱动器名字。 
Response.Write "Contained on drive " & fldr.Drive & "<br/>" 
' 打印根文件名。 
If fldr.IsRootFolder = True Then 
Response.Write "This is the root folder." & ""<br/>"<br/>" 
Else 
Response.Write "This folder isn't a root folder." & "<br/><br/>" 
End If 
' 用 FileSystemObject 对象创建新的文件夹。 
fso.CreateFolder ("C:\Bogus") 
Response.Write "Created folder C:\Bogus" & "<br/>" 
' 打印文件夹的基本名字。 
Response.Write "Basename = " & fso.GetBaseName("c:\bogus") & "<br/>" 
' 删除新创建的文件夹。 
fso.DeleteFolder ("C:\Bogus") 
Response.Write "Deleted folder C:\Bogus" & "<br/>" 
End Sub 

下面的示例显示如何在 JScript 中使用 Folder 和 FileSystemObject 对象: 
function ShowFolderInfo() 

var fso, fldr, s = ""; 
// 获得 FileSystemObject 的实例。 
fso = new ActiveXObject("Scripting.FileSystemObject"); 
// 获得 Drive 对象。 
fldr = fso.GetFolder("c:"); 
// 打印父文件夹名。 
Response.Write("Parent folder name is: " + fldr + "<br/>"); 
// 打印驱动器名字。 
Response.Write("Contained on drive " + fldr.Drive + "<br/>"); 
// 打印根文件名。 
if (fldr.IsRootFolder) 
Response.Write("This is the root folder."); 
else 
Response.Write("This folder isn't a root folder."); 
Response.Write("<br/><br/>"); 
// 用 FileSystemObject 对象创建新的文件夹。 
fso.CreateFolder ("C:\\Bogus"); 
Response.Write("Created folder C:\\Bogus" + "<br/>"); 
// 打印文件夹的基本名。 
Response.Write("Basename = " + fso.GetBaseName("c:\\bogus") + "<br/>"); 
// 删除新创建的文件夹。 
fso.DeleteFolder ("C:\\Bogus"); 
Response.Write("Deleted folder C:\\Bogus" + "<br/>"); 

ASP分页函数 

Function ExportPageInfo(ByRef rs,curpage,i,LinkFile) 
Dim retval, j, pageNumber, BasePage 

retval = "第" & curpage & "页/总" & rs.pagecount & "页 " 
retval = retval & "本页" & i & "条/总" & rs.recordcount & "条 " 

If curpage = 1 Then 
retval = retval & "首页 前页 " 
Else 
retval = retval & "<a href='" & LinkFile & "page=1'>首页</a> <a href='" & LinkFile & "page=" & cstr(curpage - 1) & "'>前页</a> " 
End If 
If curpage = rs.pagecount Then 
retval = retval & "后页 末页" 
Else 
retval = retval & "<a href='" & LinkFile & "page=" & cstr(curpage + 1) & "'>后页</a> <a href='" & LinkFile & "page=" & cstr(rs.pagecount) & "'>末页</a>" 
End if 

retval = retval & "<br/>" 
BasePage = (curpage \ 10) * 10 
If BasePage > 0 Then retval = retval & " <a href='" & LinkFile & "page=" & (BasePage - 9) & "'><<</a>" 
For j = 1 to 10 
pageNumber = BasePage + j 
If PageNumber > rs.pagecount Then Exit For 
If pageNumber = Cint(curpage) Then 
retval = retval & " <font color='#FF0000'>" & pageNumber & "</font>" 
Else 
retval = retval & " <a href='" & LinkFile & "page=" & pageNumber & "'>" & pageNumber & "</a>" 
End If 
Next 
If rs.pagecount > BasePage Then retval = retval & " <a href='" & LinkFile & "page=" & (BasePage + 11) & "'>>></a>" 

ExportPageInfo = retval 
End Function 

应用 

<% 
adoPageRS.open "SELECT * FROM news ORDER BY addtime DESC", conn, 1, 1 
if err.number <> 0 then 
response.write "数据库操作失败:"&err.description 
else 
if adoPageRS.eof and adoPageRS.bof then 
response.write "没有记录" 
else 
%> 
<div align="center"> 
<center> 
<table width="100%" border="0" cellspacing="1" cellpadding="2"> 
<tr class="big"> 
<td width="60%">新 闻 标 题</td> 
<td width="25%" align="center">日期</td> 
<td width="15%" align="center">操  作</td> 
</tr> 
<% 
adoPageRS.pagesize = 10 
adoPageRS.absolutepage = curpage 
for i = 0 to 9 
%> 
<tr> 
<td><%= adoPageRS("title") %></td> 
<td align="center"> 
<% = adoPageRS("addtime") %> 
</td> 
<td align="center"><a href='newsman.asp?action=edit&id=<%= adoPageRS("id")%>'>编辑</a> 
<a href='javascript:confirmDel(<%= adoPageRS("id") %>)'>删除</a></td> 
</tr> 
<% 
adoPageRS.movenext 
if adoPageRS.eof then 
i = i + 1 
exit for 
End If 
next 
%> 
<tr align="center"> 
<td colspan="3"> 
<% = ExportPageInfo(adoPageRS, curpage, i, "Newsman.asp?") %> 
</td> 
</tr> 
</table> 
</center> 
</div> 
从ASP调用SQL中的图像: 
如何处理ASP中的图象 在用ASP编程中,很多时侯要用到图象。对于单纯从数据库中处理一个图象,方法大家讲了很多,也不难, 可以看下面的代码: 这里假设你有个数据库名字叫:PUBS,在数据库中有一个叫:PUB_INFO的表,在表中有一个LOGO 的BLOB列。我们查出PUB_ID=0736的人的相片。 FILE: SHOWIMG.ASP *************************************** < %@ LANGUAGE="VBSCRIPT" %> < % ' Clear out the existing HTTP header information Response.Expires = 0 Response.Buffer = TRUE Response.Clear ' Change the HTTP header to reflect that an image is being passed. Response.ContentType = "image/gif" Set cn = Server.CreateObject("ADODB.Connection") ' The following open line assumes you have set up a System DataSource ' by the name of myDSN. cn.Open "DSN=myDSN;UID=sa;PWD=;DATABASE=pubs" Set rs = cn.Execute("SELECT logo FROM pub_info WHERE pub_id='0736'") Response.BinaryWrite rs("logo") Response.End %> ***************************************** 执行这个ASP文件就可以看到你存在数据库中的图象了。 但如果是同时处理文字和图象就会有些困难了:-( 比如:一个企业的人员管理,后台数据库可以用SYBASE或SQL SERVER等。(我在这用SQL SERVER)当 你在企业内部需要用到BROWSE/SERVER方式,即用浏览器查看员工的个人信息时,就即要处理文字信息同时 还要用到关于图象的技巧。 问题在于你显示文字信息时HTML的HEAD中的CONTENT=“TEXT/HTML”,而显示图象则必须是 CONTENT=“IMAGE/GIF”或者是CONTENT=”IMAGE/JPEG“。因此你是无法只用一个ASP文件就把文字信息和 图象都处理完的,解决的办法是:用一个单独的ASP文件处理图象,然后在处理文字信息的ASP文件中调用 这个ASP文件。 在这给大家介绍一个我的解决方法,希望大家一起讨论: 环境:WINNT4.0 SQL SERVER IIS3.0 数据库名:RSDA 表名:RSDA_TABLE 目的:从RSDA_TABLE中查出ID=00001的人员的信息,包括姓名,年龄和照片 第一步:创建一个查询表单RSDA.HTM: ********************************** < html> < head> < /head> < body> < form method="POST" action="SEARCH.ASP"> < p>请输入编号:< input type="text" name="T1" size="20"> < input type="submit" value="提交" name="B1"> < /form> < /body> *********************************** 第二步:建立SEARCH.ASP *********************************** < html> < head> < meta http-equiv="content-type" content="text/html;charset=gb2312"> < title>查询结果< /title> < /head> < body bgColor=Azure> < % session("RSDA_ID")=Request.Form("T1") '这里我用了一个SESSION变量,是为了在处理图象的ASP文件中再次调用 temp_id=session("RSDA_ID") < font size=4 color=OrangeRed> 查询结果:< /font> < %set conntemp=server.createobject("adodb.connection") conntemp.open "dsn=RSDA;uid=sa;pwd=SA" set rstemp=conntemp.execute("select * from RSDA_TABLE where rsda='"&temp_id&"'") % > < % 'put headings on the table of field names nobody="对不起!在我们的数据库里没有您要找的资料!"%> '判断是否有这个人 < %if rstemp.eof then % > < font size="5" color=OrangeRed> < %Response.Write(nobody)% >< /font> < %else% > < div align="center"> < center> < table border="1" width="73%" height="399"> < tr> < td width="21%" height="49" align="center">< p align="center">姓 名< /td> < td width="30%" height="49" align="center"> < font size=4 color=OrangeRed>< /font>< /td> < /td> < tr> < p align="center">年 龄< /td> < td width="30%" height="47" align="center"> < font size=4 color=OrangeRed>< %=rstemp(0)% >< /font>< /td> < /tr> < tr> < td width="49%" height="146" rowspan="3" colspan="2"> < img src="jpg.asp">< /td> 'JPG.ASP就是我们将要建立的专门处理图象的ASP文件 < /tr> < /table> < /center>< /div> rstemp.close set rstemp=nothing conntemp.close set conntemp=nothing % > < /BODY> < /HTML> *********************************** 第三步:建立处理图象的ASP文件。(JPG.ASP) *********************************** < % Response.Expires = 0 Response.Buffer = TRUE Response.Clear ' Open database Set conntemp = Server.CreateObject("ADODB.Connection") conntemp.open "dsn=RSDA;uid=sa;pwd=SA" 'change http header Response.ContentType = "image/jpeg" ' or "IMAGE/GIF" ' Get picture TEMP_ID=session("RSDA_ID") Set Rs = conntemp.Execute("SELECT photo from RSDA_table where ID='"&TEMP_ID&"'") Response.BinaryWrite Rs("photo") Session.Abandon Response.End % > ********************************** 这里主要就是用到了一个小技巧就是利用了一个SESSION变量来实现两次同条件查询。 大家如我上述只需少量改动,就可以实现一个页面既有文字又有图象了! 
asp常常用到的一些东西, 
我做东西一般下面的东西经常用(拷贝) 


<%=Request.ServerVariables("remote_addr")%> 

FOR each item in Request.form 
tempvalue=trim(Request(item)) 
tempvalue=Replace(tempvalue,chr(13)&chr(10),"<br/>") 
tempvalue=Replace(tempvalue,"<br/><br/>","<br/>") 
if tempvalue="" then tempvalue=0 
Execute item&"="""&tempvalue&"""" 
'response.write item&"="&tempvalue&"<br/>" 
next 
'response.write request("id") 
'response.end 

if ="" then 
response.write "<script language='JavaScript'>window.alert('')</script>" 
response.write "<script language='JavaScript'>window.history.go(-1);</script>" 
response.end 
end if 

<!--#include file="" --> 
<!--#include virtual="" --> 

sql="select max(id) from pack" 
set RS=conn.execute(sql) 
if isnull(RS(0)) then 
id=1 
else 
id=RS(0)+1 
end if 
set rs=nothing 


sql="insert into pack(id,strpackdm,strusername) values("&id&",'"&strpackdm&"','"&Session("username")&"')" 
set RS=conn.execute(sql) 


sql="update pack set "&Itemname&"='"&tempvalue&"' where id="&id&"" 
if Itemname<>"id" then 
response.write sql&"<br/>" 
set rs=conn.execute(sql) 


if err.number<>0 then 
'错误处理 
response.write "数据库操作失败:" & err.description 
err.clear 
end if 

Set rs=Nothing 
Conn.close 
Set conn=Nothing 

do while not rs.eof and rowcount>0 

rowcount=rowcount-1 
rs.MoveNext 

do while not rs.eof 

rs.MoveNext 
loop 

for each item in rs2.fields 
Execute item.name&"="""&trim(rs2(""&item.name&""))&"""" 
next 


function Mycn(str) 
str=lcase(str) 
str=replace(str,"","") 
response.write str 
end function 

dim conn 
dim connstr 
on error resume next 
set conn=server.CreateObject("adodb.connection") 

Connstr="driver=SQL Server; server="&servername&"; uid="&username&"; pwd="&password&"; database="&datebasename&";" 

Connstr="DBQ="+server.mappath(mydbpath&mdbname)+";DRIVER={Microsoft Access Driver (*.mdb)};" 

'response.write Connstr 
'response.end 
conn.Open connstr 
if err<>0 then 
Response.Write "无法建立到数据库的连接!" 
end if 
MD5不可逆加密算法的ASP实现实例(一) 

此为国外转载函数,可将任意字符转换为md5 16为字符加密形式,而且为不可逆转换。 
<% 
Private Const BITS_TO_A_BYTE = 8 
Private Const BYTES_TO_A_WORD = 4 
Private Const BITS_TO_A_WORD = 32 

Private m_lOnBits(30) 
Private m_l2Power(30) 

Private Function LShift(lValue, iShiftBits) 
If iShiftBits = 0 Then 
LShift = lValue 
Exit Function 
ElseIf iShiftBits = 31 Then 
If lValue And 1 Then 
LShift = &H80000000 
Else 
LShift = 0 
End If 
Exit Function 
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then 
Err.Raise 6 
End If 

If (lValue And m_l2Power(31 - iShiftBits)) Then 
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000 
Else 
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits)) 
End If 
End Function 

Private Function RShift(lValue, iShiftBits) 
If iShiftBits = 0 Then 
RShift = lValue 
Exit Function 
ElseIf iShiftBits = 31 Then 
If lValue And &H80000000 Then 
RShift = 1 
Else 
RShift = 0 
End If 
Exit Function 
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then 
Err.Raise 6 
End If 

RShift = (lValue And &H7FFFFFFE) \ m_l2Power(iShiftBits) 

If (lValue And &H80000000) Then 
RShift = (RShift Or (&H40000000 \ m_l2Power(iShiftBits - 1))) 
End If 
End Function 

Private Function RotateLeft(lValue, iShiftBits) 
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits)) 
End Function 

Private Function AddUnsigned(lX, lY) 
Dim lX4 
Dim lY4 
Dim lX8 
Dim lY8 
Dim lResult 

lX8 = lX And &H80000000 
lY8 = lY And &H80000000 
lX4 = lX And &H40000000 
lY4 = lY And &H40000000 

lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF) 

If lX4 And lY4 Then 
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8 
ElseIf lX4 Or lY4 Then 
If lResult And &H40000000 Then 
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8 
Else 
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8 
End If 
Else 
lResult = lResult Xor lX8 Xor lY8 
End If 

AddUnsigned = lResult 
End Function 

Private Function md5_F(x, y, z) 
md5_F = (x And y) Or ((Not x) And z) 
End Function 

Private Function md5_G(x, y, z) 
md5_G = (x And z) Or (y And (Not z)) 
End Function 

Private Function md5_H(x, y, z) 
md5_H = (x Xor y Xor z) 
End Function 

Private Function md5_I(x, y, z) 
md5_I = (y Xor (x Or (Not z))) 
End Function 

Private Sub md5_FF(a, b, c, d, x, s, ac) 
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), x), ac)) 
a = RotateLeft(a, s) 
a = AddUnsigned(a, 
End Sub 

Private Sub md5_GG(a, b, c, d, x, s, ac) 
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), x), ac)) 
a = RotateLeft(a, s) 
a = AddUnsigned(a, 
End Sub 

Private Sub md5_HH(a, b, c, d, x, s, ac) 
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), x), ac)) 
a = RotateLeft(a, s) 
a = AddUnsigned(a, 
End Sub 

Private Sub md5_II(a, b, c, d, x, s, ac) 
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), x), ac)) 
a = RotateLeft(a, s) 
a = AddUnsigned(a, 
End Sub 

Private Function ConvertToWordArray(sMessage) 
Dim lMessageLength 
Dim lNumberOfWords 
Dim lWordArray() 
Dim lBytePosition 
Dim lByteCount 
Dim lWordCount 

Const MODULUS_BITS = 512 
Const CONGRUENT_BITS = 448 

lMessageLength = Len(sMessage) 

lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) \ BITS_TO_A_BYTE)) \ (MODULUS_BITS \ BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS \ BITS_TO_A_WORD) 
ReDim lWordArray(lNumberOfWords - 1) 

lBytePosition = 0 
lByteCount = 0 
Do Until lByteCount >= lMessageLength 
lWordCount = lByteCount \ BYTES_TO_A_WORD 
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE 
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition) 
lByteCount = lByteCount + 1 
Loop 

lWordCount = lByteCount \ BYTES_TO_A_WORD 
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE 

lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition) 

lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3) 
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29) 

ConvertToWordArray = lWordArray 
End Function 

Private Function WordToHex(lValue) 
Dim lByte 
Dim lCount 

For lCount = 0 To 3 
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1) 
WordToHex = WordToHex & Right("0" & Hex(lByte), 2) 
Next 
End Function 
MD5不可逆加密算法的ASP实现实例(一) 
-------------------------------------- 

Public Function MD5(sMessage) 
m_lOnBits(0) = CLng(1) 
m_lOnBits(1) = CLng(3) 
m_lOnBits(2) = CLng(7) 
m_lOnBits(3) = CLng(15) 
m_lOnBits(4) = CLng(31) 
m_lOnBits(5) = CLng(63) 
m_lOnBits(6) = CLng(127) 
m_lOnBits(7) = CLng(255) 
m_lOnBits(8) = CLng(511) 
m_lOnBits(9) = CLng(1023) 
m_lOnBits(10) = CLng(2047) 
m_lOnBits(11) = CLng(4095) 
m_lOnBits(12) = CLng(8191) 
m_lOnBits(13) = CLng(16383) 
m_lOnBits(14) = CLng(32767) 
m_lOnBits(15) = CLng(65535) 
m_lOnBits(16) = CLng(131071) 
m_lOnBits(17) = CLng(262143) 
m_lOnBits(18) = CLng(524287) 
m_lOnBits(19) = CLng(1048575) 
m_lOnBits(20) = CLng(2097151) 
m_lOnBits(21) = CLng(4194303) 
m_lOnBits(22) = CLng(8388607) 
m_lOnBits(23) = CLng(16777215) 
m_lOnBits(24) = CLng(33554431) 
m_lOnBits(25) = CLng(67108863) 
m_lOnBits(26) = CLng(134217727) 
m_lOnBits(27) = CLng(268435455) 
m_lOnBits(28) = CLng(536870911) 
m_lOnBits(29) = CLng(1073741823) 
m_lOnBits(30) = CLng(2147483647) 

m_l2Power(0) = CLng(1) 
m_l2Power(1) = CLng(2) 
m_l2Power(2) = CLng(4) 
m_l2Power(3) = CLng(8) 
m_l2Power(4) = CLng(16) 
m_l2Power(5) = CLng(32) 
m_l2Power(6) = CLng(64) 
m_l2Power(7) = CLng(128) 
m_l2Power(8) = CLng(256) 
m_l2Power(9) = CLng(512) 
m_l2Power(10) = CLng(1024) 
m_l2Power(11) = CLng(2048) 
m_l2Power(12) = CLng(4096) 
m_l2Power(13) = CLng(8192) 
m_l2Power(14) = CLng(16384) 
m_l2Power(15) = CLng(32768) 
m_l2Power(16) = CLng(65536) 
m_l2Power(17) = CLng(131072) 
m_l2Power(18) = CLng(262144) 
m_l2Power(19) = CLng(524288) 
m_l2Power(20) = CLng(1048576) 
m_l2Power(21) = CLng(2097152) 
m_l2Power(22) = CLng(4194304) 
m_l2Power(23) = CLng(8388608) 
m_l2Power(24) = CLng(16777216) 
m_l2Power(25) = CLng(33554432) 
m_l2Power(26) = CLng(67108864) 
m_l2Power(27) = CLng(134217728) 
m_l2Power(28) = CLng(268435456) 
m_l2Power(29) = CLng(536870912) 
m_l2Power(30) = CLng(1073741824) 


Dim x 
Dim k 
Dim AA 
Dim BB 
Dim CC 
Dim DD 
Dim a 
Dim b 
Dim c 
Dim d 

Const S11 = 7 
Const S12 = 12 
Const S13 = 17 
Const S14 = 22 
Const S21 = 5 
Const S22 = 9 
Const S23 = 14 
Const S24 = 20 
Const S31 = 4 
Const S32 = 11 
Const S33 = 16 
Const S34 = 23 
Const S41 = 6 
Const S42 = 10 
Const S43 = 15 
Const S44 = 21 

x = ConvertToWordArray(sMessage) 

a = &H67452301 
b = &HEFCDAB89 
c = &H98BADCFE 
d = &H10325476 

F

相关文章

最新评论