clscryptoapi.cls

程序加密算法

      strOutput = strRndBuffer
  End If

' ---------------------------------------------------------------------------
' Return data
' ---------------------------------------------------------------------------
  If blnRetExactLength Then
      CreateRandom = Left$(strOutput, lngDataLength)
  Else
      CreateRandom = RTrim$(strOutput)
  End If
  
' ---------------------------------------------------------------------------
' empty variables
' ---------------------------------------------------------------------------
  strOutput = String$(250, 0)
  strRndBuffer = String$(250, 0)
  
End Function

Public Function CreateSaltValue(Optional lngReturnLength As Long = 20, _
             Optional blnUseLettersNumbersOnly As Boolean = True) As Variant
Attribute CreateSaltValue.VB_Description = "Generate random data to be used a salt value.  This will return values 0-9, A-Z, and a-z or truely random data."

' ***************************************************************************
' Routine:       CreateSaltValue
'
' Description:   Generate random data to be used a salt value.  This will
'                return values 0-9, A-Z, and a-z or truely random data.
'
' Parameters:    lngReturnLength - Length of data to be returned
'                blnUseLettersNumbersOnly - (Optional) [Default] TRUE=Use
'                     letters and numbers only.
'                     FALSE=Use truely random data
'
' Returns:       A string of random data
'
' ===========================================================================
'    DATE      NAME / eMAIL
'              DESCRIPTION
' -----------  --------------------------------------------------------------
' 03-OCT-2000  Kenneth Ives  [e-mail]
'              Modified and documented
' 24-JUL-2001  Kenneth Ives  [e-mail]
'              Added boolean parameter
' 09-SEP-2001  Kenneth Ives  [e-mail]
'              Documented and added 9 to bad ASCII values
' ***************************************************************************
    
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim intChar    As Integer
  Dim lngIndex   As Long
  Dim strOutput  As String
  
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  strOutput = ""
  
' ---------------------------------------------------------------------------
' Create salt value string using 0-9, A-Z, a-z only
' ---------------------------------------------------------------------------
  If blnUseLettersNumbersOnly Then

      For lngIndex = 1 To lngReturnLength
  
          intChar = Int(Rnd2(48!, 122!))
      
          Select Case intChar
                 Case 58 To 64, 91 To 96
                      intChar = intChar + 9   ' add 9 to unwanted values
          End Select
      
          strOutput = strOutput & Chr$(intChar)
      Next
  Else
      strOutput = CreateRandom(lngReturnLength, True)
  End If
  
' ---------------------------------------------------------------------------
' Return the new Salt value
' ---------------------------------------------------------------------------
  CreateSaltValue = strOutput
  
' ---------------------------------------------------------------------------
' empty variables
' ---------------------------------------------------------------------------
  strOutput = String$(250, 0)
  
End Function

Public Function Decrypt(Optional intHashType As Integer = 1, _
                        Optional intCipherType As Integer = 1) As Boolean

' ***************************************************************************
' Routine:       Decrypt
'
' Description:   Call the decyption routine.
'
' Parameters:    intHashType - (Optional) [Default] 1=Use MD5 hash algorithm
'                    Selection:   1=MD5  2=MD4  3=MD2  4=SHA-1
'                intCipherType - (Optional) [Default] 1=Use RC4 algorithm
'                    Selection:  (Default Provider)   1=RC4  2=RC2  3=DES
'                                (Enhanced Provider)  4=3DES 5=3DES_112
'
' Returns:       TRUE/FALSE based on completion.
'
' ===========================================================================
'    DATE      NAME / eMAIL
'              DESCRIPTION
' -----------  --------------------------------------------------------------
' 00-Feb-1998  Sam Patterson's COMponent builder Article in Visual Basic
'              Programmers Journal, "Secure Your Apps with CryptoAPI".
'              Great magazine to subscribe to.
' 29-DEC-2000  Kenneth Ives  [e-mail]
'              Modified and documented
' 24-JUL-2001  Kenneth Ives  [e-mail]
'              Added parameters to determine type of hash and cipher
'              algorithms to use
' 09-SEP-2001  Kenneth Ives  [e-mail]
'              Changed to a function routine. Added parameters for hash and
'              cipher selections.
' ***************************************************************************
  
' ---------------------------------------------------------------------------
' Decrypt the data
' ---------------------------------------------------------------------------
  Decrypt = CryptoDecrypt(intHashType, intCipherType)
  
End Function

Private Function CryptoDecrypt(intHashType As Integer, _
                               intCipherType As Integer) As Boolean

' ***************************************************************************
' Routine:       CryptoDecrypt
'
' Description:   Perform the actual decryption of a string of data or a file.
'
' Returns:       TRUE/FALSE based on completion
'
' ===========================================================================
'    DATE      NAME / eMAIL
'              DESCRIPTION
' -----------  --------------------------------------------------------------
' 00-Feb-1998  Sam Patterson's COMponent builder Article in Visual Basic
'              Programmers Journal, "Secure Your Apps with CryptoAPI".
'              Great magazine to subscribe to.
' 29-DEC-2000  Kenneth Ives  [e-mail]
'              Modified and documented
' 24-JUL-2001  Kenneth Ives  [e-mail]
'              Modified and documented
' 09-SEP-2001  Kenneth Ives  [e-mail]
'              Changed to a function routine. Added parameters for hash and
'              cipher selections.  Corrected bad coding when calling
'              CryptDecrypt() function.
' ***************************************************************************
    
' ---------------------------------------------------------------------------
' Define local variables
' ---------------------------------------------------------------------------
  Dim lngHashHwd      As Long     ' Hash handle
  Dim lngHkey         As Long
  Dim lngRetCode      As Long     ' return value from an API call
  Dim lngHashType     As Long
  Dim lngLength       As Long
  Dim lngCipherType   As Long
  Dim lngHExchgKey    As Long
  Dim lngCryptLength  As Long
  Dim lngCryptBufLen  As Long
  Dim strCryptBuffer  As String
  Dim strOutputData   As String
  Dim strPassword     As String
  
' ---------------------------------------------------------------------------
' Initialize variables
' ---------------------------------------------------------------------------
  CryptoDecrypt = False        ' preset to FALSE
  Erase m_abytOutputData()
  ReDim m_abytOutputData(0)
  strOutputData = ""
  strCryptBuffer = ""
  strPassword = ""

' ---------------------------------------------------------------------------
' If bad hash or cipher selection then leave
' ---------------------------------------------------------------------------
  lngHashType = GetHashType(intHashType, lngLength)
  If lngHashType = 0 Then
      MsgBox "This hash selection is not supported.", _
             vbExclamation Or vbOKOnly, "Wrong Decrypt Hash Selection"
      Call Class_Terminate       ' Failed.  Time to leave.
      Exit Function
  End If
    
  lngCipherType = GetCipherType(intCipherType)
  If lngCipherType = 0 Then
      Call Class_Terminate       ' Failed.  Time to leave.
      Exit Function
  End If
    
' ---------------------------------------------------------------------------
' Aquire the provider handle
' ---------------------------------------------------------------------------
  If m_lngCryptContext = 0 Then
      If Not GetProvider Then
          Call Class_Terminate       ' Failed.  Time to leave.
          Exit Function
      End If
  End If

  On Error GoTo CryptoDecrypt_Error
' ---------------------------------------------------------------------------
' convert password to string
' ---------------------------------------------------------------------------
  If UBound(m_abytPWord) > 0 Then
      strPassword = ByteArrayToString(m_abytPWord())
  Else
      If m_blnUseDefaultPWD Then
          m_abytPWord = GetPassword(True)       ' Use the default password
          strPassword = ByteArrayToString(m_abytPWord())
      End If
  End If
  
' ---------------------------------------------------------------------------
' Create a hash object
' ---------------------------------------------------------------------------
  If Not CBool(CryptCreateHash(m_lngCryptContext, lngHashType, ByVal 0&, _
               ByVal 0&, lngHashHwd)) Then
  
      MsgBox "Error: " & CStr(GetLastError) & " during CryptCreateHash!", _
             vbExclamation Or vbOKOnly, "Decryption Errors"
      GoTo CleanUp
  End If

' ---------------------------------------------------------------------------
' Hash in the password text
' ---------------------------------------------------------------------------
  If Not CBool(CryptHashData(lngHashHwd, strPassword, Len(strPassword), ByVal 0&)) Then
      MsgBox "Error: " & CStr(GetLastError) & " during CryptHashData!", _
             vbExclamation Or vbOKOnly, "Decryption Errors"
      GoTo CleanUp
  End If
    
' ---------------------------------------------------------------------------
' Create a session key from the hash object
' ---------------------------------------------------------------------------
  If Not CBool(CryptDeriveKey(m_lngCryptContext, lngCipherType, _
               lngHashHwd, ByVal 0&, lngHkey)) Then
               
      MsgBox ("Error: " & CStr(GetLastError) & " during CryptDeriveKey!"), _
             vbExclamation Or vbOKOnly, "Decryption Errors"
      GoTo CleanUp
  End If

' ---------------------------------------------------------------------------
' Destroy hash object
' ---------------------------------------------------------------------------
  If lngHashHwd <> 0 Then
      lngRetCode = CryptDestroyHash(lngHashHwd)
  End If
  lngHashHwd = 0

' ---------------------------------------------------------------------------
' Prepare data for decryption.
' ---------------------------------------------------------------------------
  lngCryptLength = Len(m_strInputData)
  lngCryptBufLen = lngCryptLength * 2
  strCryptBuffer = String$(lngCryptBufLen, vbNullChar)
  LSet strCryptBuffer = m_strInputData
  
' ---------------------------------------------------------------------------
' Decrypt the text data
' ---------------------------------------------------------------------------
  If Not CBool(CryptDecrypt(lngHkey, ByVal 0&, ByVal 1&, ByVal 0&, _
               strCryptBuffer, lngCryptLength)) Then
      
      MsgBox