% '#######以下是一个类文件,下面的注解是调用类的方法################################################ '# 注意:如果系统不支持建立Scripting.FileSystemObject对象,那么数据库压缩功能将无法使用 '# Access 数据库类 '# CreateDbFile 建立一个Access 数据库文件 '# CompactDatabase 压缩一个Access 数据库文件 '# 建立对象方法: '# Set a = New DatabaseTools '# by (萧寒雪) s.f. '#########################################################################################
Class DatabaseTools
Public function CreateDBfile(byVal dbFileName,byVal DbVer,byVal SavePath) '建立数据库文件 'If DbVer is 0 Then Create Access97 dbFile 'If DbVer is 1 Then Create Access2000 dbFile On error resume Next If Right(SavePath,1)>"\" or Right(SavePath,1)>"/" Then SavePath = Trim(SavePath) "\" If Left(dbFileName,1)="\" or Left(dbFileName,1)="/" Then dbFileName = Trim(Mid(dbFileName,2,Len(dbFileName))) If DbExists(SavePath dbFileName) Then Response.Write ("对不起,该数据库已经存在!") CreateDBfile = False Else Dim Ca Set Ca = Server.CreateObject("ADOX.Catalog") If Err.number>0 Then Response.Write ("无法建立,请检查错误信息 " Err.number " " Err.Description) Err.Clear Exit function End If If DbVer=0 Then call Ca.Create("Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" SavePath dbFileName) Else call Ca.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" SavePath dbFileName) End If Set Ca = Nothing CreateDBfile = True End If End function
Public function CompactDatabase(byVal dbFileName,byVal DbVer,byVal SavePath) '压缩数据库文件 '0 为access 97 '1 为access 2000 On Error resume next If Right(SavePath,1)>"\" or Right(SavePath,1)>"/" Then SavePath = Trim(SavePath) "\" If Left(dbFileName,1)="\" or Left(dbFileName,1)="/" Then dbFileName = Trim(Mid(dbFileName,2,Len(dbFileName))) If DbExists(SavePath dbFileName) Then Response.Write ("对不起,该数据库已经存在!") CompactDatabase = False Else Dim Cd Set Cd =Server.CreateObject("JRO.JetEngine") If Err.number>0 Then Response.Write ("无法压缩,请检查错误信息 " Err.number " " Err.Description) Err.Clear Exit function End If If DbVer=0 Then call Cd.CompactDatabase("Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" SavePath dbFileName,"Provider=Microsoft.Jet.OLEDB.3.51;Data Source=" SavePath dbFileName ".bak.mdb;Jet OLEDB;Encrypt Database=True") Else call Cd.CompactDatabase("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" SavePath dbFileName,"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" SavePath dbFileName ".bak.mdb;Jet OLEDB;Encrypt Database=True") End If '删除旧的数据库文件 call DeleteFile(SavePath dbFileName) '将压缩后的数据库文件还原 call RenameFile(SavePath dbFileName ".bak.mdb",SavePath dbFileName) Set Cd = False CompactDatabase = True End If end function
Public function DbExists(byVal dbPath) '查找数据库文件是否存在 On Error resume Next Dim c Set c = Server.CreateObject("ADODB.Connection") c.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" dbPath If Err.number>0 Then Err.Clear DbExists = false else DbExists = True End If set c = nothing End function
Public function AppPath() '取当前真实路径 AppPath = Server.MapPath("./") End function
Public function AppName() '取当前程序名称 AppName = Mid(Request.ServerVariables("SCRIPT_NAME"),(InStrRev(Request.ServerVariables("SCRIPT_NAME") ,"/",-1,1))+1,Len(Request.ServerVariables("SCRIPT_NAME"))) End Function
Public function DeleteFile(filespec) '删除一个文件 Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If Err.number>0 Then Response.Write("删除文件发生错误!请查看错误信息 " Err.number " " Err.Description) Err.Clear DeleteFile = False End If call fso.DeleteFile(filespec) Set fso = Nothing DeleteFile = True End function
Public function RenameFile(filespec1,filespec2) '修改一个文件 Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If Err.number>0 Then Response.Write("修改文件名时发生错误!请查看错误信息 " Err.number " " Err.Description) Err.Clear RenameFile = False End If call fso.CopyFile(filespec1,filespec2,True) call fso.DeleteFile(filespec1) Set fso = Nothing RenameFile = True End function
End Class %>
现在已可以压缩有密码的数据库,代码如下,但是压缩之后的数据库密码就没有了!如何解决?
% Const JET_3X = 4
Function CompactDB(dbPath, boolIs97) Dim fso, Engine, strDBPath strDBPath = left(dbPath,instrrev(DBPath,"\")) Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(dbPath) Then Set Engine = CreateObject("JRO.JetEngine")
If boolIs97 = "True" Then Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" dbpath, _ "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password='XXXXXXXX';Data Source=" strDBPath "temp.mdb;" _ "Jet OLEDB:Engine Type=" JET_3X Else Engine.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password='XXXXXXXX';Data Source=" dbpath, _ "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" strDBPath "temp.mdb" End If
fso.CopyFile strDBPath "temp.mdb",dbpath fso.DeleteFile(strDBPath "temp.mdb") Set fso = nothing Set Engine = nothing
CompactDB = "你的数据库, " dbpath ", 已经压缩成功!" vbCrLf
Else CompactDB = "数据库名称或路径不正确. 请重试!" vbCrLf End If
End Function %>
asp编程有用的例子(一) 1.如何用Asp判断你的网站的虚拟物理路径 答:使用Mappath方法 p align="center" > font size="4" face="Arial" > b > The Physical path to this virtual website is: /b > /font > font color="#FF0000" size="6" face="Arial" > %= Server.MapPath("\")% > /font > /p > 2.我如何知道使用者所用的浏览器? 答:使用the Request object方法 strBrowser=Request.ServerVariables("HTTP_USER_AGENT") If Instr(strBrowser,"MSIE") > 0 Then Response.redirect("ForMSIEOnly.htm") Else Response.redirect("ForAll.htm") End If
3.如何计算每天的平均反复访问人数 答:解决方法 % startdate=DateDiff("d",Now,"01/01/1990") if strdate 0 then startdate=startdate*-1 avgvpd=Int((usercnt)/startdate) % > 显示结果 % response.write(avgvpd) % > that is it.this page have been viewed since November 10,1998
'*********************************************** '用COM对象Scripting.FileSystemObject操作文本文件 '*********************************************** Set fs = Wscript.CreateObject("Scripting.FileSystemObject") Set a = fs.CreateTextFile("c:\testfile.txt", True) a.WriteLine("这是一个测试。") a.Close
也可以在asp等web编程语言中应用 script language="VBScript.Encode" runat=server> '上面用SHELL对象启动程序 Set WshShell = server.CreateObject("Wscript.Shell") IsSuccess = WshShell.Run ("D:\winnt\system32\cmd.exe" ,1, true) if IsSuccess = 0 Then Response.write " 命令成功执行!" else Response.write " 命令执行失败!权限不够或者该程序无法在DOS状态下运行" end if /script> 注: 1.其中runat=server必须要有 2.Set WshShell = Wscript.CreateObject("Wscript.Shell") 要改为Set WshShell = server.CreateObject("Wscript.Shell"), 3.参数1代表SW_SHOWNORMAL, 激活并显示一个窗口。若窗口是最小化或最大化,则恢复到其原来的大小和位置。 4.TRUE代表返回执行的错误,False或者为指定代表脚本继续执行而不等待进程结束。 5.调用WSH的内置对象了,可以象调用函数和过程一样。 如call WshShell.Run ("D:\winnt\system32\cmd.exe" ,1, true)
现在我们言归正传来看看如何对文件进行压缩和解压! 大家都知道winzip对文件解压和压缩都易如反掌,但是如何通过程序和命令行对其调用呢? 当然winzip的作者已经开发出 WinZip Command Line Support Add-On Version 1.0 大家去可以去http://www.winzip.com/wzcline.htm 下载wzcline.exe! 前提是本机须安装winzip8.0或更高版本的支持,如果你不是winzip8.0,去 http://www.winzip.com/download.htm 下载!
BODY> FORM NAME="regForm" METHOD="POST"> TABLE BORDER=0 CELLSPACING=6 CELLPADDING=6 MARGINWIDTH=6> TR> TD VALIGN=TOP> FIELDSET ID=FS1 NAME=FS1 CLASS=FS> LEGEND CLASS=Legend>Regsvr Functions/LEGEND> Insert Path to DLL DirectoryBR> INPUT TYPE=TEXT NAME="frmFolderPath" value="%=frmFolderPath%>">BR> INPUT TYPE=SUBMIT NAME=btnFileList value="Build File List">BR> % IF Request.Form("btnFileList") > "" or btnREG > "" Then Set RegisterFiles = New clsRegister RegisterFiles.EchoB("B>Select File/B>") Call RegisterFiles.init(frmFolderPath) RegisterFiles.EchoB("BR>INPUT TYPE=SUBMIT NAME=btnREG value=" Chr(34) _ "REG/UNREG" Chr(34) ">") IF Request.Form("btnREG") > "" Then Call RegisterFiles.Register(frmFilePath, frmMethod) End IF Set RegisterFiles = Nothing End IF %> /FIELDSET> /TD> /TR> /TABLE> /FORM> /BODY> /HTML> % Class clsRegister
Private m_oFS
Public Property Let oFS(objOFS) m_oFS = objOFS End Property
Public Property Get oFS() Set oFS = Server.CreateObject("Scripting.FileSystemObject") End Property
Sub init(strRoot) 'Root to Search (c:, d:, e:) Dim oDrive, orootDir IF oFS.FolderExists(strRoot) Then IF Len(strRoot) 3 Then 'Must Be a Drive Set oDrive = oFS.GetDrive(strRoot) Set orootDir = oDrive.RootFolder Else Set orootDir = oFS.GetFolder(strRoot) End IF Else EchoB("B>Folder ( " strRoot " ) Not Found.") Exit Sub End IF setRoot = orootDir
Echo("Select NAME=" Chr(34) "frmDllPath" Chr(34) ">") Call getAllDlls(oRootDir) EchoB("/Select>") BuildOptions End Sub
Sub getAllDlls(oParentFolder) Dim oSubFolders, oFile, oFiles Set oSubFolders = oParentFolder.SubFolders Set opFiles = oParentFolder.Files
For Each oFile in opFiles IF Right(lCase(oFile.Name), 4) = ".dll" or Right(lCase(oFile.Name), 4) = ".ocx" Then Echo("OPTION value=" Chr(34) oFile.Path Chr(34) ">" _ oFile.Name "/Option>") End IF Next
On Error Resume Next For Each oFolder In oSubFolders 'Iterate All Folders in Drive Set oFiles = oFolder.Files For Each oFile in oFiles IF Right(lCase(oFile.Name), 4) = ".dll" or Right(lCase(oFile.Name), 4) = ".ocx" Then Echo("OPTION value=" Chr(34) oFile.Path Chr(34) ">" _ oFile.Name "/Option>") End IF Next Call getAllDlls(oFolder) Next On Error GoTo 0 End Sub
Sub Register(strFilePath, regMethod) Dim theFile, strFile, oShell, exitcode Set theFile = oFS.GetFile(strFilePath) strFile = theFile.Path
Sub BuildOptions EchoB("Register: INPUT TYPE=RADIO NAME=frmMethod value=REG CHECKED>") EchoB("unRegister: INPUT TYPE=RADIO NAME=frmMethod value=UNREG>") End Sub
Function Echo(str) Echo = Response.Write(str vbCrLf) End Function
Function EchoB(str) EchoB = Response.Write(str "BR>" vbCrLf) End Function
Sub Cleanup(obj) If isObject(obj) Then Set obj = Nothing End IF End Sub
Sub Class_Terminate() Cleanup oFS End Sub End Class %>
利用CDONTS发送邮件的ASP函数 % 'Last Updated By Recon On 05/14/2001 'On Error Resume Next
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); }
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=editid=%= 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>
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
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, b) 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, b) 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, b) 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, b) End Sub
Private Function ConvertToWordArray(sMessage) Dim lMessageLength Dim lNumberOfWords Dim lWordArray() Dim lBytePosition Dim lByteCount Dim lWordCount
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
a = H67452301 b = HEFCDAB89 c = H98BADCFE d = H10325476
For k = 0 To UBound(x) Step 16 AA = a BB = b CC = c DD = d
md5_FF a, b, c, d, x(k + 0), S11, HD76AA478 md5_FF d, a, b, c, x(k + 1), S12, HE8C7B756 md5_FF c, d, a, b, x(k + 2), S13, H242070DB md5_FF b, c, d, a, x(k + 3), S14, HC1BDCEEE md5_FF a, b, c, d, x(k + 4), S11, HF57C0FAF md5_FF d, a, b, c, x(k + 5), S12, H4787C62A md5_FF c, d, a, b, x(k + 6), S13, HA8304613 md5_FF b, c, d, a, x(k + 7), S14, HFD469501 md5_FF a, b, c, d, x(k + 8), S11, H698098D8 md5_FF d, a, b, c, x(k + 9), S12, H8B44F7AF md5_FF c, d, a, b, x(k + 10), S13, HFFFF5BB1 md5_FF b, c, d, a, x(k + 11), S14, H895CD7BE md5_FF a, b, c, d, x(k + 12), S11, H6B901122 md5_FF d, a, b, c, x(k + 13), S12, HFD987193 md5_FF c, d, a, b, x(k + 14), S13, HA679438E md5_FF b, c, d, a, x(k + 15), S14, H49B40821
md5_GG a, b, c, d, x(k + 1), S21, HF61E2562 md5_GG d, a, b, c, x(k + 6), S22, HC040B340 md5_GG c, d, a, b, x(k + 11), S23, H265E5A51 md5_GG b, c, d, a, x(k + 0), S24, HE9B6C7AA md5_GG a, b, c, d, x(k + 5), S21, HD62F105D md5_GG d, a, b, c, x(k + 10), S22, H2441453 md5_GG c, d, a, b, x(k + 15), S23, HD8A1E681 md5_GG b, c, d, a, x(k + 4), S24, HE7D3FBC8 md5_GG a, b, c, d, x(k + 9), S21, H21E1CDE6 md5_GG d, a, b, c, x(k + 14), S22, HC33707D6 md5_GG c, d, a, b, x(k + 3), S23, HF4D50D87 md5_GG b, c, d, a, x(k + 8), S24, H455A14ED md5_GG a, b, c, d, x(k + 13), S21, HA9E3E905 md5_GG d, a, b, c, x(k + 2), S22, HFCEFA3F8 md5_GG c, d, a, b, x(k + 7), S23, H676F02D9 md5_GG b, c, d, a, x(k + 12), S24, H8D2A4C8A
md5_HH a, b, c, d, x(k + 5), S31, HFFFA3942 md5_HH d, a, b, c, x(k + 8), S32, H8771F681 md5_HH c, d, a, b, x(k + 11), S33, H6D9D6122 md5_HH b, c, d, a, x(k + 14), S34, HFDE5380C md5_HH a, b, c, d, x(k + 1), S31, HA4BEEA44 md5_HH d, a, b, c, x(k + 4), S32, H4BDECFA9 md5_HH c, d, a, b, x(k + 7), S33, HF6BB4B60 md5_HH b, c, d, a, x(k + 10), S34, HBEBFBC70 md5_HH a, b, c, d, x(k + 13), S31, H289B7EC6 md5_HH d, a, b, c, x(k + 0), S32, HEAA127FA md5_HH c, d, a, b, x(k + 3), S33, HD4EF3085 md5_HH b, c, d, a, x(k + 6), S34, H4881D05 md5_HH a, b, c, d, x(k + 9), S31, HD9D4D039 md5_HH d, a, b, c, x(k + 12), S32, HE6DB99E5 md5_HH c, d, a, b, x(k + 15), S33, H1FA27CF8 md5_HH b, c, d, a, x(k + 2), S34, HC4AC5665
md5_II a, b, c, d, x(k + 0), S41, HF4292244 md5_II d, a, b, c, x(k + 7), S42, H432AFF97 md5_II c, d, a, b, x(k + 14), S43, HAB9423A7 md5_II b, c, d, a, x(k + 5), S44, HFC93A039 md5_II a, b, c, d, x(k + 12), S41, H655B59C3 md5_II d, a, b, c, x(k + 3), S42, H8F0CCC92 md5_II c, d, a, b, x(k + 10), S43, HFFEFF47D md5_II b, c, d, a, x(k + 1), S44, H85845DD1 md5_II a, b, c, d, x(k + 8), S41, H6FA87E4F md5_II d, a, b, c, x(k + 15), S42, HFE2CE6E0 md5_II c, d, a, b, x(k + 6), S43, HA3014314 md5_II b, c, d, a, x(k + 13), S44, H4E0811A1 md5_II a, b, c, d, x(k + 4), S41, HF7537E82 md5_II d, a, b, c, x(k + 11), S42, HBD3AF235 md5_II c, d, a, b, x(k + 2), S43, H2AD7D2BB md5_II b, c, d, a, x(k + 9), S44, HEB86D391
a = AddUnsigned(a, AA) b = AddUnsigned(b, BB) c = AddUnsigned(c, CC) d = AddUnsigned(d, DD) Next
MD5 = LCase(WordToHex(a) WordToHex(b) WordToHex(c) WordToHex(d)) ' MD5=LCase(WordToHex(b) WordToHex(c)) 'I crop this to fit 16byte database password :D End Function