smimedecryptvbs

'''''''''''''''''''''''''''''''''''''''''''''''''''''

'Copyright (C) 2004 Hitachi East Japan Solutions,Ltd.

'Product: eMailKit Utility Ver. 1.0.2.3

'S/MIME Decrypting And Verifying, Sample Implementation.

'

'To execute this sample, you need to get "CAPICOM 2.0"

'(CAPICOM means CryptoAPI COM) from the web site of

'Microsoft Corporation.

'''''''''''''''''''''''''''''''''''''''''''''''''''''

'CONSTANTS

'Type mkIOMode

Const mkForReading = 1

Const mkForWriting = 2

Const mkForCreating = 4

Const mkForAppending = 8

'Type CAPICOM_CERT_INFO_TYPE

Const CAPICOM_CERT_INFO_SUBJECT_SIMPLE_NAME = 0

Const CAPICOM_CERT_INFO_ISSUER_SIMPLE_NAME = 1

Const CAPICOM_CERT_INFO_SUBJECT_EMAIL_NAME = 2

Const CAPICOM_CERT_INFO_ISSUER_EMAIL_NAME = 3

Const CAPICOM_CERT_INFO_SUBJECT_UPN = 4

Const CAPICOM_CERT_INFO_ISSUER_UPN = 5

Const CAPICOM_CERT_INFO_SUBJECT_DNS_NAME = 6

Const CAPICOM_CERT_INFO_ISSUER_DNS_NAME = 7

'Type CAPICOM_SIGNED_DATA_VERIFY_FLAG

Const CAPICOM_VERIFY_SIGNATURE_ONLY = 0

Const CAPICOM_VERIFY_SIGNATURE_AND_CERTIFICATE = 1

'S/MIME message type

Const CRYPTOGRAPHIC_PLAIN = &H0000

Const CRYPTOGRAPHIC_SMIME_ENCRYPTED = &H0001

Const CRYPTOGRAPHIC_SMIME_SIGNED = &H0002

Const CRYPTOGRAPHIC_SMIME_CLEARSIGNED = &H0004

'Error source

Const SOURCE_SMIME = "S/MIME"

'''''''''''''''''''''''''''''''''''''''''''''''''''

'Decrypt and/or verify S/MIME message.

Function DecryptAndVerifyMessage(objMM, flagVerify, objSigners)

Dim intMsgType        'As Integer

Dim intEntityType     'As Integer

Set objSigners = Nothing

intMsgType = CRYPTOGRAPHIC_PLAIN

intEntityType = GetCryptoEntityType(objMM)

Do While intEntityType <> CRYPTOGRAPHIC_PLAIN

intMsgType = (intMsgType Or intEntityType)

If intEntityType = CRYPTOGRAPHIC_SMIME_ENCRYPTED Then

Call DecryptEntity(objMM)

ElseIf intEntityType = CRYPTOGRAPHIC_SMIME_SIGNED Then

Call VerifySignedEntity(objMM, flagVerify, objSigners)

ElseIf intEntityType = CRYPTOGRAPHIC_SMIME_CLEARSIGNED Then

Call VerifyClearSignedEntity(objMM, flagVerify, objSigners)

End If

intEntityType = GetCryptoEntityType(objMM)

Loop

If Not (objSigners Is Nothing) Then

If CompareSignerAndSender(objSigners, objMM) = False Then

Err.Raise 29010, SOURCE_SMIME, _

"The address in the From: header field of a mail message " & _

"does not match an e-mail address in the signer's certificate."

End If

End If

DecryptAndVerifyMessage = intMsgType

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''

'Is the MIME entity encrypted or signed?

'

' Content-Type: application/pkcs7-mime; smime-type=enveloped-data

'  --> ENCRYPTED

' Content-Type: application/pkcs7-mime; smime-type=signed-data

'  --> SIGNED

' Content-Type: multipart/signed;

'   protolol="application/pkcs7-signature"

' Content-Type: application/pkcs7-signature

'  --> CLEAR SIGNED

'

Function GetCryptoEntityType(itfME)

Dim objCT             'As ContentType

Dim objParams         'As FieldParameters

Dim objMBP            'As MimeBodyPart

Dim objMPB            'As MultipartBody

Dim strPrimaryType    'As String

Dim strSubType        'As String

Dim strMediaType      'As String

Dim strParamValue     'As String

Dim lngIndex          'As Long

Set objCT = itfME.ContentType

Set objParams = objCT.Parameters

strPrimaryType = LCase(objCT.PrimaryType)

strSubType = LCase(objCT.SubType)

If strPrimaryType = "application" Then

If strSubType = "pkcs7-mime" Or _

strSubType = "x-pkcs7-mime" Then

lngIndex = objParams.Find("smime-type")

If lngIndex >= 0 Then

strParamValue = LCase(objParams.Item(lngIndex).Value)

If strParamValue = "enveloped-data" Then

GetCryptoEntityType = CRYPTOGRAPHIC_SMIME_ENCRYPTED

Exit Function

ElseIf strParamValue = "signed-data" Then

GetCryptoEntityType = CRYPTOGRAPHIC_SMIME_SIGNED

Exit Function

End If

Else

GetCryptoEntityType = CRYPTOGRAPHIC_SMIME_ENCRYPTED

Exit Function

End If

End If

ElseIf strPrimaryType = "multipart" Then

If strSubType = "signed" Then

lngIndex = objParams.Find("protocol")

If lngIndex >= 0 Then

strParamValue = LCase(objParams.Item(lngIndex).Value)

If strParamValue = "application/pkcs7-signature" Or _

strParamValue = "application/x-pkcs7-signature" Then

Set objMPB = itfME.MultipartBody

If objMPB.Count = 2 Then

strMediaType = objMPB.Item(1).ContentType.Value

strMediaType = LCase(strMediaType)

If strMediaType = strParamValue Then

GetCryptoEntityType = CRYPTOGRAPHIC_SMIME_CLEARSIGNED

Exit Function

End If

End If

End If

End If

End If

End If

GetCryptoEntityType = CRYPTOGRAPHIC_PLAIN

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''

'Decrypt enveloped MIME entity.

Sub DecryptEntity(itfME)

Dim objED             'As EnvelopedData

Dim objTE             'As TextEncoder

Set objED = CreateObject("CAPICOM.EnvelopedData")

Set objTE = CreateObject("eMailkit.TextEncoder")

'decrypt envelopedData object

'(This method will fail if the certificate for the associated

' private key is not in either the local computer MY store or

' the current user MY store.)

objED.Decrypt objTE.BytesToString(itfME.GetBytes)

'parse decrypted content as MIME entity

itfME.WrapWithMultipart

itfME.MultipartBody.Item(0).Decode _

objTE.StringToBytes(objED.Content)

itfME.UnwrapMultipart

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''

'Verify digital signature of signed MIME entity.

Sub VerifySignedEntity(itfME, flagVerify, objSigners)

Dim objSD             'As SignedData

Dim objTE             'As TextEncoder

Set objSD = CreateObject("CAPICOM.SignedData")

Set objTE = CreateObject("eMailkit.TextEncoder")

'verify signedData object

objSD.Verify objTE.BytesToString(itfME.GetBytes), _

False, flagVerify

'get signerInfo

If objSigners Is Nothing Then

Set objSigners = objSD.Signers

End If

'parse verified content as a plain MIME entity

itfME.WrapWithMultipart

itfME.MultipartBody.Item(0).Decode _

objTE.StringToBytes(objSD.Content)

itfME.UnwrapMultipart

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''

'Verify digital signature of clear-signed MIME entity.

Sub VerifyClearSignedEntity(itfME, flagVerify, objSigners)

Dim objSD             'As SignedData

Dim objTE             'As TextEncoder

Set objSD = CreateObject("CAPICOM.SignedData")

Set objTE = CreateObject("eMailkit.TextEncoder")

'verify digital signature

objSD.Content = _

objTE.BytesToString(itfME.MultipartBody.Item(0).Source)

objSD.Verify _

objTE.BytesToString(itfME.MultipartBody.Item(1).GetBytes), _

True, flagVerify

'get signerInfo

If objSigners Is Nothing Then

Set objSigners = objSD.Signers

End If

'remove digital signature from the multipart MIME entity

itfME.MultipartBody.Remove 1

itfME.UnwrapMultipart

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''

'Compare sender and signer.

Function CompareSignerAndSender(objSigners, objMM)

Dim strSenderAddr 'As String

strSenderAddr = GetFromAddress(objMM)

If Not IsEmpty(strSenderAddr) Then

If Not (FindSignerInfo(objSigners, strSenderAddr) Is Nothing) Then

'identical

CompareSignerAndSender = True

Exit Function

End If

End If

'not identical or comparison failed

CompareSignerAndSender = False

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''

'Find signerInfo corresponding to specified e-mail address.

Function FindSignerInfo(objSigners, strMailAddr)

Dim objSigner     'As Signer

Dim objAG         'As AddressGroup

Dim strCertAddr   'As String

Set objAG = CreateObject("eMailKit.AddressGroup")

objAG.Add strMailAddr

For Each objSigner In objSigners

strCertAddr = objSigner.Certificate.GetInfo( _

CAPICOM_CERT_INFO_SUBJECT_EMAIL_NAME)

'compare two addresses strictly using AddressGroup object

If objAG.FindAddress(strCertAddr) >= 0 Then

Set FindSignerInfo = objSigner

Exit Function

End If

Next

Set FindSignerInfo = Nothing

End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''

'Get sender's e-mail address of the message.

Function GetFromAddress(objMM)

With objMM.From

If .Count > 0 Then

GetFromAddress = .Item(0).Value

Exit Function

End If

End With

GetFromAddress = Empty

End Function