''''''''''''''''''''''''''''''''''''''''''''''''''''' '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
![](https://img2024.cnblogs.com/blog/35695/202408/35695-20240826070647288-243310440.jpg)