Public Class Class1


    '******************************************************************************
    '
    ' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND,
    ' EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED
    ' WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
    '
    ' Copyright (C) 1999- 2002.  Microsoft Corporation.  All rights reserved.
    '
    '******************************************************************************
    '
    ' smime.vbp
    '
    ' This is a VB sample that illustrates how to use CAPICOM's SignedData object
    ' with the CDO object to produce and verify S/MIME messages.
    '
    ' This sample is in part based the knowledge base article "HOWTO: Send Digitally
    ' Signed Messages Using CDOEX" at:
    ' http://support.microsoft.com/support/kb/articles/Q280/3/91.ASP
    '
    ' It utilizes the following references:
    '   * Microsoft CDO for Exchange 2000 (for accessing messages)
    '   * CAPICOM 2.0 (for signing and verifying messages)
    '   * Microsoft ActiveX Data Objects 2.5 or above
    '   * Microsoft Scripting Runtime
    '
    ' See the following RFC's for more information on S/MIME:
    '   * http://www.ietf.org/rfc/rfc2311.txt?number=2311
    '   * http://www.ietf.org/rfc/rfc1847.txt?number=1847
    '
    ' Note: For simplicity, this sample does not handle exception.
    '
    '******************************************************************************
    '	Option Explicit On


    ' Constants+
    Const CERT_KEY_SPEC_PROP_ID =  6 
    Const CdoAddressListGAL =  0 
    Const CdoAddressListPAB =  1 
    Const cdlOFNFileMustExist = &H1000
    Const cdlOFNHideReadOnly = &H4
    Const cdlOFNPathMustExist = &H800
    Const cdlOFNCreatePrompt = &H2000
    Const CAPICOM_CURRENT_USER_STORE =  2 
    Const CAPICOM_STORE_OPEN_READ_ONLY =  0 
    Const CAPICOM_CERTIFICATE_FIND_EXTENDED_PROPERTY =  6 
    Const CAPICOM_CERTIFICATE_FIND_APPLICATION_POLICY =  7 
    Const CAPICOM_CERT_INFO_SUBJECT_EMAIL_NAME =  2 
    Const CAPICOM_AUTHENTICATED_ATTRIBUTE_SIGNING_TIME =  0 
    Const CAPICOM_ENCODE_BINARY =  1 
    Const CAPICOM_E_CANCELLED = - 2138568446 


    ' Globals
    Dim oSigner As New CAPICOM.Signer
    Dim oMessage As New CDO.Message

    Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long


    '******************************************************************************
    '
    ' Function:     SignMessage
    '
    ' Parameters:   oMsg    -   A CDO object representing a properly formed MIME
    '                           message. [in/out]
    '
    '               bClear  -   a boolean specifying if the message is to be signed
    '                           using a detached PKCS7 or attached PKCS7. [in]
    '
    '
    ' Purpose:      Return a S/MIME message derived from the passed in message
    '
    ' Copyright (C) 1999- 2002.  Microsoft Corporation.  All rights reserved.
    '
    '******************************************************************************

    Private Function SignMessage(ByRef oMsg As CDO.Message, ByVal bClear As Boolean) As Boolean
        Dim oSignedMsg As New CDO.Message
        Dim oBodyPart As CDO.IBodyPart
        Dim cFields As ADODB.Fields
        Dim oStream As ADODB.Stream
        Dim oSignedData As New CAPICOM.SignedData
        Dim oUtilities As New CAPICOM.Utilities
        Dim oAttribute As New CAPICOM.Attribute
        Dim oSignerCertificate As CAPICOM.Certificate
        Dim cSignerCertificates As CAPICOM.Certificates
        Dim oStore As New CAPICOM.Store
        Dim szSignature, byteSignature() As Byte

        On Error GoTo ErrorHandler

        ' create the SignedData object we will use to create the PKCS7
        oSignedData = New CAPICOM.SignedData

        ' create the new message
        oSignedMsg = New CDO.Message

        ' select the signer certificate
        oStore.Open(CAPICOM_CURRENT_USER_STORE, "My", CAPICOM_STORE_OPEN_READ_ONLY)
        cSignerCertificates = oStore.Certificates.Find(CAPICOM_CERTIFICATE_FIND_EXTENDED_PROPERTY, CERT_KEY_SPEC_PROP_ID).Find(CAPICOM_CERTIFICATE_FIND_APPLICATION_POLICY, "Secure Email")

        Select Case cSignerCertificates.Count
            Case  0 
                MsgBox("Error: No signing certificate can be found.")
            Case  1 
                oSigner.Certificate = cSignerCertificates( 1 )
            Case Else
                cSignerCertificates = cSignerCertificates.Select("S/MIME Certificates", "Please select a certificate to sign with.")
                If (cSignerCertificates.Count =  0 ) Then
                    MsgBox("Error: Certificate selection dialog was cancelled.")
                    Exit Function
                End If
                oSigner.Certificate = cSignerCertificates( 1 )
        End Select

        ' set the from field based off of the selected certificate
        oSignedMsg.From = oSigner.Certificate.GetInfo(CAPICOM_CERT_INFO_SUBJECT_EMAIL_NAME)


        ' set the signing time in UTC time
        oAttribute = New CAPICOM.Attribute
        oAttribute.Name = CAPICOM_AUTHENTICATED_ATTRIBUTE_SIGNING_TIME
        oAttribute.Value = oUtilities.LocalTimeToUTCTime(Now)
        oSigner.AuthenticatedAttributes.Add(oAttribute)

        Select Case bClear
            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
                oSignedMsg.To = oMsg.To
                oSignedMsg.CC = oMsg.CC
                oSignedMsg.Subject = oMsg.Subject

                oBodyPart = oSignedMsg.BodyPart.AddBodyPart
                cFields = oBodyPart.Fields
                cFields.Item(cdoContentType).Value = oMsg.BodyPart.BodyParts( 1 ).Fields.Item(cdoContentType).Value
                cFields.Update()

                oStream = oBodyPart.GetDecodedContentStream
                oStream.WriteText(oMsg.BodyPart.BodyParts( 1 ).GetDecodedContentStream.ReadText)
                oStream.Flush()

                ' set the content to be signed
                oSignedData.Content = StrConv(oSignedMsg.BodyPart.BodyParts( 1 ).GetStream.ReadText, vbFromUnicode)

                ' sign the content
                szSignature = oSignedData.Sign(oSigner, True, CAPICOM_ENCODE_BINARY)

                ' Get the string data as a byte array
                byteSignature = szSignature

                ' Attach the signature and let CDO base64 encode it
                oBodyPart = oSignedMsg.BodyPart.AddBodyPart
                cFields = oBodyPart.Fields
                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"""
                cFields.Update()

                oStream = oBodyPart.GetDecodedContentStream
                oStream.Type = ADODB.StreamTypeEnum.adTypeBinary
                oStream.Write(byteSignature)
                oStream.Flush()

                ' Set the messages content type, this needs to be done last to ensure it is not changed when we add the BodyParts
                oSignedMsg.Fields.Item("urn:schemas:mailheader:content-type").Value = "multipart/signed;" & vbCrLf & "protocol=""application/x-pkcs7-signature"";" & vbCrLf & "micalg=SHA1;"
                oSignedMsg.Fields.Update()

            Case False
                ' this is to be a opaquely signed message so we need to copy the entire message into our
                ' new encrypted message
                oSignedMsg.DataSource.OpenObject(oMsg, cdoIMessage)

                ' Set up main bodypart
                oBodyPart = oSignedMsg.BodyPart
                oBodyPart.ContentMediaType = "application/pkcs7-mime;" & vbCrLf & "smime-type=signed-data;" & vbCrLf & "name=""smime.p7m"""
                oBodyPart.ContentTransferEncoding = "base64"
                oBodyPart.Fields("urn:schemas:mailheader:content-disposition") = "attachment;" & vbCrLf & "FileName=""smime.p7m"""
                oBodyPart.Fields.Update()

                ' set the from field based off of the selected certificate
                oMsg.From = oSigner.Certificate.GetInfo(CAPICOM_CERT_INFO_SUBJECT_EMAIL_NAME)

                ' set the content to be signed
                oSignedData.Content = StrConv(oMsg.BodyPart.GetStream.ReadText, vbFromUnicode)

                ' Sign the content
                szSignature = oSignedData.Sign(oSigner, False, CAPICOM_ENCODE_BINARY)

                ' Get the string data as a byte array
                byteSignature = szSignature

                ' Attach the signature and let CDO base64 encode it
                oStream = oBodyPart.GetDecodedContentStream
                oStream.Type = ADODB.StreamTypeEnum.adTypeBinary
                oStream.Write(byteSignature)
                oStream.Flush()
        End Select


        ' Signing Was sucessfull
        SignMessage = True
        oMsg = oSignedMsg

        GoTo CleanUp

ErrorHandler:
        'If the user cancels, don't display error message
        If Err.Number <> CAPICOM_E_CANCELLED Then
            MsgBox("Error: " & Hex(Err.Number) & ": " & Err.Description)
        End If
        Err.Clear()

        ' An error occurred
        SignMessage = False
        oMsg = Nothing

CleanUp:
        oSignedMsg = Nothing
        oBodyPart = Nothing
        cFields = Nothing
        oStream = Nothing
        oSignedData = Nothing
        oUtilities = Nothing
        oAttribute = Nothing
        oSignerCertificate = Nothing
        cSignerCertificates = Nothing
        oStore = Nothing
    End Function

    '******************************************************************************
    '
    ' Function:     EncryptMessage
    '
    ' Parameters:   oMsg        -   A CDO object representing a properly formed MIME
    '                               message. [in/out]
    '
    '               oRecipients  -  A collection of CAPICOM certificate objects in
    '                               which should be capable of decrypting this
    '                               message. [in]
    '
    '
    ' Purpose:      Return a S/MIME Encrypted message derived from the passed in message
    '
    ' Copyright (C) 1999- 2002.  Microsoft Corporation.  All rights reserved.
    '
    '******************************************************************************

    Private Function EncryptMessage(ByRef oMsg As CDO.Message, ByVal oRecipients As Certificates) As Boolean

        Dim oEncryptedMsg As New CDO.Message
        Dim oBodyPart As CDO.IBodyPart
        Dim cFields As ADODB.Fields
        Dim oStream As ADODB.Stream
        Dim oEnvelopedData As New CAPICOM.EnvelopedData
        Dim oRecipient As CAPICOM.Certificate
        Dim szEncMessage, byteEncMessage() As Byte

        ' Copy input into output message
        oEncryptedMsg.DataSource.OpenObject(oMsg, cdoIMessage)

        ' Set up main bodypart
        oBodyPart = oEncryptedMsg.BodyPart
        oBodyPart.ContentMediaType = "application/pkcs7-mime;" & vbCrLf & "smime-type=enveloped-data;" & vbCrLf & "name=smime.p7m;"
        oBodyPart.ContentTransferEncoding = "base64"
        oBodyPart.Fields("urn:schemas:mailheader:content-disposition") = "attachment;FileName=""smime.p7m"""
        oBodyPart.Fields("urn:schemas:mailheader:date").Value = oMsg.Fields("urn:schemas:mailheader:date").Value
        oBodyPart.Fields.Update()

        ' Add each of the passed in recipients to the EnvelopedData recipient's collection
        For Each oRecipient In oRecipients
            oEnvelopedData.Recipients.Add(oRecipient)
        Next

        ' Encrypt content
        oEnvelopedData.Content = StrConv(oMsg.BodyPart.GetStream.ReadText, vbFromUnicode)
        szEncMessage = oEnvelopedData.Encrypt(CAPICOM_ENCODE_BINARY)

        ' Get the string data as a byte array
        byteEncMessage = szEncMessage

        ' Write the CMS blob into the main bodypart and let CDO do the base64 encoding
        oStream = oEncryptedMsg.BodyPart.GetDecodedContentStream
        oStream.Type = adTypeBinary
        oStream.Write(byteEncMessage)
        oStream.Flush()

        ' Return out finished message
        EncryptMessage = True
        oMsg = oEncryptedMsg

        GoTo CleanUp

ErrorHandler:
        MsgBox(Err.Number & ": " & Err.Description, , "Error:")
        Err.Clear()
        EncryptMessage = False
        oMsg = Nothing

CleanUp:
        ' clean up
        oBodyPart = Nothing
        oEnvelopedData = Nothing
        oStream = Nothing
        oRecipient = Nothing
        oEncryptedMsg = Nothing
        oBodyPart = Nothing
        cFields = Nothing
    End Function
    Private Function IsSigned(ByVal oInMsg As CDO.Message) As Boolean
        Dim szContentType As String

        szContentType = oInMsg.BodyPart.Fields.Item("urn:schemas:mailheader:content-type").Value

        If ((InStr( 1 , szContentType, "application/x-pkcs7-signature", vbTextCompare) <>  0 ) Or (InStr( 1 , szContentType, "signed-data", vbTextCompare) <>  0 )) Then
            IsSigned = True
        Else
            IsSigned = False
        End If

    End Function

    Private Function IsEncrypted(ByVal oInMsg As CDO.Message) As Boolean
        Dim szContentType As String

        szContentType = oInMsg.BodyPart.Fields.Item("urn:schemas:mailheader:content-type").Value

        If (InStr( 1 , szContentType, "enveloped-data", vbTextCompare) <>  0 ) Then
            IsEncrypted = True
        Else
            IsEncrypted = False
        End If

    End Function

    '******************************************************************************
    '
    ' Function:     GetContent
    '
    ' Parameters:   oInMsg      -   A CDO object representing a properly formed MIME
    '                               message. [in/out]
    '
    '
    ' Purpose:      Return the portion of a S/MIME message that a signature was
    '               calculated over.
    '
    ' Copyright (C) 1999- 2002.  Microsoft Corporation.  All rights reserved.
    '
    '******************************************************************************
    Private Function GetContent(ByVal oInMsg As CDO.Message) As String
        Dim iStart As Integer, iLength As Integer
        Dim szMessage, szBodyPart

        szMessage = oInMsg.GetStream.ReadText

        szBodyPart = "--" + oInMsg.BodyPart.GetFieldParameter("urn:schemas:mailheader:content-type", "boundary") + vbCrLf

        iStart = InStr( 1 , szMessage, szBodyPart) + Len(szBodyPart)
        iLength = InStr((iStart +  1 ), szMessage, szBodyPart) - iStart -  2 

        GetContent = Mid(szMessage, iStart, iLength)
    End Function

    '******************************************************************************
    '
    ' Function:     GetSignature
    '
    ' Parameters:   oMsg        -   A CDO object representing a properly formed MIME
    '                               message. [in/out]
    '
    '
    ' Purpose:      Return the portion of a S/MIME message that contains the PKCS7
    '               signature.
    '
    ' Copyright (C) 1999- 2002.  Microsoft Corporation.  All rights reserved.
    '
    '******************************************************************************
    Private Function GetSignature(ByVal oInMsg As CDO.Message) As String

        If InStr( 1 , oInMsg.Fields.Item("urn:schemas:mailheader:content-disposition").Value, "attachment", vbTextCompare) <>  0  Then
            GetSignature = oInMsg.BodyPart.GetEncodedContentStream.ReadText
        Else
            GetSignature = oInMsg.BodyPart.BodyParts( 2 ).GetEncodedContentStream.ReadText
        End If
    End Function
    
    '******************************************************************************
    '
    ' Function:     VerifyMessage
    '
    ' Parameters:   oMsg        -   A CDO object representing a properly formed S/MIME
    '                               message. [in/out]
    '
    '
    ' Purpose:      Verify that a S/MIME message is signature valid
    '
    ' Copyright (C) 1999- 2002.  Microsoft Corporation.  All rights reserved.
    '
    '******************************************************************************
    Private Function VerifyMessage(ByRef oInMsg As CDO.Message) As Boolean
        Dim oSignedData As New CAPICOM.SignedData
        Dim szSignature As String
        Dim iStart As Integer, iEnd As Integer, szTemp As String
        On Error GoTo ErrorHandler

        ' get the pkcs7 signature
        szSignature = GetSignature(oInMsg)

        ' verify The message
        oSignedData = New CAPICOM.SignedData

        ' is this a detached or attached signature, deal with the differences
        oSignedData.Content = StrConv(GetContent(oInMsg), vbFromUnicode)
        Call oSignedData.Verify(szSignature, True, CAPICOM_VERIFY_SIGNATURE_ONLY)


        ' update the global signer for use later
        oSigner = oSignedData.Signers.Item( 1 )

        VerifyMessage = True

        GoTo CleanUp
ErrorHandler:
        MsgBox("Error: " & Hex(Err.Number) & ": " & Err.Description)
        Err.Clear()

        VerifyMessage = False

CleanUp:
        ' clean up
        oSignedData = Nothing

    End Function
    '******************************************************************************
    '
    ' Function:     DecryptMessage
    '
    ' Parameters:   oMsg        -   A CDO object representing a properly formed S/MIME
    '                               message. [in/out]
    '
    '
    ' Purpose:      To decrypt the supplied message and return a decrypted version in
    '               the oMsg parameter.
    '
    ' Copyright (C) 1999- 2002.  Microsoft Corporation.  All rights reserved.
    '
    '******************************************************************************

    Private Function DecryptMessage(ByRef oMsg As CDO.Message) As Boolean
        Dim oDecryptedMsg As New CDO.Message
        Dim oStream As New ADODB.Stream
        Dim iDsrc As IDataSource
        Dim oEnvelopedData As New CAPICOM.EnvelopedData
        Dim byteDecryptedMessage() As Byte

        On Error GoTo ErrorHandler

        ' Decrypt content
        Call oEnvelopedData.Decrypt(oMsg.BodyPart.GetEncodedContentStream.ReadText)

        ' Convert the message to a byte array
        byteDecryptedMessage = oEnvelopedData.Content

        ' Load the decrypted message into a stream
        oStream.Open()
        oStream.Type = adTypeBinary
        oStream.Write(byteDecryptedMessage)

        iDsrc = oDecryptedMsg
        iDsrc.OpenObject(oStream, "_Stream")

        ' Return the status
        oMsg = oDecryptedMsg
        DecryptMessage = True

        GoTo CleanUp

ErrorHandler:
        MsgBox(Err.Number & ": " & Err.Description, , "Error:")

        ' Return the false values
        DecryptMessage = False
        oMsg = Nothing

CleanUp:
        ' clean up
        oEnvelopedData = Nothing
        oDecryptedMsg = Nothing
        oStream = Nothing
        iDsrc = Nothing
    End Function





   
End Class