'''''''''''''''''''''''''''''''''''''''''''''''''''''
'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