Solved

PGP and VB

Posted on 2002-05-07
8
1,017 Views
Last Modified: 2008-01-17
I'm needing a way to encrypt a flat (text based) file for FTP transmittion with PGP.

Is there a component that I can use to encrypt these files with our PGP key and then decrypt recieving files with the senders PGP key.

The application is a banking application B2B where I am sending files to the banks FTP server and then picking up response files from their server.  The Banks require that the files are encrypted with PGP.  We have parntered with a large number of banks and will be adding more as time progresses so this needs to be automated.

Any suggestions, advice, direction most welcome.
0
Comment
Question by:raizon
8 Comments
 
LVL 1

Expert Comment

by:delloro
ID: 6995562
You can use the Microsoft Cryptography API, depending on which versions of Windows and Internet Explorer you have loaded up.


There is a good book on this which will answer this question and talk about the topic: Developing Secure Applications with Visual Basic-SAMS

Here is some source code to Encrypt a string/file with
visual basic. If you wanted to encrypt an entire file, you could uuencode it and uudecode it and use this function.

I can provide other samples if u want.

'-----------------------------------------
'Encryption Module BAS MODULE
'-----------------------------------------

 Function Encrypt(sInBuffer As String) As String
    Dim csCrypt As New clsCrypto
   
    If Len(sInBuffer) = 0 Or sInBuffer = Chr(0) Then
      Encrypt = ""
      Exit Function
    End If
   
    csCrypt.Password = StrReverse("xyzzy")
    csCrypt.InBuffer = sInBuffer
    If Not csCrypt.GeneratePasswordKey Then _
        Exit Function
    If Not csCrypt.EncryptMessageData Then _
        Exit Function
    csCrypt.DestroySessionKey
    Encrypt = csCrypt.OutBuffer
End Function
 



 Function Decrypt(sInBuffer As String) As String
    Dim csCrypt As New clsCrypto
    If Len(sInBuffer) = 0 Or sInBuffer = Chr(0) Then
      Decrypt = ""
      Exit Function
    End If
    csCrypt.Password = StrReverse("xyzzy")
    csCrypt.InBuffer = sInBuffer
    If Not csCrypt.GeneratePasswordKey Then _
        Exit Function
    If Not csCrypt.DecryptMessageData Then _
        Exit Function
    csCrypt.DestroySessionKey
    Decrypt = csCrypt.OutBuffer
End Function
 
 


 
 
------------------------------------
'Encryption Module CLASS MODULE
 
Option Explicit
 

'
' Algorithm IDs and Flags
'
 
' Algorithm classes
Private Const ALG_CLASS_ANY = 0
Private Const ALG_CLASS_SIGNATURE = 8192
Private Const ALG_CLASS_MSG_ENCRYPT = 16384
Private Const ALG_CLASS_DATA_ENCRYPT = 24576
Private Const ALG_CLASS_HASH = 32768
Private Const ALG_CLASS_KEY_EXCHANGE = 40960
 
' Algorithm types
Private Const ALG_TYPE_ANY = 0
Private Const ALG_TYPE_DSS = 512
Private Const ALG_TYPE_RSA = 1024
Private Const ALG_TYPE_BLOCK = 1536
Private Const ALG_TYPE_STREAM = 2048
Private Const ALG_TYPE_DH = 2560
Private Const ALG_TYPE_SECURECHANNEL = 3072
 
' RC2 sub-ids
Private Const ALG_SID_RC2 = 2
 
' Stream cipher sub-ids
Private Const ALG_SID_RC4 = 1
Private Const ALG_SID_SEAL = 2
 
' Diffie-Hellman sub-ids
Private Const ALG_SID_DH_SANDF = 1
Private Const ALG_SID_DH_EPHEM = 2
Private Const ALG_SID_AGREED_KEY_ANY = 3
Private Const ALG_SID_KEA = 4
 
' Hash sub ids
Private Const ALG_SID_MD2 = 1
Private Const ALG_SID_MD4 = 2
Private Const ALG_SID_MD5 = 3
Private Const ALG_SID_SHA = 4
Private Const ALG_SID_SHA1 = 4
Private Const ALG_SID_MAC = 5
Private Const ALG_SID_RIPEMD = 6
Private Const ALG_SID_RIPEMD160 = 7
Private Const ALG_SID_SSL3SHAMD5 = 8
Private Const ALG_SID_HMAC = 9
 
' algorithm identifier definitions
Private Const CALG_MD5 = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
Private Const CALG_RC2 = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK) Or ALG_SID_RC2)
 
' dwFlags definitions for CryptAcquireContext
Private Const CRYPT_VERIFYCONTEXT = &HF0000000
Private Const CRYPT_NEWKEYSET = &H8
Private Const CRYPT_DELETEKEYSET = &H10
Private Const CRYPT_MACHINE_KEYSET = &H20
 
' dwFlag definitions for CryptGenKey
Private Const CRYPT_EXPORTABLE = &H1
Private Const CRYPT_USER_PROTECTED = &H2
Private Const CRYPT_CREATE_SALT = &H4
Private Const CRYPT_UPDATE_KEY = &H8
Private Const CRYPT_NO_SALT = &H10
Private Const CRYPT_PREGEN = &H40
Private Const CRYPT_RECIPIENT = &H10
Private Const CRYPT_INITIATOR = &H40
Private Const CRYPT_ONLINE = &H80
Private Const CRYPT_SF = &H100
Private Const CRYPT_CREATE_IV = &H200
Private Const CRYPT_KEK = &H400
Private Const CRYPT_DATA_KEY = &H800
 
' dwFlags definitions for CryptDeriveKey
Private Const CRYPT_SERVER = &H400
 
Private Const KEY_LENGTH_MASK = &HFFFF0000
 
' dwFlag definitions for CryptSetProviderEx and CryptGetDefaultProvider
Private Const CRYPT_MACHINE_DEFAULT = &H1
Private Const CRYPT_USER_DEFAULT = &H2
Private Const CRYPT_DELETE_DEFAULT = &H4
 
'
' CryptSetProvParam
'
Private Const PROV_RSA_FULL = 1
Private Const PROV_RSA_SIG = 2
Private Const PROV_DSS = 3
Private Const PROV_FORTEZZA = 4
Private Const PROV_MS_EXCHANGE = 5
Private Const PROV_SSL = 6
Private Const PROV_RSA_SCHANNEL = 12
Private Const PROV_DSS_DH = 13
Private Const PROV_EC_ECDSA_SIG = 14
Private Const PROV_EC_ECNRA_SIG = 15
Private Const PROV_EC_ECDSA_FULL = 16
Private Const PROV_EC_ECNRA_FULL = 17
Private Const PROV_SPYRUS_LYNKS = 20
 
'
' Provider friendly names
'
Private Const MS_DEF_PROV = "Microsoft Base Cryptographic Provider v1.0"
Private Const MS_ENHANCED_PROV = "Microsoft Enhanced Cryptographic Provider v1.0"
Private Const MS_DEF_RSA_SIG_PROV = "Microsoft RSA Signature Cryptographic Provider"
Private Const MS_DEF_RSA_SCHANNEL_PROV = "Microsoft Base RSA SChannel Cryptographic Provider"
Private Const MS_ENHANCED_RSA_SCHANNEL_PROV = "Microsoft Enhanced RSA SChannel Cryptographic Provider"
Private Const MS_DEF_DSS_PROV = "Microsoft Base DSS Cryptographic Provider"
Private Const MS_DEF_DSS_DH_PROV = "Microsoft Base DSS and Diffie-Hellman Cryptographic Provider"
 

'--- WinCrypt API Declarations
Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" ( _
    phProv As Long, _
    ByVal pszContainer As String, _
    ByVal pszProvider As String, _
    ByVal dwProvType As Long, _
    ByVal dwFlags As Long) As Long
 
Private Declare Function CryptReleaseContext Lib "advapi32.dll" ( _
    ByVal hProv As Long, _
    ByVal dwFlags As Long) As Long
 
Private Declare Function CryptDeriveKey Lib "advapi32.dll" ( _
    ByVal hProv As Long, _
    ByVal Algid As Long, _
    ByVal hBaseData As Long, _
    ByVal dwFlags As Long, _
    phKey As Long) As Long
 
Private Declare Function CryptDestroyKey Lib "advapi32.dll" ( _
    ByVal hKey As Long) As Long
 
Private Declare Function CryptEncrypt Lib "advapi32.dll" ( _
    ByVal hKey As Long, _
    ByVal hHash As Long, _
    ByVal Final As Long, _
    ByVal dwFlags As Long, _
    ByVal pbData As String, _
    pdwDataLen As Long, _
    ByVal dwBufLen As Long) As Long
 
Private Declare Function CryptDecrypt Lib "advapi32.dll" ( _
    ByVal hKey As Long, _
    ByVal hHash As Long, _
    ByVal Final As Long, _
    ByVal dwFlags As Long, _
    ByVal pbData As String, _
    pdwDataLen As Long) As Long
 
Private Declare Function CryptCreateHash Lib "advapi32.dll" ( _
    ByVal hProv As Long, _
    ByVal Algid As Long, _
    ByVal hKey As Long, _
    ByVal dwFlags As Long, _
    phHash As Long) As Long
 
Private Declare Function CryptHashData Lib "advapi32.dll" ( _
    ByVal hHash As Long, _
    ByVal pbData As String, _
    ByVal dwDataLen As Long, _
    ByVal dwFlags As Long) As Long
 
Private Declare Function CryptDestroyHash Lib "advapi32.dll" ( _
    ByVal hHash As Long) As Long
 
'constants from WinErr.h
Private Const ERROR_INVALID_HANDLE As Long = 6
Private Const ERROR_INVALID_PARAMETER As Long = 87
Private Const NTE_BAD_KEY As Long = &H80090003
Private Const NTE_BAD_UID As Long = &H80090001
Private Const NTE_NO_KEY As Long = &H8009000D
Private Const NTE_BAD_SIGNATURE As Long = &H80090006
 
' Private property buffers
Private m_sPassword As String   ' Password used to create encryption key
 
Private m_sInBuffer As String   ' Used as an input buffer for all
                                ' data to be encrypted or decrypted
 
Private m_sOutBuffer As String  ' Used as an output buffer for all
                                ' data that has been encrypted or decrypted
 
Private m_sErrorMsg As String   ' Error message string
 
' Private class-level variables
Private m_lHCryptProv As Long   ' Handle for the cryptographic
                                ' service provider (CSP)
 
Private m_lHSessionKey As Long  ' Session key for encrypting and
                                ' decrypting data
 
Public Property Get InBuffer() As String
    InBuffer = m_sInBuffer
End Property
 
Public Property Let InBuffer(vNewValue As String)
    m_sInBuffer = vNewValue
End Property
 
Public Property Get OutBuffer() As String
    OutBuffer = m_sOutBuffer
End Property
 
Public Property Get ErrorMsg() As String
    ErrorMsg = m_sErrorMsg
End Property
 
Private Sub Class_Initialize()
 
    If Not InitUser Then
        m_sErrorMsg = "Unable to initialize CryptoAPI."
        MsgBox m_sErrorMsg, vbOKOnly, "VB Crypto"
    End If
End Sub
 
Private Function InitUser() As Boolean
 
On Error Resume Next
    InitUser = False
   
    Dim lDataSize As Long
   
    Dim lResult As Long
    Dim sResult As String
    Dim sContainer As String
    Dim sProvider As String
   
    '--- Prepare string buffers
    sContainer = vbNullChar
    sProvider = MS_DEF_PROV & vbNullChar
   
    '--- Attempt to acquire a handle to the default key container.
    If Not CBool(CryptAcquireContext(m_lHCryptProv, sContainer, sProvider, PROV_RSA_FULL, 0)) Then
   
        '--- Create default key container.
        If Not CBool(CryptAcquireContext(m_lHCryptProv, sContainer, sProvider, PROV_RSA_FULL, CRYPT_NEWKEYSET)) Then
            m_sErrorMsg = "Error creating key container - " & CStr(Err.LastDllError)
            MsgBox m_sErrorMsg, vbOKOnly, "VB Crypto"
           
            Exit Function
        End If
       
    End If
   
    '--- Didn't exit early, return TRUE
    InitUser = True
 
    Exit Function
   
End Function
 
Private Sub Class_Terminate()
 
    Dim lResult As Long
   
    '--- Do we have an open key context? If so, release it.
    If (m_lHCryptProv <> 0) Then lResult = CryptReleaseContext(m_lHCryptProv, 0)
End Sub
 
Public Function GeneratePasswordKey() As Boolean
 
On Error Resume Next
    Dim lHash As Long
    Dim lResult As Long
   
    GeneratePasswordKey = False
   
    '--- Create an empty hash object.
    If Not CBool(CryptCreateHash(m_lHCryptProv, CALG_MD5, 0, 0, lHash)) Then
        m_sErrorMsg = "Error " & CStr(Err.LastDllError) & " during CryptCreateHash!"
        Err.Raise vbObjectError + 1, "DiscMove", "NoCreateEmptyHash:" & m_sErrorMsg
        Exit Function
    End If
   
    '--- Hash the password string.
    If Not CBool(CryptHashData(lHash, m_sPassword, Len(m_sPassword), 0)) Then
        m_sErrorMsg = "Error " & CStr(Err.LastDllError) & " during CryptHashData!"
        Err.Raise vbObjectError + 2, "DiscMove", "NoCreateHash:" & m_sErrorMsg
        Exit Function
    End If
   
    '--- Create a derived block cipher session key.
    If Not CBool(CryptDeriveKey(m_lHCryptProv, CALG_RC2, lHash, 0, m_lHSessionKey)) Then
        m_sErrorMsg = "Error " & CStr(Err.LastDllError) & " during CryptDeriveKey!"
        Err.Raise vbObjectError + 3, "DiscMove", "NoKey:" & m_sErrorMsg
        Exit Function
    End If
   
    '--- Destroy the hash object
    If Not CBool(CryptDestroyHash(lHash)) Then
        m_sErrorMsg = "Error " & CStr(Err.LastDllError) & " during CryptDestroyHash!"
        Err.Raise vbObjectError + 4, "DiscMove", "NoDestHash:" & m_sErrorMsg
        Exit Function
    End If
   
    GeneratePasswordKey = True
End Function
 

Public Property Get Password() As String
    Password = m_sPassword
End Property
 

Public Property Let Password(ByVal sNewValue As String)
    m_sPassword = sNewValue
End Property
 

Public Function EncryptMessageData()
 
On Error Resume Next
    EncryptMessageData = False
 
    Dim lDataSize As Long
    Dim lResult As Long
    Dim sCryptBuffer As String
    Dim lCryptLength As Long
    Dim lCryptBufLen As Long
 
    '--- Determine the size of the buffer needed for encrypting the data
    '--- in the InBuffer property
    lCryptLength = Len(m_sInBuffer)
    lResult = CryptEncrypt(m_lHSessionKey, 0, 1, 0, vbNullString, lCryptLength, lCryptBufLen)
   
    '--- Prepare a string buffer for the CryptEncrypt function
    lCryptBufLen = lCryptLength * 2
    lCryptLength = Len(m_sInBuffer)
    sCryptBuffer = String(lCryptBufLen, vbNullChar)
   
    '--- Copy in the contents of the InBuffer property
    LSet sCryptBuffer = m_sInBuffer
 
    '--- Encrypt data
    If Not CBool(CryptEncrypt(m_lHSessionKey, 0, 1, 0, sCryptBuffer, lCryptLength, lCryptBufLen)) Then
       
        m_sErrorMsg = "Error " & CStr(Err.LastDllError) & " during CryptEncrypt!"
        MsgBox m_sErrorMsg, vbOKOnly, "VB Crypto"
       
        Exit Function
    End If
 
    '--- Copy the encrypted data to the OutBuffer property
    m_sOutBuffer = Mid$(sCryptBuffer, 1, lCryptLength)
 
    EncryptMessageData = True
End Function
 
Public Function DestroySessionKey() As Boolean
 
    Dim lResult As Long
   
    DestroySessionKey = False
   
    '--- Destroy the session key
    If Not CBool(CryptDestroyKey(m_lHSessionKey)) Then
        m_sErrorMsg = "Error " & CStr(Err.LastDllError) & " during CryptDestroyKey!"
        MsgBox m_sErrorMsg, vbOKOnly, "VB Crypto"
       
        Exit Function
    End If
   
   
    DestroySessionKey = True
End Function
 

Public Function DecryptMessageData() As Boolean
 
On Error Resume Next
    DecryptMessageData = False
 
    Dim lDataSize As Long
    Dim lResult As Long
    Dim sCryptBuffer As String
    Dim lCryptLength As Long
    Dim lCryptBufLen As Long
 
    '--- Prepare sCryptBuffer for CryptDecrypt
    lCryptBufLen = Len(m_sInBuffer)
    sCryptBuffer = String(lCryptBufLen, vbNullChar)
    LSet sCryptBuffer = m_sInBuffer
   
    '--- Decrypt data
    If Not CBool(CryptDecrypt(m_lHSessionKey, 0, 1, 0, sCryptBuffer, lCryptBufLen)) Then
        m_sErrorMsg = "Error " & CStr(Err.LastDllError) & " during CryptDecrypt!"
        MsgBox m_sErrorMsg, vbOKOnly, "VB Crypto"
       
        Exit Function
    End If
   
    '--- Apply decrypted string from sCryptBuffer to private buffer for OutBuffer property
    m_sOutBuffer = Mid$(sCryptBuffer, 1, lCryptBufLen)
   
    '--- Didn't exit early, return TRUE
    DecryptMessageData = True
End Function
 

 
0
 
LVL 45

Accepted Solution

by:
aikimark earned 100 total points
ID: 6995569
0
 
LVL 5

Author Comment

by:raizon
ID: 6996577
delloro,

nice code.

Question, with this can decrypt the files recieved back from the bank with the banks public key that they provide?
0
 
LVL 45

Expert Comment

by:aikimark
ID: 6996782
raizon,

I thought you needed PGP encryption?
0
IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 5

Author Comment

by:raizon
ID: 6996905
I do


having looked at this more it doesn't look like it does PGP encryption.

I'm going through the links you provided for me now aikimark.

0
 
LVL 5

Author Comment

by:raizon
ID: 6997656
http://community.wow.net/grt/nsdpgp.html

has a com wrapper that will do just exactly what I need.

Thanks for the help guys.
0
 

Expert Comment

by:Zelja
ID: 7283762
Hallo.
I also have problem with this..
well on my workstation win 2000 mashine this all works well.
As I try to install pgp freeware on win2000 server it does not work, message I get is "can not run under this environment".
Does any one has a solution for this com object (nsdpgp2.dll) that works??
regards
Zeljko Kvesic
0
 
LVL 45

Expert Comment

by:aikimark
ID: 7283904
Zeljko,

Since this question is closed, you should only expect and answer to the new question you asked in the VB area.
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Introduction In a recent article (http://www.experts-exchange.com/A_7811-A-Better-Concatenate-Function.html) for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now