Public Function SignMessage(ByRef oMsg As CDO.Message) As Boolean
'    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 = oMsg.BodyPart
    oMsg.BodyPart.ContentMediaType = "application/pkcs7-mime;smime-type=signed-data;name=""smime.p7m"""
    oMsg.BodyPart.ContentTransferEncoding = "base64"
    oMsg.BodyPart.Fields("urn:schemas:mailheader:content-disposition") = "attachment;FileName=""smime.p7m"""
    oMsg.BodyPart.Fields.Update
            
    ' Get certificate
    Set oCert = GetCertForSignature("user@gmail.com") '(oSecMsg.From)

    ' If no cert, throw an error and exit
    If oCert Is Nothing Then
        MsgBox "No valid certificate found for sender.", , "Error"
        SignMessage = False
    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 = strContent ' 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 = oMsg.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

Public Function GetCertForSignature(ByVal signature As String) As CAPICOM.Certificate
  Dim MyStore As New CAPICOM.Store
  
  ' Open the MY store and retrieve the first compartible certificate from the
  ' Store. The signing operation will only work if this
  ' certificate is valid and has access to the signer's private key.
  MyStore.Open CAPICOM_CURRENT_USER_STORE, "MY", CAPICOM_STORE_OPEN_READ_ONLY
  Dim cert As CAPICOM.Certificate
  For Each cert In MyStore.Certificates
    If cert.IsValid Then
      'Debug.Print cert.SubjectName
      If InStr(cert.SubjectName, signature) > 0 Then
        Debug.Print cert.SubjectName
        Set GetCertForSignature = cert
        Exit Function
      End If
    End If
  Next

 Public Function GetCertForSignature(ByVal signature As String) As CAPICOM.Certificate
    Dim MyStore As New CAPICOM.Store

    ' Open the MY store and retrieve the first compartible certificate from the
    ' Store. The signing operation will only work if this
    ' certificate is valid and has access to the signer's private key.
    MyStore.Open(CAPICOM.CAPICOM_STORE_LOCATION.CAPICOM_CURRENT_USER_STORE, "MY", _
     CAPICOM.CAPICOM_STORE_OPEN_MODE.CAPICOM_STORE_OPEN_READ_ONLY)
    For Each cert As CAPICOM.Certificate In MyStore.Certificates
      If cert.IsValid.Result Then
        'Debug.Print cert.SubjectName
        If InStr(cert.SubjectName, signature) > 0 Then
          Debug.Print(cert.SubjectName)
          Return cert
          Exit Function
        End If
      End If
    Next
    Return Nothing
    'Signer.Certificate = MyStore.Certificates.Item(1)

  End Function

  Private Function SignMessage(ByRef Message As Object, ByVal ClearFlag As Boolean) As Boolean

    'http://www.pcreview.co.uk/threads/re-capicom-use-in-c-problem-with-verifying-email-signature.1233519/

    Dim SignedMessage As Object ' = CreateObject("CDO.Message")
    Dim BodyPart As Object 'CDO.IBodyPart
    Dim Fields As Object
    Dim Stream As ADODB.Stream
    Dim Signer As New CAPICOM.Signer
    Dim SignedData As New CAPICOM.SignedData
    Dim Utilities As New CAPICOM.Utilities
    Dim Attribute As New CAPICOM.Attribute
    Dim SignerCertificate As CAPICOM.Certificate
    Dim SignerCertificates As CAPICOM.Certificates
    Dim Store As New CAPICOM.Store
    Dim Signature As String
    Dim byteSignature() As Byte

    ' Used for Global Memory Allocation to send ANSI Text to Signer
    Dim MyGC As GCHandle

    ' Used to look up Signature Capable Certificates
    'Const CERT_KEY_SPEC_PROP_ID = 6


    'Try
    ' create the SignedData object we will use to create the PKCS7()
    SignedData = New CAPICOM.SignedData

    ' create the new message
    SignedMessage = CreateObject("CDO.Message") ' New CDO.Message

    ' select the signer certificate
    Signer.Certificate = GetCertForSignature("user@gmail.com")


    ' set the from field based off of the selected certificate
    SignedMessage.From = _
      Signer.Certificate.GetInfo(CAPICOM.CAPICOM_CERT_INFO_TYPE.CAPICOM_CERT_INFO_SUBJECT_EMAIL_NAME)

    ' Add signing time attribute to signer object
    Attribute = New CAPICOM.Attribute
    Attribute.Name = CAPICOM.CAPICOM_ATTRIBUTE.CAPICOM_AUTHENTICATED_ATTRIBUTE_SIGNING_TIME
    Attribute.Value = Now
    Signer.AuthenticatedAttributes.Add(Attribute)

    Select Case ClearFlag
      Case True

        ' this is to be a clear text signed message so we need to copy the interesting
        ' parts (sender, recipient, and subject) into the new header
        SignedMessage.To = Message.To
        SignedMessage.CC = Message.CC
        SignedMessage.Subject = Message.Subject

        BodyPart = SignedMessage.BodyPart.AddBodyPart
        Fields = BodyPart.Fields
        Fields.Item("urn:schemas:mailheader:content-type") =
         Message.BodyPart.BodyParts(1).Fields("urn:schemas:mailheader:content-type").Value
        Fields.Update()

        Stream = BodyPart.GetDecodedContentStream

        Stream.WriteText(Message.BodyPart.BodyParts(1).GetDecodedContentStream.ReadText)
        Stream.Flush()

        ' set the content to be signed
        ' This only works for words that are less than 6 bytes long - it's wierd
        'Dim bytes As Byte()
        'bytes = System.Text.Encoding.GetEncoding(1252).GetBytes(SignedMessage.BodyPart.BodyParts(1).GetStream.ReadText)
        'SignedData.Content =  System.Text.Encoding.Unicode.GetString(Bytes)
        ' -- Original VB v6 -- SignedData.Content = StrConv(SignedMessage.BodyPart.BodyParts(1).GetStream.ReadText, vbFromUnicode)
        ' See  http://support.microsoft.com/default.aspx?scid=kb;en-us;Q311338

        ' Therefore it was necessary to utilize a Custom  Designed Interop
        ' Per the instructions of:http://groups.google.com/groups?hl=...oups?hl=en&lr=&q=System.Text.Encoding+capicom

        'A byte array
        Dim Bytes() As Byte

        'Convert string to byte and copy to byte array
        Bytes = Encoding.GetEncoding(1251).GetBytes(SignedMessage.BodyPart.BodyParts(1).GetStream.ReadText)
        'Bytes = Encoding.UTF8.GetBytes(SignedMessage.BodyPart.BodyParts(1).GetStream.ReadText)

        ' Now in order to use the new Interop - it is expecting a Pointer (native int)
        ' The Runtime Interop Classes provide the ability to do this.
        ' But make sure to free memory

        'Create Gchandle instance and pin variable required
        MyGC = GCHandle.Alloc(Bytes, GCHandleType.Pinned)

        'get address of variable in pointer variable
        Dim ByteAddress As IntPtr =
        MyGC.AddrOfPinnedObject()

        ' Set the Content to be signed
        SignedData.Content = ByteAddress

        ' sign the content
        Signature = SignedData.Sign(Signer, True, CAPICOM.CAPICOM_ENCODING_TYPE.CAPICOM_ENCODE_BINARY)

        ' Get the string data as a byte array
        byteSignature = System.Text.Encoding.Unicode.GetBytes(Signature)

        ' Attach the signature and let CDO base64 encode it
        BodyPart = SignedMessage.BodyPart.AddBodyPart
        Fields = BodyPart.Fields

        'BodyPart.Fields.Item("urn:schemas:mailheader:content-type").Value = _
        ' "application/x-pkcs7-signature" & vbCrLf & "Name = ""smime.p7s"""
        BodyPart.Fields.Item("urn:schemas:mailheader:content-type").Value = _
         "application/pkcs7-mime;smime-type=signed-data;name=""smime.p7m"""

        BodyPart.Fields.Item("urn:schemas:mailheader:content-transfer-encoding").Value = "base64"

        'BodyPart.Fields.Item("urn:schemas:mailheader:content-disposition").Value _
        ' = "attachment;" & vbCrLf & "FileName=""smime.p7s"""
        BodyPart.Fields.Item("urn:schemas:mailheader:content-disposition").Value _
         = "attachment;FileName=""smime.p7m"""
        Fields.Update()

        Stream = BodyPart.GetDecodedContentStream
        Stream.Type = ADODB.StreamTypeEnum.adTypeBinary
        Stream.Write(byteSignature)
        Stream.Flush()

        ' Set the messages content type, this needs to be done last to ensure it is not changed when we add the BodyParts

        SignedMessage.Fields.Item("urn:schemas:mailheader:content-type").Value _
         = "multipart/signed;" & vbCrLf & "protocol=""application/x-pkcs7-signature"";" & _
         vbCrLf & "micalg=SHA1;"
        SignedMessage.Fields.Update()

        'Free GChandle to avoid memory leaks
        MyGC.Free()


      Case False
        ' this is to be a opaquely signed message so we need to copy the entire message into our
        ' new encrypted message
        SignedMessage.DataSource.OpenObject(Message, "IMessage")

        ' Set up main bodypart
        BodyPart = SignedMessage.BodyPart
        'BodyPart.ContentMediaType =
        '"application/pkcs7-mime;" & vbCrLf & "smime-type=signed-data;" & vbCrLf _
        ' & "name=""smime.p7m"""
        BodyPart.Fields.Item("urn:schemas:mailheader:content-type").Value = _
         "application/pkcs7-mime;smime-type=signed-data;name=""smime.p7m"""
        BodyPart.ContentTransferEncoding = "base64"
        Fields = BodyPart.Fields

        'Fields("urn:schemas:mailheader:content-disposition") = "attachment;" & _
        ' vbCrLf & "FileName=""smime.p7m"""
        Fields.Item("urn:schemas:mailheader:content-disposition").Value _
         = "attachment;FileName=""smime.p7m"""
        BodyPart.Fields.Update()

        ' set the from field based off of the selected certificate()
        Message.From = Signer.Certificate.GetInfo(CAPICOM.CAPICOM_CERT_INFO_TYPE.CAPICOM_CERT_INFO_SUBJECT_EMAIL_NAME)

        ' set the content to be signed
        ' This only works for words that are less than 6 bytes long - it's wierd
        'Dim bytes As Byte()
        'bytes = System.Text.Encoding.GetEncoding(1252).GetBytes(SignedMessage.BodyPart.BodyParts(1).GetStream.ReadText)
        'SignedData.Content =          System.Text.Encoding.Unicode.GetString(Bytes)
        ' -- Original VB v6 DIFFERENT THAN ABOVE IT USES          Message --SignedData.Content =          StrConv(SignedMessage.BodyPart.BodyParts(1).GetStream.ReadText,          vbFromUnicode)
        ' See http://support.microsoft.com/default.aspx?scid=kb;en-us;Q311338

        ' Therefore it was necessary to utilize a Custom          Designed Interop
        ' Per the instructions of:http://groups.google.com/groups?hl=...oups?hl=en&lr=&q=System.Text.Encoding+capicom

        'A byte array
        Dim Bytes() As Byte

        'Convert string to byte and copy to byte array
        Bytes = Encoding.GetEncoding(1251).GetBytes(Message.BodyPart.GetStream.ReadText)
        'Bytes = Encoding.UTF8.GetBytes(Message.BodyPart.GetStream.ReadText)

        ' Now in order to use the new Interop - it is expecting a Pointer (native int)
        ' The Runtime Interop Classes provide the ability to do this.
        ' But make sure to free memory

        'Create Gchandle instance and pin variable required
        MyGC = GCHandle.Alloc(Bytes, GCHandleType.Pinned)

        'get address of variable in pointer variable
        Dim ByteAddress As IntPtr =
        MyGC.AddrOfPinnedObject()

        ' Set the Content to be signed
        SignedData.Content = ByteAddress

        ' Sign the content
        Signature = SignedData.Sign(Signer, False, CAPICOM.CAPICOM_ENCODING_TYPE.CAPICOM_ENCODE_BINARY)

        ' Get the string data as a byte array
        byteSignature = System.Text.Encoding.Unicode.GetBytes(Signature)

        ' Attach the signature and let CDO base64 encode it
        Stream = BodyPart.GetDecodedContentStream
        Stream.Type = ADODB.StreamTypeEnum.adTypeBinary
        Stream.Write(byteSignature)
        Stream.Flush()

        'Free GChandle to avoid memory leaks
        MyGC.Free()

    End Select

    ' Signing Was sucessfull
    SignMessage = True
    Message = SignedMessage

    ' Catch ex As Exception
    'MsgBox(ex.Message, MsgBoxStyle.Critical, "Error:")

    'If Err.Number <> CAPICOM_E_CANCELLED Then
    ' MsgBox("Error: " & Hex(Err.Number) & ": " & Err.Description)
    'End If
    'Err.Clear()

    ' An error occurred
    'SignMessage = False
    'Message = Nothing


    '  Finally

    If MyGC.IsAllocated Then
      MyGC.Free()
      MyGC = Nothing
    End If

    SignedMessage = Nothing
    BodyPart = Nothing
    Fields = Nothing
    Stream = Nothing
    Signer = Nothing
    SignedData = Nothing
    Utilities = Nothing
    Attribute = Nothing
    SignerCertificate = Nothing
    SignerCertificates = Nothing
    Store = Nothing
    '   End Try

  End Function

  Public Function SignMessageClear(oMsg As CDO.Message) As CDO.Message 'CDO.Message
    Dim oSecMsg As New CDO.Message
    Dim oBodyPart As CDO.IBodyPart 'Object ' 
    Dim oBodyPart2 As CDO.IBodyPart 'Object ' 
    Dim oStream As ADODB.Stream

    On Error GoTo handle_error
    oSecMsg.To = oMsg.To
    oSecMsg.From = oMsg.From
    oSecMsg.Subject = oMsg.Subject

    oBodyPart = oSecMsg.BodyPart.AddBodyPart
    Dim data As Byte()
    '=====вариант(1), когда подписываемое сообщение multipart/mixed (и текст и вложение)
     For i As Integer = 1 To oMsg.BodyPart.BodyParts.Count
      oBodyPart2 = oBodyPart.AddBodyPart
      oStream = oMsg.BodyPart.BodyParts(i).GetStream
      oStream.Type = ADODB.StreamTypeEnum.adTypeBinary
      data = oStream.Read
      oStream.Close()
      ' Write the data to the stream and flush it
      oStream = oBodyPart2.GetStream
      oStream.Type = ADODB.StreamTypeEnum.adTypeBinary
      oStream.Write(data)
      oStream.Flush()
      oStream.Close()
    Next
    '=====вариант(1), когда подписываемое сообщение multipart/mixed (и текст и вложение)

    '=====вариант(2), когда подписываемое сообщение состоит из одной части (только текст либо только вложение)
    '=====здесь подписывает нормально
    'oStream = oMsg.BodyPart.BodyParts(1).GetStream '
    'oStream.Type = ADODB.StreamTypeEnum.adTypeBinary
    'data = oStream.Read()
    'oStream = oBodyPart.GetStream
    'oStream.Type = ADODB.StreamTypeEnum.adTypeBinary
    'oStream.Write(data)
    'oStream.Flush()
    '=====вариант(2), когда подписываемое сообщение состоит из одной части (только текст либо только вложение)


    ' Attach the signature and let CDO base64 encode it
    oBodyPart = oSecMsg.BodyPart.AddBodyPart
    oBodyPart.Fields.Item("urn:schemas:mailheader:content-type").Value = _
       "application/x-pkcs7-signature" & vbCrLf & "Name = ""smime.p7s"""
    oBodyPart.Fields.Item("urn:schemas:mailheader:content-transfer-encoding").Value = "base64"
    oBodyPart.Fields.Item("urn:schemas:mailheader:content-disposition").Value _
     = "attachment;" & vbCrLf & "FileName=""smime.p7s"""
    oBodyPart.Fields.Update()

    ' Get certificate
    Dim certificate As X509Certificate2 = _
     GetCertForSignature(New MailAddress(oMsg.From).Address, StoreLocation.LocalMachine)

    Dim strContent As String = oSecMsg.BodyPart.BodyParts(1).GetStream.ReadText
    strContent = Replace(strContent, "This is a multi-part message in MIME format." & vbCrLf, "", , 1)
    data = Encoding.GetEncoding(1252).GetBytes(strContent)
    'oStream = oSecMsg.BodyPart.BodyParts(1).GetStream
    'oStream.Type = ADODB.StreamTypeEnum.adTypeBinary
    'data = oStream.Read
    'oStream.Close()
    IO.File.WriteAllBytes("original.txt", data)
    Dim content As New ContentInfo(data)
    Dim signedCms As New SignedCms(content, True)
    Dim signer As New CmsSigner(SubjectIdentifierType.IssuerAndSerialNumber, certificate)
    signedCms.ComputeSignature(signer, True)
    Dim signedbytes As Byte() = signedCms.Encode()

    oStream = oBodyPart.GetDecodedContentStream
    oStream.Type = ADODB.StreamTypeEnum.adTypeBinary

    ' Write the data to the stream and flush it
    oStream.Write(signedbytes)
    oStream.Flush()
    oStream.Close()

    oSecMsg.Fields.Item("urn:schemas:mailheader:content-type").Value _
     = "multipart/signed;" & vbCrLf & "protocol=""application/x-pkcs7-signature"";" & _
     vbCrLf & "micalg=SHA1;"
    oSecMsg.Fields.Update()

    oSecMsg.Configuration = oMsg.Configuration

    GoTo cleanup

    ' Report error
handle_error:
    MsgBox(Err.Number & ": " & Err.Description, , "Error:")
    oSecMsg.Attachments.DeleteAll()
    oSecMsg = Nothing

    ' Clean up memory
cleanup:
    oBodyPart = Nothing
    oStream = Nothing

    ' Return new message
    SignMessageClear = oSecMsg
  End Function