'
'  ddwcrypt.bas
'
'  Wrapper Functions for MS's CryptoApi using
'  the Microsoft Base RSA Cryptographic Provider with Streamed input.
'  By Don Dickinson
'  ddickinson@basicguru.com
'  www.basicguru.com/dickinson
'
'  Anyone who finds this code useful it free to use
'  it at their own risk. By using this code
'  you agree to hold the author, Don Dickinson,
'  harmless from all effects and side-effects
'  of its use.
'
'
'  Function Prototypes
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

'- General (usually I don't call these directly)
Declare Function crGetDefaultRSAHandle As Long
Declare Function crCrypt( sInput As String, sOutput As String, sPassword As String, IsInputEncrypted As Long) As Long
Declare Function crFileToFile( inFile As String, outFile As String, sPassword As String, IsInputEncrypted As Long) As Long

'- Call these to encrypt strings/files
Declare Function creStringToString(sInput As String, sOutput As String, sPassword As String) As Long
Declare Function creFileToFile(inFile As String, outFile As String, sPassword As String) As Long
Declare Function creStringToFile(sToEncrypt As String, outFile As String, sPassword As String) As Long

'- Call these to decrypt strings/files
Declare Function crdStringToString(sEnc As String, sDec As String, sPassword As String) As Long
Declare Function crdFileToFile(inFile As String, outFile As String, sPassword As String) As Long
Declare Function crdFileToString(encryptedFile As String, sOutput As String, sPassword As String) As Long

'
'  crGetDefaultRSAHandle
'
'  Returns the handle to the default provider. Returns %False (0) if failure
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function crGetDefaultRSAHandle As Long

   Dim hProv As Long

   If CryptAcquireContext(hProv, ByVal %NULL,  ByVal %NULL,  %PROV_RSA_FULL, 0) = %False Then

      '- Create a new key container
      '
      '  This will only be called the first time you
      '  run this program.
      '
      If CryptAcquireContext(hProv, ByVal %NULL, $MS_DEF_PROV, %PROV_RSA_FULL, %CRYPT_NEWKEYSET) = %False Then
         Function = %False
      Else
         Function = hProv
      End If
   Else
      Function  = hProv
   End If

End Function

'
'  crCrypt
'  This is the main function. It's called creStringToString and crdStringToString
'  It encrypts data using RC_4 - streamed encryption.
'  Set IsInputEncrypted to %False if you want to encrypt sInput to sOutput
'  Set IsInputEncrypted to non-zero to decrypt.
'
'  There is great room for improving this function by breaking the data
'  into chunks so progress can be reported. As it is here, the data
'  is sent to the crypto api as one big block. If there's a limit
'  to the amount of data that can be sent directly (not in chunks), I'm not
'  aware of what this limit is. I tried this function with up to one meg
'  of data with no problems - the functions encrypts it nearly instantly
'  on my P166mmx machine.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function crCrypt( sInput As String, sOutput As String, _
                  sPassword As String, IsInputEncrypted As Long) As Long

   Dim iStatus As Long
   Dim iLen As Long
   Dim iReturn As Long
   Dim hProv As Long
   Dim hHash As Long
   Dim hKey As Long
   Dim zPassword As Asciiz * 400

   iStatus = %True
   hProv = crGetDefaultRSAHandle

   '- Setup for encryption
   If hProv = 0 Then
      iStatus = %False
   Else

      '- Create a hash object
      If CryptCreateHash(hProv, %CALG_MD5, 0, 0, hHash) = %False Then
         iStatus = %False
      Else

         '- Hash in the password
         zPassword = sPassword
         If CryptHashData(hHash, zPassword, Len(sPassword), 0) = %False Then
            iStatus = %False
         Else

            '- Get the session key from the hash object
            If CryptDeriveKey(hProv, %CALG_RC4, hHash, %CRYPT_EXPORTABLE, hKey) = %False Then
               iStatus = %False

            End If      ' CryptDriveKey
         End If         ' CryptHashData
      End If            ' CryptCreateHash
   End If               ' hProv = 0

   '- Destroy the hash
   If hHash Then CryptDestroyHash hHash

   '- Now do the encryption
   If iStatus Then
      sOutput = sInput
      iLen = Len(sOutput)
      If IsInputEncrypted Then
         iReturn = CryptDecrypt(hKey, 0, %True, 0, ByVal StrPtr(sOutput), iLen)
      Else
         iReturn = CryptEncrypt (hKey, 0, %True, 0, ByVal StrPtr(sOutput), iLen, iLen)
      End If

      If iReturn = %False Then
         iStatus = %False
      Else
         iStatus = %True
      End If
   End If

   '- Destroy key and release handle
   If hKey Then CryptDestroyKey hKey
   If hProv Then CryptReleaseContext hProv, 0

   Function = iStatus

End Function

'
'  creStringToString
'  This function takes an un-encrypted string (sInput) and encrypts it
'  against the password. The encrypted result is returned in sOutput.
'  It returns %True on success or %False on failure.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function creStringToString(sInput As String, sOutput As String, sPassword As String) As Long

   Function = crCrypt(sInput, sOutput, sPassword, %False)

End Function

'
'  crdStringToString
'  This function takes an encrypted string and decrypts it with the given
'  password. The un-encrypted result is returned in sDec. It returns
'  %True on success or %False on failure.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function crdStringToString(sEnc As String, sDec As String, sPassword As String) As Long

   Function = crCrypt(sEnc, sDec, sPassword, %True)

End Function

'
'  crFileToFile
'  Usually I don't call this directly (use creFileToFile or crdFileToFile
'  instead). It takes two files and a password. If IsInputEncrypted is
'  non-zero, it decrypts the inFile and stores the result in outFile.
'  if IsInputEncrypt is non-zero, it decrypts the input file and
'  stores the result in the outFile.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function crFileToFile( inFile As String, outFile As String, sPassword As String, IsInputEncrypted As Long) As Long

   Dim iResult As Long
   Dim hIn As Long
   Dim hOut As Long
   Dim sInput As String
   Dim sOutput As String

   '- The input file MUST exist and the output file MUST NOT exist
   If (Dir$(outFile) <> "") Or (Dir$(inFile) = "") Then
      Function = %False
      Exit Function
   End If

   '- Open the input
   On Error Resume Next
   hIn = FreeFile
   Open inFile For Binary Shared As #hIn
   If Err Then
      Function = %False
      Exit Function
   End If

   '- Read the input file into a string
   sInput = Space$(Lof(hIn))
   Get #hIn,, sInput
   Close #hIn
   If Err Then
      Function = %False
      Exit Function
   End If

   '- Open the output file
   hOut = FreeFile
   Open outFile For Binary As #hOut
   If Err Then
      Function = %False
      Exit Function
   End If

   If IsInputEncrypted = %False Then
      iResult = creStringToString(sInput, sOutput, sPassword)
   Else
      iResult = crdStringToString(sInput, sOutput, sPassword)
   End If

   '- Encrypt the file's data
   If iResult = %False Then
      Close #hOut
      Function = %False
      Exit Function
   Else

      '- Store out the encrypted data
      Put #hOut,, sOutput
      If Err Then
         Function = %False
      Else
         Function = %True
      End If
      Close #hOut
   End If

End Function

'
'  creFileToFile
'  Reads a file (un-encrypted), encrypts it against the provided password,
'  and stores the encrypted result in outFile.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function creFileToFile(inFile As String, outFile As String, sPassword As String) As Long

   Function = crFileToFile(inFile, outFile, sPassword, %False)

End Function

'
'  crdFileToFile
'  Decrypts the encrypted inFile and puts the decrypted information in
'  outFile. Returns %True if successful, %False if not.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function crdFileToFile(inFile As String, outFile As String, sPassword As String) As Long

   Function = crFileToFile(inFile, outFile, sPassword, %True)

End Function

'
'  creStringToFile
'  Takes an unencrypted string, encrypts it and stores it in the file
'  specified. Returns %True if successful, %False if not.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function creStringToFile(sToEncrypt As String, outFile As String, sPassword As String) As Long

   Dim hOut As Long
   Dim sOutput As String

   '- The output file MUST NOT exist
   If Dir$(outFile) <> "" Then
      Function = %False
      Exit Function
   End If

   '- Open the output file
   On Error Resume Next
   hOut = FreeFile
   Open outFile For Binary As #hOut
   If Err Then
      Function = %False
      Exit Function
   End If

   '- Do the encryption
   If creStringToString(sToEncrypt, sOutput, sPassword) = %False Then
      Function  = %False
      Exit Function
   End If

   '- Write out the encrypted data
   Put #hOut,, sOutput
   If Err Then
      Function = %False
   Else
      Function = %True
   End If
   Close #hOut

End Function

'
'  crdFileToString
'  Opens the given encrypted file, decrypts it using the given
'  password and returns its result in sDec. Returns %True
'  if successful or %False if not.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function crdFileToString(inFile As String, sDec As String, sPassword As String) As Long

   Dim hIn As Long
   Dim sInput As String

   '- The input file MUST exist
   If Dir$(inFile) = "" Then
      Function = %False
      Exit Function
   End If

   '- Open the input file
   On Error Resume Next
   hIn = FreeFile
   Open inFile For Binary As #hIn
   If Err Then
      Function = %False
      Exit Function
   ElseIf Lof(hIn) = 0 Then
      Function = %False
      Exit Function
   End If

   '- Read the input file
   sInput = Space$(Lof(hIn))
   Get #hIn,, sInput

   '- Decrypt the input
   If Err Then
      Function = %False
   ElseIf crdStringToString(sInput, sDec, sPassword) = %False Then
      Function  = %False
   Else
      Function = %True
   End If

   Close #hIn

End Function

'
'  test_sub
'  some sample code
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub test_sub

   Dim hProv As Long
   Dim zData As Asciiz * 1000
   Dim dwLen As Dword

   '- Get handle to the default RSA provider
   hProv = crGetDefaultRSAHandle
   If IsFalse(hProv) Then
      MsgBox "Unable to obtain handle to default RSA provider"
      Exit Sub
   End If

   '- Display the name
   dwLen = SizeOf(zData)
   If CryptGetProvParam(hProv, %PP_NAME, zData, dwLen, 0) = %False Then
      MsgBox "Error reading CSP name:" + Str$(GetLastError())
      Exit Sub
   End If
   MsgBox "Provider name is " + zData

   '- Release the handle to the default RSA provider
   If CryptReleaseContext(hProv, 0) = %False Then
      MsgBox "Error releasing context:" + Str$(GetLastError())
   End If

End Sub