How To Create a Multipart SMIME Signature by Using CAPICOM and CDO (318215)

MORE INFORMATION

Create a Multipart Signed Message

1. Start with a CDOSYS or CDOEx IMessage object. Configure this message with sender, recipient, subject, attachments, and other elements of the message. (With some programs, such as BizTalk Server, you do not need to do this.)
2. Make the content type multipart/signed.
3. Add the first BodyPart object to the message.
4. Set content type to text/plain, and then add the file contents to the first decoded stream of the BodyPart object.
5. Sign the first BodyPart stream using CAPICOM.
6. Add a second BodyPart to the message object.
7. Set content type to application/pkcs7-signature, and then set the Content-Transfer-Encoding to base64.
8. Get the encoded stream of the second BodyPart, and then add the signed message from step 5.
9. Get all of the message object's stream.

Sample Code

Public Function CreateSignature(szFileToSign As String, szCertName As String) As String
Dim iMsg As New CDO.Message
Dim Flds As ADODB.Fields
Dim MsgToSign As String

' You can add the following lines to create a
' multipart/signed e-mail that Outlook Express can
' verify. Just save as an .eml file.
'  With iMsg
'    .To = """You""<You@dot.com>"
'    .From = """Me"" <Me@dot.com>"
'    .subject = "Here is a signed message"
'  End With ' iMsg
   
   Dim iBp As CDO.IBodyPart
   Dim iBp2 As CDO.IBodyPart

   Set iBp = iMsg   '  get IBodyPart on Message object

   ' Set up main header.
   ' This will be a multipart/signed signature.
   Set Flds = iBp.Fields
   iMsg.MimeFormatted = True
   Flds("urn:schemas:mailheader:content-type") = "multipart/signed; protocol=application/pkcs7-signature; micalg=SHA1"
   Flds("urn:schemas:mailheader:thread-index") = ""
   Flds("urn:schemas:mailheader:priority") = ""
   Flds("urn:schemas:mailheader:importance") = ""
   Flds("urn:schemas:mailheader:content-class") = ""
   Flds.Update

   ' Setup the first body part; this is the header
   ' plus the file contents.
   Set iBp2 = iBp.AddBodyPart
   Set Flds = iBp2.Fields
   Flds("urn:schemas:httpmail:content-media-type") = "text/plain"
   Flds("urn:schemas:mailheader:content-type") = "text/plain; charset=UTF-8"
   Flds("urn:schemas:mailheader:content-class") = "urn:content-classes:message"
   Flds("urn:schemas:mailheader:content-transfer-encoding") = "7bit"
   Flds.Update

   Dim Stm As ADODB.Stream
   Dim StrBase64 As String
   
   ' Make sure you have the file name and the certificate name.
   If (szFileToSign = "") Then
      MsgBox "Please enter file name to sign.", , "More Info Needed"
      Exit Function
   End If
   
   If (szCertName = "") Then
      MsgBox "Please Enter Certificate name.", , "More Info Needed"
      Exit Function
   End If
   
   ' Load the contents of the file that is to be signed.
   MsgToSign = LoadFile(szFileToSign)
   
   ' Get the decoded stream and add the contents of the file to the stream.
   Set Stm = iBp2.GetDecodedContentStream
   Stm.WriteText MsgToSign
   Stm.Flush
   
   ' Pass in the full stream (header and content) and sign it.
   StrBase64 = SignMessage(szCertName, iBp2.GetStream.ReadText)
   If StrBase64 = "" Then Exit Function
   
   ' Set up the second body part; this is header plus signed content.
   Set iBp2 = iBp.AddBodyPart
   Set Flds = iBp2.Fields
   Flds("urn:schemas:mailheader:content-type") = "application/pkcs7-signature; Name = smime.p7s"
   Flds("urn:schemas:mailheader:content-transfer-encoding") = "base64"
   Flds("urn:schemas:mailheader:content-Disposition") = "attachment; FileName = smime.p7s"
   Flds.Update

   ' Get the encoded stream and add the signed message to the stream.
   Set Stm = iBp2.GetEncodedContentStream
   Stm.Type = adTypeBinary
   Dim a() As Byte
   a = StrConv(StrBase64, vbFromUnicode)
    
   Stm.Write a
   Stm.Flush

   ' Get the whole SMIME message.
   CreateSignature = iMsg.GetStream.ReadText
   
End Function

Public Function SignMessage(szCertName As String, msg As String) As String
       Dim oSignedData As New CAPICOM.SignedData
       Dim strData As String
       Dim strContent As String
       Dim oSigner As New CAPICOM.Signer
       Dim oCert As CAPICOM.Certificate
       Dim oAttr As New CAPICOM.Attribute
       Dim byteData() As Byte
       
       On Error GoTo handle_error
                      
       ' Get certificate.
       Set oCert = GetCertForSignature(szCertName)
       
       ' If no certificate, throw an error and then exit.
       If oCert Is Nothing Then
           MsgBox "No valid certificate found for sender.", , "Error"
           SignMessage = ""
           Exit Function
       End If
       
       ' Add certificate to signer object.
       oSigner.Certificate = oCert
       
       ' Add signing time attribute to signer object.
       oAttr.Name = CAPICOM_AUTHENTICATED_ATTRIBUTE_SIGNING_TIME
       oAttr.Value = Now
       oSigner.AuthenticatedAttributes.Add oAttr

       ' Sign the content (root bodypart).
       strContent = msg
       oSignedData.Content = StrConv(strContent, vbFromUnicode)

       ' True implies detached signature.
       strData = oSignedData.Sign(oSigner, True, CAPICOM_ENCODE_BASE64)
       
       SignMessage = strData
       GoTo cleanup
       
       ' Report error.
handle_error:
       MsgBox Err.Number & ": " & Err.Description, , "Error:"
       SignMessage = ""
       Exit Function
       
       ' Clean up memory.
cleanup:
       Set oSignedData = Nothing
       Set oSigner = Nothing
       Set oCert = Nothing
       Set oAttr = Nothing
End Function

Public Function GetCertForSignature(subject As String) As CAPICOM.Certificate
    
    Dim cert As CAPICOM.Certificate
    Dim st As New CAPICOM.Store
    
    st.Open CAPICOM_CURRENT_USER_STORE, "My", CAPICOM_STORE_OPEN_READ_ONLY
    
    For Each cert In st.Certificates
    
        If (cert.IsValid) And _
           (StrComp(cert.GetInfo(CAPICOM_CERT_INFO_SUBJECT_SIMPLE_NAME), subject, vbTextCompare) = 0) And _
           (cert.KeyUsage.IsDigitalSignatureEnabled) Then
                    
            Set GetCertForSignature = cert
            Exit Function
        End If
    Next
    
    Set GetCertForSignature = Nothing
End Function

Public Function LoadFile(ByVal filename As String) As String
    Dim s As String
    Dim buffer As String

    Open filename For Binary As #1
    buffer = String(LOF(1), " ")
    Get #1, , buffer
    LoadFile = buffer
    Close #1
End Function

Public Sub SaveFile(ByVal filename As String, strData As String)
    ReDim Data(Len(strData)) As Byte
    Data = StrConv(strData, vbFromUnicode)
    Open filename For Binary As #1
    Put #1, , Data
    Close #1
End Sub