署名されたメッセージ CDOSYS/CDOEX によるデジタルに送信する方法

'******************************************************************
'
' SignMessage
'
' Takes oMsg as input (non-secure message) and returns a new
' message that is digitally signed.
'
'******************************************************************
Public Function SignMessage(oMsg As CDO.Message) As CDO.Message
    Dim oSecMsg As New CDO.Message
    Dim oBodyPart As CDO.IBodyPart
    Dim oSignedData As New CAPICOM.SignedData
    Dim strData As String
    Dim strContent As String
    Dim oStream As ADODB.Stream
    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
    
    ' Copy input into output message
    oSecMsg.DataSource.OpenObject oMsg, cdoIMessage
    
    ' Set up main bodypart
    Set oBodyPart = oSecMsg.BodyPart
    oBodyPart.ContentMediaType = "application/pkcs7-mime;smime-type=signed-data;name=""smime.p7m"""
    oBodyPart.ContentTransferEncoding = "base64"
    oBodyPart.Fields("urn:schemas:mailheader:content-disposition") = "attachment;FileName=""smime.p7m"""
    oBodyPart.Fields.Update
            
    ' Get certificate
    Set oCert = GetCertForSignature(oSecMsg.From)
    
    ' If no cert, throw an error and exit
    If oCert Is Nothing Then
        MsgBox "No valid certificate found for sender.", , "Error"
        Set SignMessage = Nothing
    End If
    
    ' Add cert 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 = oMsg.BodyPart.GetStream.ReadText
    oSignedData.Content = StrConv(strContent, vbFromUnicode)

    strData = oSignedData.Sign(oSigner, False, CAPICOM_ENCODE_BINARY)

    ' Write the cms blob into the main bodypart
    ' let CDO do the base64 encoding
    Set oStream = oSecMsg.BodyPart.GetDecodedContentStream
    
    oStream.Type = adTypeBinary

    ' Get the string data as a byte array
    byteData = strData
    
    ' Write the data to the stream and flush it
    oStream.Write byteData
    oStream.Flush
    
    GoTo cleanup
    
    ' Report error
handle_error:
    MsgBox Err.Number & ": " & Err.Description, , "Error:"
    Set oSecMsg = Nothing
    
    ' Clean up memory
cleanup:
    Set oBodyPart = Nothing
    Set oSignedData = Nothing
    Set oStream = Nothing
    Set oSigner = Nothing
    Set oCert = Nothing
    Set oAttr = Nothing
    
    ' Return new message
    Set SignMessage = oSecMsg
End Function

'******************************************************************
'
' EnvelopeMessage
'
' Takes oMsg as input (non-secure message) and returns a new
' message that is enveloped.
'
'******************************************************************
Public Function EnvelopeMessage(oMsg As CDO.Message, iCertStore As Integer, Optional strQuery As String) As CDO.Message
    Dim oSecMsg As New CDO.Message
    Dim oBodyPart As CDO.IBodyPart
    Dim oEnvelopedData As New CAPICOM.EnvelopedData
    Dim oCert As CAPICOM.Certificate
    Dim oStream As ADODB.Stream
    Dim strData As String
    Dim strContent As String
    Dim byteData() As Byte
    
    ' Copy input into output message
    oSecMsg.DataSource.OpenObject oMsg, cdoIMessage
    
    ' Set up main bodypart
    Set oBodyPart = oSecMsg.BodyPart
    oBodyPart.ContentMediaType = "application/pkcs7-mime;smime-type=enveloped-data;name=smime.p7m;"

    oBodyPart.ContentTransferEncoding = "base64"
    oBodyPart.Fields("urn:schemas:mailheader:content-disposition") = "attachment;FileName=""smime.p7m"""
    oBodyPart.Fields.Update
    
    ' Get recipient's cert
    If strQuery = "" Then
        Set oCert = GetCertForEnvelope(oSecMsg.To, iCertStore)
    Else
        Set oCert = GetCertForEnvelope(oSecMsg.To, iCertStore, strQuery)
    End If
    
    oEnvelopedData.Recipients.Add oCert
    
    ' Encrypt content
    strContent = oMsg.BodyPart.GetStream.ReadText
    oEnvelopedData.Content = StrConv(strContent, vbFromUnicode)
    strData = oEnvelopedData.Encrypt(CAPICOM_ENCODE_BINARY)
    
    ' Write the CMS blob into the main bodypart
    ' let CDO do the base64 encoding
    Set oStream = oSecMsg.BodyPart.GetDecodedContentStream
    
    oStream.Type = adTypeBinary
    
    ' Get the string data as a byte array
    byteData = strData
    
    ' Write the data to the stream and flush it
    oStream.Write byteData
    oStream.Flush
    
    GoTo cleanup
    
handle_error:
    MsgBox Err.Number & ": " & Err.Description, , "Error:"
    Set oSecMsg = Nothing
    
    ' Clean up memory
cleanup:
    Set oBodyPart = Nothing
    Set oEnvelopedData = Nothing
    Set oStream = Nothing
    Set oCert = Nothing
    
    ' Return new message
    Set EnvelopeMessage = oSecMsg
End Function