CMS加密、解密

TSecurity.asp，加密、解密调用接口
<%
'/**
'* ASP Security
'*
'* @Author  : [BI]CJJ http://www.imcjj.com
'* @Version : 0.1.0 build 20070709
'*/
Class TSecurity
    Private cls_oObj, cls_oSecurity
    Private cls_sMsg, cls_sSecurity
    Public Key
    Private Sub Class_Initialize() cls_sSecurity=",MD5,SHA1,SHA256,AES,BlowFish,RSA," End Sub
    Private Sub Class_Terminate()  Set cls_oObj=Nothing  End Sub
    Private Function getInstance(ByVal a_sName)
        Server.Execute(gbl_sPath_SiteRoot & "library/class/security/T" & a_sName & ".asp")    
        Call Execute("Set getInstance = New T" & a_sName)
    End Function
 
    Public Sub genKey(a_sType, a_sKey)
        Select Case a_sType
        Case "1"
            Key=Date() & a_sKey
        Case Else
'           If TypeName(cls_oObj)<>"T" & a_sType Then Set cls_oObj=getInstance(a_sType) End If
'           If TypeName(cls_oObj)<>"T" & a_sType Then Exit Sub End If
'           Key=cls_oObj.genKey()
        End Select
    End Sub
    Public Function Encrypt(ByVal a_sName, ByVal a_sMsg, ByVal a_sKey)   
        Dim sResult, sType,sObjType,sName
        Dim aName : aName=Split(a_sName,":")
        Dim oObj
        Encrypt=null
        sName=aName(0)
        sObjType = "T" & sName
        sType="abcd"
        cls_sMsg="对不起，系统不支持 <strong>[" & sName & "]</strong>加密算法"
        If Instr(cls_sSecurity,"," & sName & ",")<1 Then Exit Function End If
        If UBound(aName)>0 Then sType=aName(1) End If
        If TypeName(cls_oObj)<>sObjType Then Set cls_oObj=getInstance(sName) End If
        If TypeName(cls_oObj)<>sObjType Then Exit Function End If
   
        Select Case sName
        Case "SHA1"
            sResult = cls_oObj.Encrypt(sType,a_sMsg)
            If not isNone(a_sKey) Then
                Call Execute(includeFile(gbl_sPath_SiteRoot & "library/class/security/THMAC.asp","",""))
                Set oObj = New THMAC
               
                 sResult = oObj.Encrypt(cls_oObj,a_sKey,sResult)
            End If
        Case "SHA256"
            sResult = cls_oObj.Encrypt(sType,a_sMsg)
            If not isNone(a_sKey) Then
                Call Execute(includeFile(gbl_sPath_SiteRoot & "library/class/security/THMAC.asp","",""))
                Set oObj = New THMAC
               
                 sResult = oObj.Encrypt(cls_oObj,a_sKey,sResult)
            End If
  
        Case "MD5"
            sResult = cls_oObj.Encrypt(sType,a_sMsg)
            If not isNone(a_sKey) Then
                Call Execute(includeFile(gbl_sPath_SiteRoot & "library/class/security/THMAC.asp","",""))
                Set oObj = New THMAC
               
                 sResult = oObj.Encrypt(cls_oObj,a_sKey,sResult)
            End If
         
        Case "BlowFish"
'            If cls_oObj.setKey(a_sKey) Then
'                sResult=cls_oObj.Encrypt(a_sMsg)
'            Else
'                cls_sMsg="密钥设置失败"
'                Exit Function
'            End If
        Case "AES"
            sResult = cls_oObj.Encrypt(a_sMsg,a_sKey)
        Case "RSA"
            If isNone(a_sKey) Then a_sKey=cls_oObj.genKey() End If
            Key=a_sKey
            sResult = cls_oObj.Encrypt(a_sMsg)
        End Select
        cls_sMsg=""
        Encrypt = sResult
    End Function
    Public Function Decrypt(ByVal a_sName, ByVal a_sMsg, ByVal a_sKey)
        Dim sResult, sName, sType, sObjType
        Dim aName : aName=Split(a_sName,":")
        Decrypt=null
        sName=aName(0)
        sObjType = "T" & sName
        sType="abcd"
        cls_sMsg="对不起，系统不支持 <strong>[" & sName & "]</strong>加密算法"
        cls_sMsg="对不起，系统不支持<strong>[" & a_sName & "]</strong> 解密方法"
        If Instr(cls_sSecurity,"," & sName & ",")<1 Then Exit Function End If
        If TypeName(cls_oObj)<>sObjType Then Call getInstance(a_sName) End If
        If TypeName(cls_oObj)<>sObjType Then Exit Function End If
        Select Case a_sName
        Case "BlowFish"
'            If cls_oObj.setKey(a_sKey) Then
'                sResult=cls_oObj.Decrypt(a_sMsg)
'            Else
'                Exit Function
'            End If
        Case "AES"
            sResult = cls_oObj.Decrypt(a_sMsg,a_sKey)
        Case "RSA"
            cls_sMsg="密钥不能为空，无法解密"
            If isNone(a_sKey) Then Exit Function End If
            cls_sMsg="密钥设置失败，无法解密"
            If Not cls_oObj.setKey(a_sKey) Then Exit Function End If
            sResult = cls_oObj.Decrypt(a_sMsg)
        Case Else
            Exit Function
        End Select
        cls_sMsg=""
        Decrypt = sResult
    End Function
    Public Property Get getMessage() getMessage=cls_sMsg End Property
End Class
%>

HMAC算法
THMAC.asp
<%
'/**
'* RFC 2104 HMAC implementation for asp
'*
'* @Author  : [BI]CJJ http://www.imcjj.com
'* @Version : 0.1.0 build 20070708
'*/
Class THMAC
  '  Private Sub Class_Initialize() End Sub
    private function SHL(lValue, iShiftBits)
        if iShiftBits = 0 then
            SHL = lValue
            Exit Function
        elseif iShiftBits = 31 then
            if lValue And 1 then
                SHL = &H80000000
            else
                SHL = 0
            end if
            Exit Function
        elseif iShiftBits < 0 Or iShiftBits > 31 then
            Err.Raise 6
        end if
        if (lValue And 2^(31 - iShiftBits)) then
            SHL = ((lValue And (2^(31 - iShiftBits)-1)) * (2^iShiftBits)) Or &H80000000
        else
            SHL = (lValue And (2^(32 - iShiftBits)-1)) * 2^iShiftBits
        end if
    end function
    private function SHR(lValue, iShiftBits)
        if iShiftBits = 0 then
            SHR = lValue
            Exit Function
        elseif iShiftBits = 31 then
            if lValue And &H80000000 then
                SHR = 1
            else
                SHR = 0
            end if
            Exit Function
        elseif iShiftBits < 0 Or iShiftBits > 31 then
            Err.Raise 6
        end if
        SHR = (lValue And &H7FFFFFFE) \ (2^iShiftBits)
        if (lValue And &H80000000) then
            iShiftBits=iShiftBits-1
            SHR = SHR Or (&H40000000 \ (2^iShiftBits ))
        end if
    end function
    Private Function bytarray2binl (barray)
        Dim nblk,blks(),i
  
        nblk = SHR(ubound(barray) + 9, 6) + 1
        ReDim blks((nblk * 16)-1)
        For i = 0 To UBound(blks)
            blks(i) = 0
        Next
        For i = 0 To UBound(barray)
            blks(SHR(i,2)) = blks(SHR(i,2)) OR (SHL(barray(i) AND &HFF, ((i mod 4)*8)))
        Next
        blks(SHR(i,2)) = blks(SHR(i,2)) OR (SHL(&H80, ((i mod 4)*8)))
        blks(nblk*16-2) = (ubound(barray)+1) * 8
        bytarray2binl = blks
    end function
    Private Function binl2byt(binarray)
        Dim hex_tab,bytarray(),i
        ReDim bytarray(((UBound(binarray)+1)*4)-1)
        For i = 0 To ((UBound(binarray) +1) * 4) -1
            bytarray(i) = SHL((SHR(binarray(SHR(i,2)),(((i mod 4)*8)+4)) AND &H0f) ,4) OR (SHR(binarray(SHR(i,2)),((i mod 4)*8)) AND &H0f)
        Next
        binl2byt = bytarray
    end function
    private Function binl2hex(binarray)
        Dim str,i
        For i = 0 to ((UBound(binarray) +1) * 4) -1
            str = str & LCase(hex(SHR(binarray(SHR(i,2)),((i mod 4)*8) + 4) AND &Hf)) & lcase(hex(SHR(binarray(SHR(i, 2)), ((i mod 4) * 8)) AND &Hf))
        Next
        binl2hex = str
    end function
    Public Function Encrypt(ByRef a_oObj, key, text)
        Dim ipad(63),opad(63),idata(),odata(79)
        ReDim idata(63 + len(text))
        Dim i, innerhashout, hkey
        Dim sName
        Encrypt=null
        sName=TypeName(a_oObj)
        If sName<>"TMD5" And sName<>"TSHA1" AND sName<>"TSHA256" Then Exit Function End If
        hkey = key
        if Len(key) > 64 then hkey = a_oObj.Encrypt(key) end if
        For i = 0 to 63
            ipad(i) = &H36
            idata(i) = &H36
            odata(i) = &H5C
            opad(i) = &H5C
        Next
        For i = 0 To len(hkey)-1
            ipad(i) = ipad(i) XOR asc(mid(hkey,i+1,1))
            opad(i) = opad(i) XOR asc(mid(hkey,i+1,1))
            idata(i) = ipad(i) AND &HFF
            odata(i) = opad(i) AND &HFF
        Next
        For i = 0 To Len(text) -1
            idata(64 + i) = asc(mid(text,i+1,1)) AND &HFF
        Next
        innerhashout = binl2byt(a_oObj.EncryptArray(bytarray2binl(idata)))
        For i = 0 To 15
            odata(64+i) = innerhashout(i)
        Next
 
        Encrypt = binl2hex(a_oObj.EncryptArray(bytarray2binl(odata)))
    end function
End Class
%>

SHA256算法
TSHA256.asp
<%
Class TSHA256
    Private m_lOnBits(30),m_l2Power(30)
    Private K(80)
    Private  BITS_TO_A_BYTE,BYTES_TO_A_WORD,BITS_TO_A_WORD
      '#######################HASH算法通用函数开始#################
      '左移
      Private Function SHL(lValue, iBits)
          If iBits = 0 Then
              SHL = lValue
              Exit Function
          ElseIf iBits = 31 Then
              If lValue And 1 Then
                  SHL = &H80000000
              Else
                  SHL = 0
              End If
              Exit Function
          ElseIf iBits < 0 Or iBits > 31 Then
              Err.Raise 6
          End If
   
          If (lValue And m_l2Power(31 - iBits)) Then
              SHL = ((lValue And m_lOnBits(31 - (iBits + 1))) * m_l2Power(iBits)) Or &H80000000
          Else
              SHL = ((lValue And m_lOnBits(31 - iBits)) * m_l2Power(iBits))
          End If
      End Function
      '右移
      Private Function SHR(lValue, iBits)
          If iBits = 0 Then
              SHR = lValue
              Exit Function
          ElseIf iBits = 31 Then
              If lValue And &H80000000 Then
                  SHR = 1
              Else
                  SHR = 0
              End If
              Exit Function
          ElseIf iBits < 0 Or iBits > 31 Then
              Err.Raise 6
          End If
   
          SHR = (lValue And &H7FFFFFFE) \ m_l2Power(iBits)
   
          If (lValue And &H80000000) Then
              SHR = (SHR Or (&H40000000 \ m_l2Power(iBits - 1)))
          End If
      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
      '将字符串转成32位字数组(将字符串转成 双字 数组)
      Private Function ConvertToWordArray(sMsg)
          Dim lMsgLength
          Dim lNumberOfWords
          Dim lWordArray()
          Dim lBytePosition
          Dim lByteCount
          Dim lWordCount
          Dim lByte
   
          Const MODULUS_BITS = 512
          Const CONGRUENT_BITS = 448
   
          lMsgLength = Len(sMsg)
   
          lNumberOfWords = (((lMsgLength + ((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 >= lMsgLength
              lWordCount = lByteCount \ BYTES_TO_A_WORD
       
              lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
       
              lByte = AscB(Mid(sMsg, lByteCount + 1, 1))
       
              lWordArray(lWordCount) = lWordArray(lWordCount) Or SHL(lByte, lBytePosition)
              lByteCount = lByteCount + 1
          Loop
          lWordCount = lByteCount \ BYTES_TO_A_WORD
          lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
          lWordArray(lWordCount) = lWordArray(lWordCount) Or SHL(&H80, lBytePosition)
          lWordArray(lNumberOfWords - 1) = SHL(lMsgLength, 3)
          lWordArray(lNumberOfWords - 2) = SHR(lMsgLength, 29)
   
          ConvertToWordArray = lWordArray
      End Function
      '########################HASH算法通用函数结束################
      '********************SHA算法专用函数开始*********************
      Private Function ROTR(x, n)
          ROTR = (SHR(x, (n And m_lOnBits(4))) Or SHL(x, (32 - (n And m_lOnBits(4)))))
      End Function
      Private Function ROTL(x, n)
          ROTL = (SHL(x, (n And m_lOnBits(4))) Or SHR(x, (32 - (n And m_lOnBits(4)))))
      End Function
      Private Function Sigma0(x)
          Sigma0 = (ROTR(x, 2) Xor ROTR(x, 13) Xor ROTR(x, 22))
      End Function
      Private Function Sigma1(x)
          Sigma1 = (ROTR(x, 6) Xor ROTR(x, 11) Xor ROTR(x, 25))
      End Function
      Private Function Gamma0(x)
          Gamma0 = (ROTR(x, 7) Xor ROTR(x, 18) Xor SHR(x, CInt(3 And m_lOnBits(4))))
      End Function
      Private Function Gamma1(x)
          Gamma1 = (ROTR(x, 17) Xor ROTR(x, 19) Xor SHR(x, CInt(10 And m_lOnBits(4))))
      End Function
      Private Function Ch(x, y, z)
          Ch = ((x And y) Xor ((Not x) And z))
      End Function
      Private Function Maj(x, y, z)
          Maj = ((x And y) Xor (x And z) Xor (y And z))
      End Function
      Private Function Parity(x,y,z)
          Parity = x XOR y XOR z
      End Function
    Private Function F1(x,y,z,t)
          Select Case Int(t / 20)
          Case 0
             F1 = CH(x,y,z)
          Case 1
             F1 = Parity(x,y,z)
          Case 2
             F1 = Maj(x,y,z)
          Case 3
             F1 = Parity(x,y,z)
          End Select
    End Function
      '********************SHA算法专用函数结束*********************
    Private Function coreSHA256(M)
          Dim HASH(7),W(80)
          Dim a,b,c,d,e,f,g,h,str
          Dim i,j
          Dim T,T1,T2
         
              '初始化常量
              HASH(0) = &H6A09E667
              HASH(1) = &HBB67AE85
              HASH(2) = &H3C6EF372
              HASH(3) = &HA54FF53A
              HASH(4) = &H510E527F
              HASH(5) = &H9B05688C
              HASH(6) = &H1F83D9AB
              HASH(7) = &H5BE0CD19
              For i = 0 To UBound(M) Step 16 'For i = 1 To N
                  'Initialize the eight working variables
                  a = HASH(0)
                  b = HASH(1)
                  c = HASH(2)
                  d = HASH(3)
                  e = HASH(4)
                  f = HASH(5)
                  g = HASH(6)
                  h = HASH(7)
                  For j = 0 To 63
                      'Prepare the message schedule W(t)
                      If j < 16 Then
                          W(j) = M(j + i)
                      Else
                          W(j) = AddUnsigned(AddUnsigned(AddUnsigned(Gamma1(W(j - 2)), W(j - 7)), Gamma0(W(j - 15))), W(j - 16))
                      End If
                      'For t = 0  to 63
                      T1 = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(h, Sigma1(e)), Ch(e, f, g)), K(j)), W(j))
                      T2 = AddUnsigned(Sigma0(a), Maj(a, b, c))
           
                      h = g
                      g = f
                      f = e
                      e = AddUnsigned(d, T1)
                      d = c
                      c = b
                      b = a
                      a = AddUnsigned(T1, T2)
                  Next
                  HASH(0) = AddUnsigned(a, HASH(0))
                  HASH(1) = AddUnsigned(b, HASH(1))
                  HASH(2) = AddUnsigned(c, HASH(2))
                  HASH(3) = AddUnsigned(d, HASH(3))
                  HASH(4) = AddUnsigned(e, HASH(4))
                  HASH(5) = AddUnsigned(f, HASH(5))
                  HASH(6) = AddUnsigned(g, HASH(6))
                  HASH(7) = AddUnsigned(h, HASH(7))
          Next
          coreSHA256=HASH
    End Function
    public  function EncryptArray(a_aMsg)
        EncryptArray=coreSHA256(a_aMsg)
    end function
      Public Function Encrypt(a_sResultType,a_sMsg)
          Dim sReturn, sType : sType=LCase(Trim(a_sResultType))
          Dim i
          Dim HASH
           Encrypt=NULL
          If Len(sType)<4 Then Exit Function End If
          HASH = coreSHA256(ConvertToWordArray(a_sMsg))
        sReturn=""
        For i=1 To 4
              Select Case Mid(sType,i,1)
              Case "a"
                  sReturn=sReturn & Right("00000000" & Hex(HASH(0)), 8) & Right("00000000" & Hex(HASH(1)), 8)
              Case "b"
                   sReturn=sReturn & Right("00000000" & Hex(HASH(2)), 8) & Right("00000000" & Hex(HASH(3)), 8)
              Case "c"
                  sReturn=sReturn & Right("00000000" & Hex(HASH(4)), 8) & Right("00000000" & Hex(HASH(5)), 8)
              Case "d"
                  sReturn=sReturn & Right("00000000" & Hex(HASH(6)), 8) & Right("00000000" & Hex(HASH(7)), 8)
              End Select
        Next
         
        Encrypt = LCase(sReturn)
    End Function
    Private Sub Class_Initialize()
        Dim i,j
        BITS_TO_A_BYTE = 8
        BYTES_TO_A_WORD = 4
        BITS_TO_A_WORD = 32
        For i = 0 To 30
            j = i + 1
            m_lOnBits(i) = CLng(2^j-1)
            m_l2Power(i) = CLng(2^i)
        Next
          K(0) = &H428A2F98
            K(1) = &H71374491
            K(2) = &HB5C0FBCF
            K(3) = &HE9B5DBA5
            K(4) = &H3956C25B
            K(5) = &H59F111F1
            K(6) = &H923F82A4
            K(7) = &HAB1C5ED5
            K(8) = &HD807AA98
            K(9) = &H12835B01
            K(10) = &H243185BE
            K(11) = &H550C7DC3
            K(12) = &H72BE5D74
            K(13) = &H80DEB1FE
            K(14) = &H9BDC06A7
            K(15) = &HC19BF174
            K(16) = &HE49B69C1
            K(17) = &HEFBE4786
            K(18) = &HFC19DC6
            K(19) = &H240CA1CC
            K(20) = &H2DE92C6F
            K(21) = &H4A7484AA
            K(22) = &H5CB0A9DC
            K(23) = &H76F988DA
            K(24) = &H983E5152
            K(25) = &HA831C66D
            K(26) = &HB00327C8
            K(27) = &HBF597FC7
            K(28) = &HC6E00BF3
            K(29) = &HD5A79147
            K(30) = &H6CA6351
            K(31) = &H14292967
            K(32) = &H27B70A85
            K(33) = &H2E1B2138
            K(34) = &H4D2C6DFC
            K(35) = &H53380D13
            K(36) = &H650A7354
            K(37) = &H766A0ABB
            K(38) = &H81C2C92E
            K(39) = &H92722C85
            K(40) = &HA2BFE8A1
            K(41) = &HA81A664B
            K(42) = &HC24B8B70
            K(43) = &HC76C51A3
            K(44) = &HD192E819
            K(45) = &HD6990624
            K(46) = &HF40E3585
            K(47) = &H106AA070
            K(48) = &H19A4C116
            K(49) = &H1E376C08
            K(50) = &H2748774C
            K(51) = &H34B0BCB5
            K(52) = &H391C0CB3
            K(53) = &H4ED8AA4A
            K(54) = &H5B9CCA4F
            K(55) = &H682E6FF3
            K(56) = &H748F82EE
            K(57) = &H78A5636F
            K(58) = &H84C87814
            K(59) = &H8CC70208
            K(60) = &H90BEFFFA
            K(61) = &HA4506CEB
            K(62) = &HBEF9A3F7
            K(63) = &HC67178F2
    End Sub
End Class
%>

SHA1算法
TSHA1.asp
<%
Class TSHA1
      Private m_lOnBits(30),m_l2Power(30)
      Private K(80)
      Private  BITS_TO_A_BYTE,BYTES_TO_A_WORD,BITS_TO_A_WORD
      '#######################HASH算法通用函数开始#################
    Private Function SHL(lValue, iBits)
        If iBits = 0 Then
            SHL = lValue
            Exit Function
        ElseIf iBits = 31 Then
            If lValue And 1 Then
                SHL = &H80000000
            Else
                SHL = 0
           End If
           Exit Function
       ElseIf iBits < 0 Or iBits > 31 Then
           Err.Raise 6
      End If
        If (lValue And m_l2Power(31 - iBits)) Then
            SHL = ((lValue And m_lOnBits(31 - (iBits + 1))) * m_l2Power(iBits)) Or &H80000000
        Else
            SHL = ((lValue And m_lOnBits(31 - iBits)) * m_l2Power(iBits))
        End If
    End Function
    Private Function SHR(lValue, iBits)
        If iBits = 0 Then
           SHR = lValue
           Exit Function
        ElseIf iBits = 31 Then
            If lValue And &H80000000 Then
              SHR = 1
            Else
                SHR = 0
            End If
            Exit Function
        ElseIf iBits < 0 Or iBits > 31 Then
            Err.Raise 6
        End If
   
        SHR=(lValue And &H7FFFFFFE) \ m_l2Power(iBits)
        If (lValue And &H80000000) Then SHR=(SHR Or (&H40000000 \ m_l2Power(iBits - 1))) End If
    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
      '将字符串转成32位字数组(将字符串转成 双字 数组)
      Private Function ConvertToWordArray(sMsg)
          Dim lMsgLength
          Dim lNumberOfWords
          Dim lWordArray()
          Dim lBytePosition
          Dim lByteCount
          Dim lWordCount
          Dim lByte
   
          Const MODULUS_BITS = 512
          Const CONGRUENT_BITS = 448
   
          lMsgLength = Len(sMsg)
   
          lNumberOfWords = (((lMsgLength + ((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 >= lMsgLength
              lWordCount = lByteCount \ BYTES_TO_A_WORD
       
              lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
       
              lByte = AscB(Mid(sMsg, lByteCount + 1, 1))
       
              lWordArray(lWordCount) = lWordArray(lWordCount) Or SHL(lByte, lBytePosition)
              lByteCount = lByteCount + 1
          Loop
          lWordCount = lByteCount \ BYTES_TO_A_WORD
          lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE
          lWordArray(lWordCount) = lWordArray(lWordCount) Or SHL(&H80, lBytePosition)
          lWordArray(lNumberOfWords - 1) = SHL(lMsgLength, 3)
          lWordArray(lNumberOfWords - 2) = SHR(lMsgLength, 29)
   
          ConvertToWordArray = lWordArray
      End Function
      '########################HASH算法通用函数结束################
      '********************SHA算法专用函数开始*********************
      Private Function ROTR(x, n)
          ROTR = (SHR(x, (n And m_lOnBits(4))) Or SHL(x, (32 - (n And m_lOnBits(4)))))
      End Function
      Private Function ROTL(x, n)
          ROTL = (SHL(x, (n And m_lOnBits(4))) Or SHR(x, (32 - (n And m_lOnBits(4)))))
      End Function
      Private Function Sigma0(x)
          Sigma0 = (ROTR(x, 2) Xor ROTR(x, 13) Xor ROTR(x, 22))
      End Function
      Private Function Sigma1(x)
          Sigma1 = (ROTR(x, 6) Xor ROTR(x, 11) Xor ROTR(x, 25))
      End Function
      Private Function Gamma0(x)
          Gamma0 = (ROTR(x, 7) Xor ROTR(x, 18) Xor SHR(x, CInt(3 And m_lOnBits(4))))
      End Function
      Private Function Gamma1(x)
          Gamma1 = (ROTR(x, 17) Xor ROTR(x, 19) Xor SHR(x, CInt(10 And m_lOnBits(4))))
      End Function
      Private Function Ch(x, y, z)
          Ch = ((x And y) Xor ((Not x) And z))
      End Function
      Private Function Maj(x, y, z)
          Maj = ((x And y) Xor (x And z) Xor (y And z))
      End Function
      Private Function Parity(x,y,z)
          Parity = x XOR y XOR z
      End Function
      Private Function F1(x,y,z,t)
          Select Case Int(t / 20)
          Case 0
             F1 = CH(x,y,z)
          Case 1
             F1 = Parity(x,y,z)
          Case 2
             F1 = Maj(x,y,z)
          Case 3
             F1 = Parity(x,y,z)
          End Select
      End Function
      '********************SHA算法专用函数结束*********************
    Private Function coreSHA1(M)
        Dim HASH(7),W(80)
        Dim a,b,c,d,e,f,g,h,str
        Dim i,j
        Dim T,T1,T2
         '初始化常量
         HASH(0) = &H67452301
               HASH(1) = &HEFCDAB89
               HASH(2) = &H98BADCFE
               HASH(3) = &H10325476
               HASH(4) = &HC3D2E1F0
              For i = 0 To UBound(M) Step 16
                  a = HASH(0)
                  b = HASH(1)
                  c = HASH(2)
                  d = HASH(3)
                  e = HASH(4)
                  For j = 0 To 79
                      If j < 16 Then
                          W(j) = M(j + i)
                      Else
                          W(j) = ROTL(W(j-3) XOR W(j-8) XOR W(j-14) XOR W(j-16),1)
                      End If
                      T =AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(ROTL(a,5),F1(b,c,d,j)),e),K(j)),W(j))
                      e = d
                      d = c
                      c = ROTL(b,30)
                      b=a
                      a = T
                  Next
                  HASH(0) = AddUnsigned(a, HASH(0))
                  HASH(1) = AddUnsigned(b, HASH(1))
                  HASH(2) = AddUnsigned(c, HASH(2))
                  HASH(3) = AddUnsigned(d, HASH(3))
                  HASH(4) = AddUnsigned(e, HASH(4))
              Next
             coreSHA1=HASH
    End Function
    public  function EncryptArray(a_aMsg)
        EncryptArray=coreSHA1(a_aMsg)
    end function
    Public Function Encrypt(a_sType,a_sMsg)
        Dim sReturn, sType : sType=LCase(Trim(a_sType))
        Dim i
        Dim Hash
        Encrypt=false
        If Len(sType)<4 Then Exit Function End If
      
        Hash = coreSHA1(ConvertToWordArray(a_sMsg))
        sReturn=""
        For i=1 To 4
              Select Case Mid(sType,i,1)
              Case "a"
                  sReturn=sReturn & Right("00000000" & Hex(Hash(0)), 8)
              Case "b"
                   sReturn=sReturn & Right("00000000" & Hex(Hash(1)), 8)
              Case "c"
                  sReturn=sReturn & Right("00000000" & Hex(Hash(2)), 8)
              Case "d"
                  sReturn=sReturn & Right("00000000" & Hex(Hash(3)), 8) & Right("00000000" & Hex(Hash(4)), 8)
              End Select
        Next
 
        Encrypt= LCase(sReturn)
    End Function
      '*****************************************
      '初始化
      '*****************************************
      Private Sub Class_Initialize()
          Dim i,j
          BITS_TO_A_BYTE = 8
          BYTES_TO_A_WORD = 4
          BITS_TO_A_WORD = 32
          For i = 0 To 30
              j = i + 1
              m_lOnBits(i) = CLng(2^j-1)
              m_l2Power(i) = CLng(2^i)
          Next
              For i = 0 To 79
                  Select Case Int(i/20)
                  Case 0
                      K(i) = &H5a827999
                  Case 1
                      K(i) = &H6ed9eba1
                  Case 2
                      K(i) = &H8f1bbcdc
                  Case 3
                      K(i) = &Hca62c1d6
                  End Select
              Next
      End Sub
  End Class
%>

MD5算法
TMD5.asp
<%
Class TMD5
    Private m_lOnBits(30), m_l2Power(30)
    Private BITS_TO_A_BYTE, BYTES_TO_A_WORD, BITS_TO_A_WORD
    Private Sub Class_Initialize()
        BITS_TO_A_BYTE = 8
        BYTES_TO_A_WORD = 4
        BITS_TO_A_WORD = 32
        Call HashInit()
    End Sub
    Private Function SHL(lValue, iBits)
        If iBits = 0 Then
            SHL = lValue
            Exit Function
        ElseIf iBits = 31 Then
            If lValue And 1 Then
                SHL = &H80000000
            Else
                SHL = 0
           End If
           Exit Function
       ElseIf iBits < 0 Or iBits > 31 Then
           Err.Raise 6
      End If
        If (lValue And m_l2Power(31 - iBits)) Then
            SHL = ((lValue And m_lOnBits(31 - (iBits + 1))) * m_l2Power(iBits)) Or &H80000000
        Else
            SHL = ((lValue And m_lOnBits(31 - iBits)) * m_l2Power(iBits))
        End If
    End Function
    Private Function SHR(lValue, iBits)
        If iBits = 0 Then
           SHR = lValue
           Exit Function
        ElseIf iBits = 31 Then
            If lValue And &H80000000 Then
              SHR = 1
            Else
                SHR = 0
            End If
            Exit Function
        ElseIf iBits < 0 Or iBits > 31 Then
            Err.Raise 6
        End If
   
        SHR=(lValue And &H7FFFFFFE) \ m_l2Power(iBits)
        If (lValue And &H80000000) Then SHR=(SHR Or (&H40000000 \ m_l2Power(iBits - 1))) End If
    End Function
    Private Function AddUnsigned(lX, lY)
        Dim lX4,lY4,lX8, lY8, 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 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 SHL(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 SHL(&H80, lBytePosition)
    lWordArray(lNumberOfWords - 2) = SHL(lMessageLength, 3)
    lWordArray(lNumberOfWords - 1) = SHR(lMessageLength, 29)
   
    ConvertToWordArray = lWordArray
End Function
Private Function MD5_RotL(lValue, iBits)
    MD5_RotL = SHL(lValue, iBits) Or SHR(lValue, (32 - iBits))
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 = MD5_RotL(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 = MD5_RotL(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 = MD5_RotL(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 = MD5_RotL(a, s)
    a = AddUnsigned(a, b)
End Sub
Private Function WordToHex(lValue)
    Dim lByte
    Dim lCount
   
    For lCount = 0 To 3
        lByte = SHR(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
        WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
    Next
End Function
    Private Sub HashInit()
        Dim i,j
        For i = 0 To 30
            j = i + 1
            m_lOnBits(i) = CLng(2^j-1)
            m_l2Power(i) = CLng(2^i)
        Next
    End Sub
    Private Function coreMD5(x)
        Dim k
        Dim AA, BB, CC, DD
        Dim a, b, c, d
        Dim sResult
        coreMD5=null
   
        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
        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
        coreMD5=Array(a,b,c,d)
    End Function
    public  function EncryptArray(a_aMsg)
        EncryptArray=coreMD5(a_aMsg)
    end function
    Public Function Encrypt(sType,sMessage)
        Dim sResult
        Dim aMD5
        sType=Trim(LCase(sType))
        If Len(sType)<4 Then Exit Function End If
        aMD5=coreMD5(ConvertToWordArray(sMessage))
        Encrypt=null
        If UBound(aMD5)<3 Then Exit Function End If
        sResult=""
        For i=1 To 4
              Select Case Mid(sType,i,1)
              Case "a"
                  sResult=sResult & WordToHex(aMD5(0))
              Case "b"
                   sResult=sResult & WordToHex(aMD5(1))
              Case "c"
                  sResult=sResult &  WordToHex(aMD5(2))
              Case "d"
                  sResult=sResult & WordToHex(aMD5(3))
              End Select
        Next
        Encrypt = LCase(sResult)
    End Function
End Class
%>

AES算法
TAES.asp
<%
Class TAES
    Private cls_lOnBits(30), cls_l2Power(30), cls_bytOnBits(7),cls_byt2Power(7)
    Private cls_InCo(3)
    Private cls_fbsub(255), cls_rbsub(255), cls_ptab(255), cls_ltab(255), cls_ftable(255), cls_rtable(255), cls_rco(29)
    Private cls_Nk, cls_Nb, cls_Nr
    Private cls_fi(23), cls_ri(23), cls_fkey(119), cls_rkey(119)
    Private Sub Class_Initialize()
        cls_InCo(0) = &HB
        cls_InCo(1) = &HD
        cls_InCo(2) = &H9
        cls_InCo(3) = &HE
        cls_bytOnBits(0) = 1
        cls_bytOnBits(1) = 3
        cls_bytOnBits(2) = 7
        cls_bytOnBits(3) = 15
        cls_bytOnBits(4) = 31
        cls_bytOnBits(5) = 63
        cls_bytOnBits(6) = 127
        cls_bytOnBits(7) = 255
   
        cls_byt2Power(0) = 1
        cls_byt2Power(1) = 2
        cls_byt2Power(2) = 4
        cls_byt2Power(3) = 8
        cls_byt2Power(4) = 16
        cls_byt2Power(5) = 32
        cls_byt2Power(6) = 64
        cls_byt2Power(7) = 128
   
        cls_lOnBits(0) = 1
        cls_lOnBits(1) = 3
        cls_lOnBits(2) = 7
        cls_lOnBits(3) = 15
        cls_lOnBits(4) = 31
        cls_lOnBits(5) = 63
        cls_lOnBits(6) = 127
        cls_lOnBits(7) = 255
        cls_lOnBits(8) = 511
        cls_lOnBits(9) = 1023
        cls_lOnBits(10) = 2047
        cls_lOnBits(11) = 4095
        cls_lOnBits(12) = 8191
        cls_lOnBits(13) = 16383
        cls_lOnBits(14) = 32767
        cls_lOnBits(15) = 65535
        cls_lOnBits(16) = 131071
        cls_lOnBits(17) = 262143
        cls_lOnBits(18) = 524287
        cls_lOnBits(19) = 1048575
        cls_lOnBits(20) = 2097151
        cls_lOnBits(21) = 4194303
        cls_lOnBits(22) = 8388607
        cls_lOnBits(23) = 16777215
        cls_lOnBits(24) = 33554431
        cls_lOnBits(25) = 67108863
        cls_lOnBits(26) = 134217727
        cls_lOnBits(27) = 268435455
        cls_lOnBits(28) = 536870911
        cls_lOnBits(29) = 1073741823
        cls_lOnBits(30) = 2147483647
   
        cls_l2Power(0) = 1
        cls_l2Power(1) = 2
        cls_l2Power(2) = 4
        cls_l2Power(3) = 8
        cls_l2Power(4) = 16
        cls_l2Power(5) = 32
        cls_l2Power(6) = 64
        cls_l2Power(7) = 128
        cls_l2Power(8) = 256
        cls_l2Power(9) = 512
        cls_l2Power(10) = 1024
        cls_l2Power(11) = 2048
        cls_l2Power(12) = 4096
        cls_l2Power(13) = 8192
        cls_l2Power(14) = 16384
        cls_l2Power(15) = 32768
        cls_l2Power(16) = 65536
        cls_l2Power(17) = 131072
        cls_l2Power(18) = 262144
        cls_l2Power(19) = 524288
        cls_l2Power(20) = 1048576
        cls_l2Power(21) = 2097152
        cls_l2Power(22) = 4194304
        cls_l2Power(23) = 8388608
        cls_l2Power(24) = 16777216
        cls_l2Power(25) = 33554432
        cls_l2Power(26) = 67108864
        cls_l2Power(27) = 134217728
        cls_l2Power(28) = 268435456
        cls_l2Power(29) = 536870912
        cls_l2Power(30) = 1073741824
    End Sub
    Private Function ByteSub(x)
        Dim y, z
   
        z = x
        y = cls_ptab(255 - cls_ltab(z))
        z = y
        z = ROTLB(z, 1)
        y = y Xor z
        z = ROTLB(z, 1)
        y = y Xor z
        z = ROTLB(z, 1)
        y = y Xor z
        z = ROTLB(z, 1)
        y = y Xor z
        y = y Xor &H63
   
        ByteSub = y
    End Function
    Private Function SHL(lValue, iShiftBits)
        If iShiftBits = 0 Then
            SHL = lValue
            Exit Function
        ElseIf iShiftBits = 31 Then
            If lValue And 1 Then
                SHL = &H80000000
            Else
                SHL = 0
            End If
            Exit Function
        ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
            Err.Raise 6
        End If
   
        If (lValue And cls_l2Power(31 - iShiftBits)) Then
            SHL = ((lValue And cls_lOnBits(31 - (iShiftBits + 1))) * cls_l2Power(iShiftBits)) Or &H80000000
        Else
            SHL = ((lValue And cls_lOnBits(31 - iShiftBits)) * cls_l2Power(iShiftBits))
        End If
    End Function
    Private Function SHR(lValue, iShiftBits)
        If iShiftBits = 0 Then
            SHR = lValue
            Exit Function
        ElseIf iShiftBits = 31 Then
            If lValue And &H80000000 Then
                SHR = 1
            Else
                SHR = 0
            End If
            Exit Function
        ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
            Err.Raise 6
        End If
   
        SHR = (lValue And &H7FFFFFFE) \ cls_l2Power(iShiftBits)
   
        If (lValue And &H80000000) Then
            SHR = (SHR Or (&H40000000 \ cls_l2Power(iShiftBits - 1)))
        End If
    End Function
    Private Function SHLB(bytValue, bytShiftBits)
        If bytShiftBits = 0 Then
            SHLB = bytValue
            Exit Function
        ElseIf bytShiftBits = 7 Then
            If bytValue And 1 Then
                SHLB = &H80
            Else
                SHLB = 0
            End If
            Exit Function
        ElseIf bytShiftBits < 0 Or bytShiftBits > 7 Then
            Err.Raise 6
        End If
   
        SHLB = ((bytValue And cls_bytOnBits(7 - bytShiftBits)) * cls_byt2Power(bytShiftBits))
    End Function
    Private Function SHRB(bytValue, bytShiftBits)
        If bytShiftBits = 0 Then
            SHRB = bytValue
            Exit Function
        ElseIf bytShiftBits = 7 Then
            If bytValue And &H80 Then
                SHRB = 1
            Else
                SHRB = 0
            End If
            Exit Function
        ElseIf bytShiftBits < 0 Or bytShiftBits > 7 Then
            Err.Raise 6
        End If
   
        SHRB = bytValue \ cls_byt2Power(bytShiftBits)
    End Function
    Private Function ROTL(lValue, iShiftBits)
        ROTL = SHL(lValue, iShiftBits) Or SHR(lValue, (32 - iShiftBits))
    End Function
    Private Function ROTLB(bytValue, bytShiftBits)
        ROTLB = SHLB(bytValue, bytShiftBits) Or SHRB(bytValue, (8 - bytShiftBits))
    End Function
    Private Function Pack(b())
        Dim lCount
        Dim lTemp
   
        For lCount = 0 To 3
            lTemp = b(lCount)
            Pack = Pack Or SHL(lTemp, (lCount * 8))
        Next
    End Function
    Private Function PackFrom(b(), k)
        Dim lCount
        Dim lTemp
   
        For lCount = 0 To 3
            lTemp = b(lCount + k)
            PackFrom = PackFrom Or SHL(lTemp, (lCount * 8))
        Next
    End Function
    Private Sub Unpack(a, b())
        b(0) = a And cls_lOnBits(7)
        b(1) = SHR(a, 8) And cls_lOnBits(7)
        b(2) = SHR(a, 16) And cls_lOnBits(7)
        b(3) = SHR(a, 24) And cls_lOnBits(7)
    End Sub
    Private Sub UnpackFrom(a, ByRef b(), k)
        b(0 + k) = a And cls_lOnBits(7)
        b(1 + k) = SHR(a, 8) And cls_lOnBits(7)
        b(2 + k) = SHR(a, 16) And cls_lOnBits(7)
        b(3 + k) = SHR(a, 24) And cls_lOnBits(7)
    End Sub
    Private Function IsInitialized(ByVal a_aArray)
        On Error Resume Next
        IsInitialized = IsNumeric(UBound(a_aArray))
    End Function
    Private Sub CopyBytesASP(bytDest, lDestStart, bytSource(), lSourceStart, lLength)
        Dim lCount
   
        lCount = 0
 
        Do
            bytDest(lDestStart + lCount) = bytSource(lSourceStart + lCount)
            lCount = lCount + 1
        Loop Until lCount = lLength
    End Sub
    Private Function xtime(a)
        Dim b
   
        If (a And &H80) Then
            b = &H1B
        Else
            b = 0
        End If
   
        xtime = SHLB(a, 1)
        xtime = xtime Xor b
    End Function
    Private Function bmul(x, y)
        If x <> 0 And y <> 0 Then
            bmul = cls_ptab((CLng(cls_ltab(x)) + CLng(cls_ltab(y))) Mod 255)
        Else
            bmul = 0
        End If
    End Function
    Private Function SubByte(a)
        Dim b(3)
   
        Unpack a, b
        b(0) = cls_fbsub(b(0))
        b(1) = cls_fbsub(b(1))
        b(2) = cls_fbsub(b(2))
        b(3) = cls_fbsub(b(3))
   
        SubByte = Pack(b)
    End Function
    Private Function product(x, y)
        Dim xb(3), yb(3)
   
        Unpack x, xb
        Unpack y, yb
        product = bmul(xb(0), yb(0)) Xor bmul(xb(1), yb(1)) Xor bmul(xb(2), yb(2)) Xor bmul(xb(3), yb(3))
    End Function
    Private Function InvMixCol(x)
        Dim y, m
        Dim b(3)
   
        m = Pack(cls_InCo)
        b(3) = product(m, x)
        m = ROTL(m, 24)
        b(2) = product(m, x)
        m = ROTL(m, 24)
        b(1) = product(m, x)
        m = ROTL(m, 24)
        b(0) = product(m, x)
        y = Pack(b)
   
        InvMixCol = y
    End Function
    Public Sub gentables()
        Dim i, y, ib
        Dim b(3)
   
        cls_ltab(0) = 0
        cls_ltab(1) = 0
        cls_ltab(3) = 1
        cls_ptab(0) = 1
        cls_ptab(1) = 3
   
        For i = 2 To 255
            cls_ptab(i) = cls_ptab(i - 1) Xor xtime(cls_ptab(i - 1))
            cls_ltab(cls_ptab(i)) = i
        Next
   
        cls_fbsub(0) = &H63
        cls_rbsub(&H63) = 0
   
        For i = 1 To 255
            ib = i
            y = ByteSub(ib)
            cls_fbsub(i) = y
            cls_rbsub(y) = i
        Next
   
        y = 1
        For i = 0 To 29
            cls_rco(i) = y
            y = xtime(y)
        Next
   
        For i = 0 To 255
            y = cls_fbsub(i)
            b(3) = y Xor xtime(y)
            b(2) = y
            b(1) = y
            b(0) = xtime(y)
            cls_ftable(i) = Pack(b)
            y = cls_rbsub(i)
            b(3) = bmul(cls_InCo(0), y)
            b(2) = bmul(cls_InCo(1), y)
            b(1) = bmul(cls_InCo(2), y)
            b(0) = bmul(cls_InCo(3), y)
            cls_rtable(i) = Pack(b)
        Next
    End Sub
    Private Sub gkey(nb, nk, key())               
        Dim i, j, k, m, n
        Dim C1, C2, C3
        Dim CipherKey(7)
   
        cls_Nb = nb
        cls_Nk = nk
   
        If cls_Nb >= cls_Nk Then
            cls_Nr = 6 + cls_Nb
        Else
            cls_Nr = 6 + cls_Nk
        End If
   
        C1 = 1
        If cls_Nb < 8 Then
            C2 = 2
            C3 = 3
        Else
            C2 = 3
            C3 = 4
        End If
   
        For j = 0 To nb - 1
            m = j * 3
       
            cls_fi(m) = (j + C1) Mod nb
            cls_fi(m + 1) = (j + C2) Mod nb
            cls_fi(m + 2) = (j + C3) Mod nb
            cls_ri(m) = (nb + j - C1) Mod nb
            cls_ri(m + 1) = (nb + j - C2) Mod nb
            cls_ri(m + 2) = (nb + j - C3) Mod nb
        Next
   
        N = cls_Nb * (cls_Nr + 1)
   
        For i = 0 To cls_Nk - 1
            j = i * 4
            CipherKey(i) = PackFrom(key, j)
        Next
   
        For i = 0 To cls_Nk - 1
            cls_fkey(i) = CipherKey(i)
        Next
   
        j = cls_Nk
        k = 0
 
        Do While j < N
            cls_fkey(j) = cls_fkey(j - cls_Nk) Xor _
            SubByte(ROTL(cls_fkey(j - 1), 24)) Xor cls_rco(k)
   
            If cls_Nk <= 6 Then
                i = 1
 
                Do While i < cls_Nk And (i + j) < N
                    cls_fkey(i + j) = cls_fkey(i + j - cls_Nk) Xor _
                    cls_fkey(i + j - 1)
                    i = i + 1
                Loop
            Else
                i = 1
  
                Do While i < 4 And (i + j) < N
                    cls_fkey(i + j) = cls_fkey(i + j - cls_Nk) Xor _
                    cls_fkey(i + j - 1)
                    i = i + 1
                Loop
 
                If j + 4 < N Then
                    cls_fkey(j + 4) = cls_fkey(j + 4 - cls_Nk) Xor _
                    SubByte(cls_fkey(j + 3))
                End If
   
                i = 5
 
                Do While i < cls_Nk And (i + j) < N
                    cls_fkey(i + j) = cls_fkey(i + j - cls_Nk) Xor _
                    cls_fkey(i + j - 1)
                    i = i + 1
                Loop
            End If
       
            j = j + cls_Nk
            k = k + 1
        Loop
   
        For j = 0 To cls_Nb - 1
            cls_rkey(j + N - nb) = cls_fkey(j)
        Next
   
        i = cls_Nb
 
        Do While i < N - cls_Nb
            k = N - cls_Nb - i
 
            For j = 0 To cls_Nb - 1
                cls_rkey(k + j) = InvMixCol(cls_fkey(i + j))
            Next
  
            i = i + cls_Nb
        Loop
   
        j = N - cls_Nb
 
        Do While j < N
            cls_rkey(j - N + cls_Nb) = cls_fkey(j)
            j = j + 1
        Loop
    End Sub
    Private Sub EncryptData(buff())
        Dim i, j, k, m, x, y, t
        Dim a(7), b(7)
   
        For i = 0 To cls_Nb - 1
            j = i * 4
            a(i) = PackFrom(buff, j)
            a(i) = a(i) Xor cls_fkey(i)
        Next
   
        k = cls_Nb
        x = a
        y = b
   
        For i = 1 To cls_Nr - 1
            For j = 0 To cls_Nb - 1
                m = j * 3
                y(j) = cls_fkey(k) Xor cls_ftable(x(j) And cls_lOnBits(7)) Xor _
                ROTL(cls_ftable(SHR(x(cls_fi(m)), 8) And cls_lOnBits(7)), 8) Xor _
                ROTL(cls_ftable(SHR(x(cls_fi(m + 1)), 16) And cls_lOnBits(7)), 16) Xor _
                ROTL(cls_ftable(SHR(x(cls_fi(m + 2)), 24) And cls_lOnBits(7)), 24)
                k = k + 1
            Next
            t = x
            x = y
            y = t
        Next
   
        For j = 0 To cls_Nb - 1
            m = j * 3
            y(j) = cls_fkey(k) Xor cls_fbsub(x(j) And cls_lOnBits(7)) Xor _
            ROTL(cls_fbsub(SHR(x(cls_fi(m)), 8) And cls_lOnBits(7)), 8) Xor _
            ROTL(cls_fbsub(SHR(x(cls_fi(m + 1)), 16) And cls_lOnBits(7)), 16) Xor _
            ROTL(cls_fbsub(SHR(x(cls_fi(m + 2)), 24) And cls_lOnBits(7)), 24)
            k = k + 1
        Next
   
        For i = 0 To cls_Nb - 1
            j = i * 4
            UnpackFrom y(i), buff, j
            x(i) = 0
            y(i) = 0
        Next
    End Sub
    Private Sub DecryptData(buff())
        Dim i, j, k, m, x, y, t
        Dim a(7), b(7)
   
        For i = 0 To cls_Nb - 1
            j = i * 4
            a(i) = PackFrom(buff, j)
            a(i) = a(i) Xor cls_rkey(i)
        Next
   
        k = cls_Nb
        x = a
        y = b
   
        For i = 1 To cls_Nr - 1
            For j = 0 To cls_Nb - 1
                m = j * 3
                y(j) = cls_rkey(k) Xor cls_rtable(x(j) And cls_lOnBits(7)) Xor _
                ROTL(cls_rtable(SHR(x(cls_ri(m)), 8) And cls_lOnBits(7)), 8) Xor _
                ROTL(cls_rtable(SHR(x(cls_ri(m + 1)), 16) And cls_lOnBits(7)), 16) Xor _
                ROTL(cls_rtable(SHR(x(cls_ri(m + 2)), 24) And cls_lOnBits(7)), 24)
                k = k + 1
            Next
            t = x
            x = y
            y = t
        Next
   
        For j = 0 To cls_Nb - 1
            m = j * 3
            y(j) = cls_rkey(k) Xor cls_rbsub(x(j) And cls_lOnBits(7)) Xor _
            ROTL(cls_rbsub(SHR(x(cls_ri(m)), 8) And cls_lOnBits(7)), 8) Xor _
            ROTL(cls_rbsub(SHR(x(cls_ri(m + 1)), 16) And cls_lOnBits(7)), 16) Xor _
            ROTL(cls_rbsub(SHR(x(cls_ri(m + 2)), 24) And cls_lOnBits(7)), 24)
            k = k + 1
        Next
   
        For i = 0 To cls_Nb - 1
            j = i * 4
            UnpackFrom y(i), buff, j
            x(i) = 0
            y(i) = 0
        Next
    End Sub
    Public Function Encrypt(a_sMsg, a_sPassword)
        Dim bytKey(31)
        Dim bytTemp(31)
        Dim bytLen(3)
        Dim bytIn()
        Dim bytOut()
        Dim lCount, lLength, lEncodedLength, lPosition
        Dim bytMessage
        Dim sResult
        lLength = Len(a_sMsg)
        ReDim bytMessage(lLength-1)
 
        For lCount = 1 To lLength
            bytMessage(lCount-1)=CByte(AscB(Mid(a_sMsg,lCount,1)))
        Next
        lLength = Len(a_sPassword)
        ReDim bytPassword(lLength-1)
        For lCount = 1 To lLength
            bytPassword(lCount-1)=CByte(AscB(Mid(a_sPassword,lCount,1)))
        Next
        If Not IsInitialized(bytMessage) Then
            Exit Function
        End If
 
        If Not IsInitialized(bytPassword) Then
            Exit Function
        End If
        For lCount = 0 To UBound(bytPassword)
            bytKey(lCount) = bytPassword(lCount)
            If lCount = 31 Then
                Exit For
            End If
        Next
   
        Call genTables()
        Call gKey(8, 8, bytKey)
        lLength = UBound(bytMessage) + 1
        lEncodedLength = lLength + 4
   
        If lEncodedLength Mod 32 <> 0 Then
            lEncodedLength = lEncodedLength + 32 - (lEncodedLength Mod 32)
        End If
  
        ReDim bytIn(lEncodedLength - 1)
        ReDim bytOut(lEncodedLength - 1)
        Unpack lLength, bytIn
        CopyBytesASP bytIn, 4, bytMessage, 0, lLength
        For lCount = 0 To lEncodedLength - 1 Step 32
            CopyBytesASP bytTemp, 0, bytIn, lCount, 32
            EncryptData bytTemp
            CopyBytesASP bytOut, lCount, bytTemp, 0, 32
        Next
        sResult = ""
 
        For lCount = 0 To UBound(bytOut)
            sResult = sResult & Right("0" & Hex(bytOut(lCount)), 2)
        Next
        Encrypt = sResult
    End Function
    Public Function Decrypt(a_sIn, a_sPassword)
        Dim bytMessage(), bytOut()
        Dim bytKey(31), bytTemp(31), bytIn, bytPassword, bytLen(3)
        Dim lCount, lLength, lEncodedLength, lPosition
        Dim sResult, sMsg : sMsg = Trim(a_sIn)
        Dim iCount
        If sMsg="" Or IsEmpty(sMsg) Or IsNull(sMsg) Then
            Exit Function
        End If
        lLength = Len(sMsg)
        ReDim bytIn(lLength/2-1)
        iCount = 0
       
        For lCount = 1 To lLength Step 2
            bytIn(iCount) = CByte(Int("&H" & Mid(sMsg, lCount,2)))
            iCount = iCount + 1
        Next
        lLength = Len(a_sPassword)
        ReDim bytPassword(lLength-1)
        For lCount = 1 To lLength
            bytPassword(lCount-1)=CByte(AscB(Mid(a_sPassword,lCount,1)))
        Next
        If Not IsInitialized(bytIn) Then
            Exit Function
        End If
        If Not IsInitialized(bytPassword) Then
            Exit Function
        End If
        lEncodedLength = UBound(bytIn) + 1
        If Int(lEncodedLength) Mod 32 <> 0 Then
            Exit Function
        End If
   
        For lCount = 0 To UBound(bytPassword)
            bytKey(lCount) = bytPassword(lCount)
            If lCount = 31 Then
                Exit For
            End If
        Next
   
        Call genTables()
        Call gKey(8, 8, bytKey)
        ReDim bytOut(lEncodedLength - 1)
 
        For lCount = 0 To lEncodedLength - 1 Step 32
            CopyBytesASP bytTemp, 0, bytIn, lCount, 32
            DecryptData bytTemp
            CopyBytesASP bytOut, lCount, bytTemp, 0, 32
        Next
        lLength = Pack(bytOut)
        If lLength > lEncodedLength - 4 Then
            Exit Function
        End If
   
        ReDim bytMessage(lLength - 1)
        CopyBytesASP bytMessage, 0, bytOut, 4, lLength
        lLength = UBound(bytMessage)
        sResult = ""
 
        For lCount = 0 To lLength
            sResult = sResult & Chr(bytMessage(lCount))
        Next
        Decrypt = sResult
    End Function
End Class
%>

RSA加密解密算法
TRSA.asp
<%
' Compiled by Lewis Edward Moten III
' lewis@moten.com
' http://www.lewismoten.com
' Wednesday, May 09, 2001 05:42 PM GMT +5
' RSA Encryption Class
'
' .KeyEnc
'  Key for others to encrypt data with.
'
' .KeyDec
'  Your personal private key.  Keep this hidden.
'
' .KeyMod
'  Used with both public and private keys when encrypting and decrypting data.
'
' .KeyGen
'  Used to generate both public and private keys for encrypting and decrypting data.
'
' .Encode(pStrMessage)
'  Encrypts message and returns in numeric format
'
' .Decode(pStrMessage)
'  Decrypts message and returns a string
'
Class TRSA
    Public KeyEnc
    Public KeyDec
    Private Function Mult(ByVal x, ByVal pg, ByVal m)
        dim y : y=1
 
        Do While pg > 0
         Do While (pg / 2) = Int((pg / 2))
             x = nMod((x * x), m)
             pg = pg / 2
         Loop
         y = nMod((x * y), m)
         pg = pg - 1
        Loop
        Mult = y
    End Function
    Private Function nMod(x, y)
        nMod = 0
        if y = 0 then Exit Function End If
        nMod = x - (Int(x / y) * y)
    End Function
    Private Function Euler(E3, PHI3)
     'genetates D from (E and PHI) using the Euler algorithm
     On Error Resume Next
     Dim u1, u2, u3, v1, v2, v3, q
     Dim t1, t2, t3, z, vv, inverse
     u1 = 1
     u2 = 0
     u3 = PHI3
     v1 = 0
     v2 = 1
     v3 = E3
     Do Until (v3 = 0)
         q = Int(u3 / v3)
         t1 = u1 - q * v1: t2 = u2 - q * v2: t3 = u3 - q * v3
         u1 = v1: u2 = v2: u3 = v3
         v1 = t1: v2 = t2: v3 = t3
         z = 1
     Loop
     If (u2 < 0) Then
         inverse = u2 + PHI3
     Else
         inverse = u2
     End If
     Euler = inverse
    End Function
    Private Function GCD(nPHI)
     On Error Resume Next
     Dim nE, y
     Const N_UP = 99999999 'set upper limit of random number For E
     Const N_LW = 10000000 'set lower limit of random number For E
     Randomize
     nE = Int((N_UP - N_LW + 1) * Rnd + N_LW)
  Do
      x = nPHI Mod nE
      y = x Mod nE
      If y <> 0 And IsPrime(nE) Then
          GCD = nE
          Exit Function
      Else
          nE = nE + 1
      End If
  Loop
    End Function
    Private Function IsPrime(lngNumber)
        On Error Resume Next
        Dim lngCount, ngSqr
        Dim x
        lngSqr = Int(Sqr(lngNumber)) ' Get the int square root
        If lngNumber < 2 Then
            IsPrime = False
            Exit Function
        End If
        lngCount = 2
        IsPrime = True
        If lngNumber Mod lngCount = 0 Then
            IsPrime = False
            Exit Function
        End If
        lngCount = 3
        For x = lngCount To lngSqr Step 2
            If lngNumber Mod x = 0 Then
                IsPrime = False
                Exit Function
            End If
        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
    Public Function Encrypt(ByVal tIp)
        Dim encSt, z
        Dim strMult
        Dim iEnc, iMod
        Dim aKey : aKey=Split(KeyEnc,",")
        If tIp = "" Then Exit Function End If
        iEnc=Int(aKey(0))
        iMod=Int(aKey(1))
        For z = 1 To Len(tIp)
            encSt = encSt & NumberToHex(Mult(CLng(Asc(Mid(tIp, z, 1))), iEnc, iMod),8)
        Next
 
        Encrypt = encSt
    End Function
    Public Function Decrypt(ByVal tIp)
        Dim decSt, z
        Dim iDec, iMod
        Dim aKey : aKey=Split(KeyDec,",")
        if Len(tIp) Mod 8 <> 0 then Exit Function End If
       iDec=Int(aKey(0))
       iMod=Int(aKey(1))
 
        For z = 1 To Len(tIp) Step 8
            decSt = decSt + Chr(Mult(HexToNumber(Mid(tIp, z, 8)), iDec, iMod))
        Next
 
        Decrypt = decSt
    End Function
    Public Function genKey()
        'Generates the keys for E, D and N
        Dim E, D, N, p, q
        Const PQ_UP = 9999 'set upper limit of random number
        Const PQ_LW = 3170 'set lower limit of random number
        Const KEY_LOWER_LIMIT  = 10000000 'set For 64bit minimum
        p = 0: q = 0
        Randomize
        Do Until D > KEY_LOWER_LIMIT 'makes sure keys are 64bit minimum
            Do Until IsPrime(p) And IsPrime(q) ' make sure q and q are primes
                p = clng((PQ_UP - PQ_LW + 1) * Rnd + PQ_LW)
                q = clng((PQ_UP - PQ_LW + 1) * Rnd + PQ_LW)
             Loop
            N = clng(p * q)
            PHI = (p - 1) * (q - 1)
            E = clng(GCD(PHI))
            D = clng(Euler(E, PHI))
        Loop
        KeyEnc = E & "," & N
        KeyDec = D & "," & N
        genKey=E & "," & D & "," & N
    End Function
    Public Function setKey(ByVal a_sKey)
        Dim aKeys : aKeys=Split(a_sKey,",")
        setKey=false
        KeyEnc=null
        KeyDec=null
        If UBound(aKeys)<2 Then Exit Function End If
        KeyEnc=aKeys(0) & "," & aKeys(2)
        KeyDec=aKeys(1) & "," & aKeys(2)
        setKey=true
    End Function
End Class
%>