发一个自己封装的Asp Dll文件

调试程序和做程序的时候，好多重复的代码一直输入很麻烦，也很没有效率，封装一个自己的Asp包包，挺有有的

下载个精简版的VB6.0，新建 ActiveX dll，以下是封装的代码，重要部分都有注释，不懂可以跟帖

Option Explicit
Public Resp As Response, Requ As Request, Appl As Application, Serv As Server, Sess As Session   '内置对象的变量声明
Public ObjConn As Object, StrSql As String, ObjRs As Object, ObjFso As Object '全局级变量
'=============================Md5部分声明=============================
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), m_l2Power(30)    '数组声明
'=====================================================================
Public Sub OnStartPage(MyObj As ScriptingContext)
Set Resp = MyObj.Response
Set Requ = MyObj.Request
Set Serv = MyObj.Server
Set Appl = MyObj.Application
Set Sess = MyObj.Session
Sess.Timeout = 30
End Sub
Public Sub OnEndPage()
Set Resp = Nothing
Set Requ = Nothing
Set Serv = Nothing
Set Appl = Nothing
Set Sess = Nothing
End Sub
'----------------------------------------------------------------------------------
'----------------------------------------------------------------------------------
'----------                  函数表 方法 与外来参数传递                 -----------
'----------------------------------------------------------------------------------
'----------------------------------------------------------------------------------
'W         方法        入口值：StrWords As String           返回值：直接输出
'R         方法        入口值：StrUrl As String             返回值：直接跳转
'E         方法        入口值：空                           返回值：空
'UserLevel 方法        入口值：IntQx As Integer             返回值：字符串
'SoErr     方法        入口值：StrErrMsg As String          返回值：直接输出
'.ZHtml("R","Html/Index.Html")  '本地读取
'.ZHtml("C","Html/Index.Html","StrText")  '本地创建
'.ZHtml("W","Http://127.0.0.1/Index.Html")  '远程读取
'.ZHtml("J","Http://127.0.0.1/Index.Jpg","Jpg/Test.Jpg")  '远程存储Jpg到本地
'.ZHtml("M","Model.Html","Html/Test.Html",GZ())   '模板生成文件
'.ZXml("C","StrText")   '本地创建Xml
'.ZXml("W","Http://127.0.0.1/Index.Xml")   '远程读取Xml
'.ZLogin("C")   'CkLogin
'.ZLogin("O")   'OTLogin
'.ZLogin("I")   'IsLogin
'.ZLogin("A")   'IsAdmin
'.Zmd5("StrText","[16/32]")  'md5加密
'.MyConn("ConnStr")
'.ClConn
'.CoRS  'Server.CreateObject("ADODB.Recordset")
'.CoFs  'Server.CreateObject("Scripting.FileSystemObject")
'.SoErr("StrErrorText")
'.IsFExit("File/Test.Html")  '检测文件是否存在
'.ZSp("StrFileName","IntCurrentPage","IntTotalPages","IntMaxPerPage")  '分页显示
'----------------------------------------------------------------------------------
'----------------------------------------------------------------------------------
'----------------------------------------------------------------------------------
Public Function W(ByVal StrWords As String) As Object  '封装自己的 Response.write
Resp.Write ("<br>" & StrWords)
End Function
Public Function R(ByVal StrUrl As String)  '封装自己的 Response.Redirect
Resp.Redirect StrUrl
End Function
Public Function E()   '封装自己的 Response.end
Resp.End
End Function
Public Function F()  '封装自己的 Response.Flush
Resp.Flush
End Function
Public Function C()  '封装自己的 Response.Clear
Resp.Clear
End Function
Public Function CoRs()  '封装自己的  Server.CreateObject("ADODB.Recordset")
Set CoRs = Serv.CreateObject("ADODB.Recordset")
End Function
Public Function CoFs()  '封装自己的  Server.CreateObject("Scripting.FileSystemObject")
Set CoFs = Serv.CreateObject("Scripting.FileSystemObject")
End Function
Public Function MyConn(ByVal StrConn As String)    '封装自己的Conn
On Error GoTo CuoWu
Dim StrSql As String, ObjRs
Set ObjFso = CoFs
        StrConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Serv.MapPath(StrConn)
        Set ObjConn = Serv.CreateObject("ADODB.Connection")
        ObjConn.Open StrConn
        Set MyConn = ObjConn
Set ObjFso = Nothing
Exit Function
CuoWu:
SoErr (Err.Description & "<br>" & "错误参数：" & Sess("ConnStr"))
End Function
Public Function ClConn()
ObjConn.Close
Set ObjConn = Nothing
End Function
'                             C O I A
Public Function ZLogin(ByVal StrAction As String)
Dim StrUserName As String, StrPassWord As String, StrChekCode As String
Dim StrErrMsg As String, BlnFoundErr As Boolean
Dim ComeUrl, cUrl, UserName
Set ObjRs = CoRs
    Select Case UCase(StrAction)
        Case "C"  'ChkLogin
                StrUserName = Replace(Trim(Requ.Form("UserName")), "'", "")
                StrPassWord = Replace(Trim(Requ.Form("PassWord")), "'", "")
                StrChekCode = Replace(Trim(Requ.Form("CheckCode")), "'", "")
                If StrUserName = "" Then
                    BlnFoundErr = True
                    StrErrMsg = StrErrMsg & "<br><li>用户名不能为空！</li>"
                End If
                If StrPassWord = "" Then
                    BlnFoundErr = True
                    StrErrMsg = StrErrMsg & "<br><li>密码不能为空！</li>"
                End If
                If StrChekCode = "" Then
                    BlnFoundErr = True
                    StrErrMsg = StrErrMsg & "<br><li>验证码不能为空！</li>"
                End If
                If StrChekCode <> Sess("ZzCode") Then
                    BlnFoundErr = True
                    StrErrMsg = StrErrMsg & "<br><li>您输入的确认码和系统产生的不一致，请重新输入。</li>"
                End If
                If BlnFoundErr <> True Then
                    StrPassWord = Zmd5(StrPassWord, "32")
                        StrSql = "Select * From Admin where Password='" & StrPassWord & "' And UserName='" & StrUserName & "'"
                            ObjRs.Open StrSql, ObjConn, 1, 3
                                If ObjRs.bof() Or ObjRs.EOF() Then
                                    StrErrMsg = StrErrMsg & "<br><li>用户名或密码错误！！！</li>"
                                    SoErr (StrErrMsg)
                                Else
                                    If StrPassWord <> ObjRs("password") Then
                                        StrErrMsg = StrErrMsg & "<br><li>用户名或密码错误！！！</li>"
                                        SoErr (StrErrMsg)
                                    Else
                                        ObjRs("LastLoginIP") = Requ.ServerVariables("REMOTE_ADDR")
                                        ObjRs("LastLoginTime") = Now()
                                        ObjRs("IsOnLine") = True
                                        ObjRs("LoginTimes") = ObjRs("LoginTimes") + 1
                                        Sess("UserType") = UserLevel(ObjRs("UserLevel"))
                                        Sess("UserName") = StrUserName
                                        ObjRs.Update
                                        ObjRs.Close
                                        R "Default.asp"
                                    End If
                                End If
                Else
                    SoErr (StrErrMsg)
                End If
        Case "O"  'OutLogin
                StrSql = "Select * From Admin where UserName='" & Sess("UserName") & "'"
                ObjRs.Open StrSql, ObjConn, 1, 3
                ObjRs("LastLogOutTime") = Now()
                ObjRs("IsOnLine") = False
                Set ObjRs = Nothing
                Sess("UserName") = ""
                Sess("UserType") = ""
                R "Login.asp"
                ObjRs.Update
                ObjRs.Close
        Case "I"  'IsLogLin
                Set ObjRs = CoRs
                StrSql = "Select * From Admin where UserName='" & Sess("UserName") & "' And IsOnLine=True"
                ObjRs.Open StrSql, ObjConn, 1, 1
                If ObjRs.EOF() Or ObjRs.bof() Then
                    R "Login.Asp"
                    ObjRs.Close
                End If
        Case "A"  'Is Admin
                ComeUrl = LCase(Trim(Requ.ServerVariables("HTTP_REFERER")))
                    If ComeUrl = "" Then
                        SoErr "<br><p align=center><font color='red'>对不起，为了系统安全，不允许直接输入地址访问本系统的后台管理页面。</font></p>"
                    Else
                        cUrl = Trim("http://" & Requ.ServerVariables("SERVER_NAME"))
                            If Mid(ComeUrl, Len(cUrl) + 1, 1) = ":" Then
                                cUrl = cUrl & ":" & Requ.ServerVariables("SERVER_PORT")
                            End If
                        cUrl = LCase(cUrl & Requ.ServerVariables("SCRIPT_NAME"))
                                If LCase(Left(ComeUrl, InStrRev(ComeUrl, "/"))) <> LCase(Left(cUrl, InStrRev(cUrl, "/"))) Then
                                    SoErr "<br><p align=center><font color='red'>对不起，为了系统安全，不允许从外部链接地址访问本系统的后台管理页面。</font></p>"
                                End If
                    End If
        Case Else
                SoErr ("调用方式或参数错误！<br>错误参数：" & StrAction)
        End Select
Set ObjRs = Nothing
End Function
'                         R C W J M
'                       要执行的操作                   执行对象                       被写入对象                      数组规则
Public Function ZHtml(ByVal StrAction As String, ByVal StrUrl As String, Optional ByVal StrWText As String, Optional ArryGZ)
Dim ObjStream, ObjXmlHttp, IntC As Integer, StrDtmp As String, AryPh
On Error GoTo ZzErrOr  '容错处理
Dim ObjR As Object, StrTmp As String, IntA As Integer, IntB As Integer, StrTmp1 As String, StrTmp2 As String
Set ObjFso = CoFs
Set ObjR = CoFs
    Select Case UCase(StrAction)
        Case "R"  '本地方式读入一个Html  返回网页源代码
            Set ObjR = ObjFso.OpenTextFile(Serv.MapPath(StrUrl))
            ZHtml = ObjR.ReadAll   '返回读取的文件内容
            ObjR.Close
        Case "W" 'Web方式读入一个Html  返回网页源代码
            Set ObjXmlHttp = Serv.CreateObject("MsXml2.ServerXmlHttp")
            ObjXmlHttp.Open "GET", StrUrl, False
            ObjXmlHttp.Send
            While ObjXmlHttp.ReadyState <> 4
                ObjXmlHttp.WaitForResponse 1000
            Wend
                Set ObjStream = Serv.CreateObject("Adodb.Stream")
                    With ObjStream
                        .Type = 1
                        .Mode = 3
                        .Open
                        .Write ObjXmlHttp.ResponseBody
                        .Position = 0
                        .Type = 2
                        .Charset = "GB2312"
                ZHtml = .ReadText   '返回请求的网页原代码
                        .Close
                    End With
                Set ObjStream = Nothing
                Set ObjXmlHttp = Nothing
        Case "J" '获取一个Jpg图片  返回保存地址
            Set ObjXmlHttp = Serv.CreateObject("MsXml2.ServerXmlHttp")
                ObjXmlHttp.Open "GET", StrUrl, False
                ObjXmlHttp.Send
                    While ObjXmlHttp.ReadyState <> 4
                        ObjXmlHttp.WaitForResponse 1000
                    Wend
                Set ObjStream = Serv.CreateObject("Adodb.Stream")
                    With ObjStream
                    .Type = 1
                    .Open
                    .Write ObjXmlHttp.ResponseBody
                    .SaveToFile Serv.MapPath(StrWText), 2
                    .Cancel
                    .Close
                    End With
                Set ObjStream = Nothing
                Set ObjXmlHttp = Nothing
                ZHtml = StrWText ' 返回生成的图片地址
        Case "C"  '本地创建一个Html
            AryPh = Split(StrUrl, "/")  '容错处理，如果发现文件夹不存在，则创建
                For IntC = 0 To UBound(AryPh) - 1
                    If StrDtmp = "" Then
                        StrDtmp = AryPh(IntC)
                    Else
                        StrDtmp = StrDtmp & "/" & AryPh(IntC)
                    End If
                        If Not IsDExit(StrDtmp) Then ZCF (StrDtmp)
                Next
                    Set ObjFso = CoFs
                    Set ObjR = CoFs
            Set ObjR = ObjFso.CreateTextFile(Serv.MapPath(StrUrl), True)
            ObjR.WriteLine (StrWText)
            ObjR.Close
            ZHtml = StrUrl '返回创建的html文件地址

        Case "M"  '根据模板生成Html
            Set ObjR = ObjFso.OpenTextFile(Serv.MapPath(StrUrl))
            StrTmp = ObjR.ReadAll
            ObjR.Close
                For IntA = LBound(ArryGZ, 1) To UBound(ArryGZ, 1)
                    For IntB = LBound(ArryGZ, 2) To UBound(ArryGZ, 2) - 1
                        StrTmp1 = ArryGZ(IntA, IntB)
                        StrTmp2 = ArryGZ(IntA, IntB + 1)
                        StrTmp = Replace(StrTmp, StrTmp1, StrTmp2)
                    Next
                Next
            Set ObjR = ObjFso.CreateTextFile(Serv.MapPath(StrWText), True)
            ObjR.WriteLine (StrTmp)
            ObjR.Close
            ZHtml = StrWText '返回生成的Url 地址
        Case Else
            SoErr ("调用方式或参数错误！<br>错误参数：" & StrAction & "<br>错误的Url：" & StrUrl)
    End Select
Set ObjR = Nothing
Set ObjFso = Nothing
Exit Function
ZzErrOr:
SoErr (Err.Description & "<br>" & "出错参数：" & StrUrl)
End Function
Public Function ZXml(ByVal StrAction As String, ByVal StrUrl As String, Optional ByVal StrWText As String)
Dim StrW As String, ObjStream, XmlHttp, XmlDom, Xml, IntC As Integer, AryPh, StrDtmp As String
On Error GoTo ZzErrOr  '容错处理
    Select Case UCase(StrAction)
        Case "C"  '本地创建一个Xml
                    AryPh = Split(StrUrl, "/")  '容错处理，如果发现文件夹不存在，则创建
                For IntC = 0 To UBound(AryPh) - 1
                    If StrDtmp = "" Then
                        StrDtmp = AryPh(IntC)
                    Else
                        StrDtmp = StrDtmp & "/" & AryPh(IntC)
                    End If
                        If Not IsDExit(StrDtmp) Then ZCF (StrDtmp)
                Next
            StrW = "<?xml version='1.0' encoding='UTF-8'?>" & vbCrLf
            StrW = StrW & "<Qyqrq Xmlns='CopyRight By 七月七日晴'>" & vbCrLf
            StrW = StrW & StrWText & vbCrLf
            StrW = StrW & "</Qyqrq>"
            Set ObjStream = Serv.CreateObject("ADODB.Stream")
                With ObjStream
                    .Open
                    .Charset = "UTF-8"
                    .Position = ObjStream.Size
                    .WriteText = StrW
                    .SaveToFile Serv.MapPath(StrUrl), 2
                    .Close
                End With
            Set ObjStream = Nothing
            ZXml = StrUrl '返回创建的地址
        Case "W"  '从远程获取一个Xml
            Set XmlHttp = Serv.CreateObject("MSXML2.XMLHTTP")
            XmlHttp.Open "Get", StrUrl, False
            XmlHttp.Send
            Xml = XmlHttp.ResponseBody
            Set XmlHttp = Nothing
            Set XmlDom = Serv.CreateObject("Microsoft.XMLDOM")
            XmlDom.Async = False
            XmlDom.ValidateOnParse = False
            XmlDom.Load (Xml)
            Set ZXml = XmlDom   '返回读取的内容
        Case Else
            SoErr ("调用方式或参数错误！<br>错误参数：" & StrAction & "<br>错误的Url：" & StrUrl)
        End Select
Exit Function
ZzErrOr:
SoErr (Err.Description & "<br>" & "出错参数：" & StrUrl)
End Function


Public Function SoErr(ByVal StrErrMsg As String)
Dim StrSw As String
StrSw = StrSw & "<html><head><meta http-equiv=""Content-Type"" content=""text/html; charset=gb2312""><style type=""text/css"">"
StrSw = StrSw & ".ZzButton1{BORDER-TOP-WIDTH: 0px;BORDER-LEFT-WIDTH: 0px;FONT-SIZE: 9pt;BACKGROUND-IMAGE: url(ZzImage/Button3.GIF);BORDER-BOTTOM-WIDTH: 0px;WIDTH: 68px;CURSOR: hand;COLOR: navy;BACKGROUND-REPEAT: no-repeat;HEIGHT: 23px;BACKGROUND-COLOR: white;BORDER-RIGHT-WIDTH: 0px;}"
StrSw = StrSw & ".text {    FONT-WEIGHT: normal; FONT-SIZE: 13px; COLOR: #000000; FONT-FAMILY: Verdana, Arial, Helvetica, sans-serif}"
StrSw = StrSw & ".BIGtext { FONT-WEIGHT: bolder; FONT-SIZE: 12px; COLOR: #000000; FONT-FAMILY: Verdana, Arial, Helvetica, sans-serif}"
StrSw = StrSw & "</style></head><body  topmargin=""0"" leftmargin=""0"" bgcolor=""#ffffff""><center><br>"
StrSw = StrSw & "<table width=""400"" border=""0"" align=""center"" cellpadding=""1"" cellspacing=""1"" bgcolor=""#666666"" class=text bordercolor=""#999999""><tr bgcolor=""#0066FF"" class=""TblField""><td height=""31"" bgcolor=""#669ACC"">"
StrSw = StrSw & "<div align=""center"" style=""color: #FFFFFF""> <b>错误信息</b> </div></td></tr>  <tr bgcolor=""#FFFFFF"">"
StrSw = StrSw & "<td height=""34"" bgcolor=""#FFFFFF"" class=""BIGtext""><div align=""Left""><br><b>产生错误的可能原因：</b></div>" & StrErrMsg & "</td>"
StrSw = StrSw & " </tr><tr bgcolor=""#FFFFFF"" class=""TblField""><td height=""40""><div align=""center""><font color=""#FF0000""><b><input type=""button"" name=""Submit222"" value=""返回"" CLASS=""ZzButton1"" οnclick=""javascript:history.go(-1)""></b></font></div></td></tr></table> </form></center> </BODY></HTML>"
W StrSw
E
End Function
Public Function UserLevel(ByVal IntQx As Integer)
        Select Case IntQx
            Case 64
                UserLevel = "Admin"
            Case 60
                UserLevel = "Super"
            Case 24
                UserLevel = "Power"
            Case 20
                UserLevel = "User"
            Case 10
                UserLevel = "Guest"
            End Select
End Function
Public Function IsFExit(ByVal StrFP As String)
Set ObjFso = CoFs
    If (ObjFso.FileExists(Serv.MapPath(StrFP))) Then
        IsFExit = True
    Else
        IsFExit = False
    End If
Set ObjFso = Nothing
End Function
Public Function IsDExit(ByVal StrDP As String)
Set ObjFso = CoFs
    If (ObjFso.FolderExists(Serv.MapPath(StrDP))) Then
        IsDExit = True
    Else
        IsDExit = False
    End If
Set ObjFso = Nothing
End Function
Public Function ZCF(ByVal StrDP As String)  '创建文件夹
On Error GoTo ZzErrOr  '容错处理
Dim ObjF As Object
Set ObjFso = CoFs
    Set ObjF = ObjFso.CreateFolder(Serv.MapPath(StrDP))
    ZCF = ObjF.Path
Set ObjF = Nothing
Set ObjFso = Nothing
Exit Function
ZzErrOr:
SoErr (Err.Description & "<br>" & "出错参数：" & StrDP)
End Function
'                   文件名                每页显示数                总数
Function ZSp(ByVal StrFN As String, ByVal IntMax As Integer, ByVal IntZ As Integer)
Dim n, i, StrTemp, IntCP As Integer

    IntCP = CInt(Requ.QueryString("page"))
        If IntCP = 0 Then
            IntCP = 1
            ZSp = 0
        Else
            IntCP = IntCP
            ZSp = (IntCP - 1) * IntMax
        End If
   
    If IntZ Mod IntMax = 0 Then
        n = IntZ / IntMax
    Else
        n = IntZ / IntMax + 1
    End If
    StrTemp = "<table align='center'><form name='showpages' method='Post' action='" & StrFN & "'><tr><td>"
    StrTemp = StrTemp & "共 <b>" & IntZ & "</b> 条记录   "
    StrFN = JoinChar(StrFN)
    If IntCP < 2 Then
            StrTemp = StrTemp & "首页 上一页 "
    Else
            StrTemp = StrTemp & "<a href='" & StrFN & "page=1'>首页</a> "
            StrTemp = StrTemp & "<a href='" & StrFN & "page=" & (IntCP - 1) & "'>上一页</a> "
    End If
    If n - IntCP < 1 Then
            StrTemp = StrTemp & "下一页 尾页"
    Else
            StrTemp = StrTemp & "<a href='" & StrFN & "page=" & (IntCP + 1) & "'>下一页</a> "
            StrTemp = StrTemp & "<a href='" & StrFN & "page=" & n & "'>尾页</a>"
    End If
    StrTemp = StrTemp & " 页次：<strong><font color=red>" & IntCP & "</font>/" & n & "</strong>页 "
    StrTemp = StrTemp & " <b>" & IntMax & "</b>" & "个文件/页"
    StrTemp = StrTemp & " 转到：<select name='page' size='1'>"
    For i = 1 To n
        StrTemp = StrTemp & "<option value='" & i & "'"
        If CInt(IntCP) = CInt(i) Then StrTemp = StrTemp & " selected "
        StrTemp = StrTemp & ">第" & i & "页</option>"
    Next
    StrTemp = StrTemp & "</select>"
    StrTemp = StrTemp & "</td></tr></form></table>"
    Resp.Write StrTemp
End Function
Function JoinChar(ByVal StrUrl As String)
    If StrUrl = "" Then
        JoinChar = ""
        Exit Function
    End If
    If InStr(StrUrl, "?") < Len(StrUrl) Then
        If InStr(StrUrl, "?") > 1 Then
            If InStr(StrUrl, "&") < Len(StrUrl) Then
                JoinChar = StrUrl & "&"
            Else
                JoinChar = StrUrl
            End If
        Else
            JoinChar = StrUrl & "?"
        End If
    Else
        JoinChar = StrUrl
    End If
End Function
Public Function Version()
Version = "Qyqrq Betea 1.001"
End Function
'-------------------------------------------------------------------
'----------                  修改MD5程序                 -----------
'----------           第一种 Zmd5(StrMsg,"16")          -----------
'----------           第二种 Zmd5(StrMsg,"32")          -----------
'-------------------------------------------------------------------

Public Function Zmd5(ByVal StrMsg As String, ByVal StrP As String)     '封装自己的md5函数
  Dim sMessage: sMessage = StrMsg
    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, k, AA, BB, CC, DD, A, B, C, 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
    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
   
    If StrP = "16" Then
       Zmd5 = LCase(WordToHex(B) & WordToHex(C))
    ElseIf StrP = "32" Then
       Zmd5 = LCase(WordToHex(A) & WordToHex(B) & WordToHex(C) & WordToHex(d))
    Else
       Zmd5 = sMessage
    End If
End Function
Private Function LShift(lValues, iShiftBitss)
  Dim lValue, iShiftBits: lValue = lValues: iShiftBits = iShiftBitss
    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(lValues, iShiftBitss)
  Dim lValue, iShiftBits: lValue = lValues: iShiftBits = iShiftBitss
    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(lValues, iShiftBitss)
  Dim lValue, iShiftBits: lValue = lValues: iShiftBits = iShiftBitss
  RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function
Private Function AddUnsigned(lXs, lYs)
  Dim lX4, lY4, lX8, lY8, lResult, lX, lY
  lX = lXs: lY = lYs
    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(StrMsg)
  Dim lMessageLength, lNumberOfWords, lWordArray(), lBytePosition, lByteCount, lWordCount, sMessage
  sMessage = StrMsg
   
    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, 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
'-------------------------------------------------------------------
'-------------------------------------------------------------------
'-------------------------------------------------------------------