Darin Creason's Weblog

' I do not claim any responsibility for the correctness or security of this code

' and any or all portions should be used at your own risk.



Option Explicit

Const ForReading = 1, ForWriting = 2, TristateFalse = 0

Const TemporaryFolder = 2



Private Sub Command1_Click()

  SignFile "c:\temp\in.txt", "c:\temp\signed.txt"

  EnvelopeFile "c:\temp\signed.txt", "c:\temp\smime.txt"

End Sub



Sub SignFile(ByVal sInFile As String, ByVal sOutFile As String)

  ' Open the MY store and retrieve the first certificate from the

  ' store. The signing operation will only work if this certificate is

  ' valid and has access to the signer's private key.

  Dim oCertStore As New Store

  oCertStore.Open CAPICOM_CURRENT_USER_STORE, "My", CAPICOM_STORE_OPEN_READ_ONLY

  

  Dim oSigner As New signer

  ' The signer's certificate is at index 1

  oSigner.Certificate = oCertStore.Certificates.Item(1)

  Set oCertStore = Nothing

  

  ' Set the content to be signed.

  Dim oSignedData As New SignedData

  oSignedData.Content = ReadFile(sInFile)

  

  ' Save the time the data was signed as a signer attribute

  ' NOTE: the name 'Attribute' is not a unique name

  ' and must be preceded by 'CAPICOM.'

  Dim oSigningTimeAttr As New CAPICOM.Attribute

  oSigningTimeAttr.Name = CAPICOM_AUTHENTICATED_ATTRIBUTE_SIGNING_TIME

  oSigningTimeAttr.Value = Now

  oSigner.AuthenticatedAttributes.Add oSigningTimeAttr

  

  ' Sign the content using the signer's private key.

  ' A value of 'True' in the second parameter indicates that the

  ' content signed is not included in the signature string.

  ' A value of 'False' indicates that it is

  Dim s As String

  s = oSignedData.Sign(oSigner, False, CAPICOM_ENCODE_BASE64)



  ' Strip off the last blank line

  s = Mid(s, 1, Len(s) - 2)

  ' Add the PKCS #7 header and footer so that the signature conforms to what

  ' OpenSSL expects.

  s = "-----BEGIN PKCS7-----" + vbCrLf + s + vbCrLf + "-----END PKCS7-----"

  WriteFile sOutFile, s

  

  Set oSignedData = Nothing

  Set oSigner = Nothing

  Set oSigningTimeAttr = Nothing

End Sub



Sub EnvelopeFile(ByVal sInFile As String, ByVal sOutFile As String)

  ' Open the MY store and retrieve the first certificate from the

  ' store. The signing operation will only work if this certificate is

  ' valid and has access to the signer's private key.

  Dim oCertStore As New Store

  oCertStore.Open CAPICOM_CURRENT_USER_STORE, "My", CAPICOM_STORE_OPEN_READ_ONLY

  

  ' Declare and initialize an EnvelopedData object

  Dim oEnvelopedData As New EnvelopedData

  oEnvelopedData.Content = ReadFile(sInFile)

  

  ' The signer's certificate is at index 1

  ' NOTE that you can add as many recipient certs as you like.

  oEnvelopedData.Recipients.Add oCertStore.Certificates.Item(1)

  Set oCertStore = Nothing

  

  '  Set the encryption algorithm and key length. Comment out

  '  or remove the following lines to use the default algorithm

  '  and key length. The triple DES algorithm and 128 bit key

  '  length may not be supported.

  oEnvelopedData.Algorithm.Name = CAPICOM_ENCRYPTION_ALGORITHM_3DES 'or ENCRYPTION_ALGORITHM_RC4

  oEnvelopedData.Algorithm.KeyLength = CAPICOM_ENCRYPTION_KEY_LENGTH_128_BITS



  'Declare the string that will hold the enveloped message.

  Dim sEnvelopedMessage As String



  'Encrypt the message into sEnvelopedMessage. The enveloped message

  'string contains everything that an intended recipient will need to

  'decrypt the message, including information on the encryption algorithm 'key length.

  sEnvelopedMessage = oEnvelopedData.Encrypt



  ' Release the EncryptedData object and the Store object.

  Set oEnvelopedData = Nothing



  ' Add the MIME headers to the content

  Dim sMimeHeader As String

  sMimeHeader = "MIME-Version: 1.0" + vbCrLf

  sMimeHeader = sMimeHeader + "Content-Disposition: attachment; filename=""smime.p7m""" + vbCrLf

  sMimeHeader = sMimeHeader + "Content-Type: application/x-pkcs7-mime; name=""smime.p7m""" + vbCrLf

  ' these last two line feeds are important

  sMimeHeader = sMimeHeader + "Content -Transfer - Encoding: base64" + vbCrLf + vbCrLf



  sEnvelopedMessage = sMimeHeader + sEnvelopedMessage



  WriteFile sOutFile, sEnvelopedMessage

End Sub



Sub WriteFile(ByVal sFileName As String, ByVal sText As String)

  Dim oFS, oTF As Object

  Set oFS = CreateObject("Scripting.FileSystemObject")

  Set oTF = oFS.OpenTextFile(sFileName, ForWriting, True, TristateFalse)

  oTF.Write (sText)

  oTF.Close

  Set oTF = Nothing

  Set oFS = Nothing

End Sub



Function ReadFile(ByVal sFileName As String) As String

  Dim oFS, oTF As Object

  Set oFS = CreateObject("Scripting.FileSystemObject")

  Set oTF = oFS.OpenTextFile(sFileName, ForReading, False, TristateFalse)

  ReadFile = oTF.ReadAll

  oTF.Close

  Set oTF = Nothing

  Set oFS = Nothing

End Function