Fattura elettronica – Estrarre file XML da .p7m con Office VBA

Const CMSG_DATA_FLAG = 2                    ' Raw data with no particular formatting
Const CMSG_SIGNED_FLAG = 4                  ' Signed message
Const CMSG_ENVELOPED_FLAG = 8               ' Enveloped (encrypted) message
Const CMSG_SIGNED_AND_ENVELOPED_FLAG = 16   ' Signed and encrypted message
Const CMSG_HASHED_FLAG = 32                 ' Hashed message
Const CMSG_ENCRYPTED_FLAG = 64              ' Encrypted message
Const CMSG_DATA = 1                         ' Raw data with no particular formatting
Const CMSG_SIGNED = 2                       ' Signed message
Const CMSG_ENVELOPED = 3                    ' Enveloped (encrypted) message
Const CMSG_SIGNED_AND_ENVELOPED = 4         ' Signed and encrypted message
Const CMSG_HASHED = 5                       ' Hashed message
Const CMSG_ENCRYPTED = 6                    ' Encrypted message
 
Const CERT_FIND_ANY = 0
Const CERT_FIND_EXISTING = &HD0000
Const CERT_FIND_ISSUER_OF = &HC0000
Const CERT_FIND_ISSUER_STR = &H70004
Const CERT_FIND_KEY_SPEC = &H90000
Const CERT_FIND_PROPERTY = &H50000
Const CERT_FIND_SUBJECT_STR = &H70007
Const X509_ASN_ENCODING = &H1               ' X.509 Encoding
Const PKCS_7_ASN_ENCODING = &H10000         ' PKCS #7 Message Formatting

Public Type CRYPT_DECRYPT_MESSAGE_PARA
    cbSize As Long
    dwMsgAndCertEncodingType As Long
    cCertStore As Long                      ' hCryptProv As Long
    pfnGetSignerCertificate As Long         ' Pointer to callback function    HCERTSTORE *rghCertStore;
    dwFlags As Long                         ' pvGetArg As Long  ' void Pointer
End Type
 
Public Type CRYPT_VERIFY_MESSAGE_PARA
    cbSize As Long
    dwMsgAndCertEncodingType As Long
    hCryptProv As Long                      ' HCRYPTPROV_LEGACY hCryptProv;
    pfnGetSignerCertificate As Long         ' Pointer to callback function PFN_CRYPT_GET_SIGNER_CERTIFICATE pfnGetSignerCertificate;
    pvGetArg As Long                        ' void Pointer
End Type

Public Declare Function CryptDecodeMessage Lib "Crypt32.dll" (ByVal dwMsgTypeFlags As Long, _
                                            pDecryptPara As CRYPT_DECRYPT_MESSAGE_PARA, _
                                            pVerifyPara As CRYPT_VERIFY_MESSAGE_PARA, _
                                            ByVal dwSignerIndex As Long, ByVal pbEncodedBlob As String, _
                                            ByVal cbEncodedBlob As Long, ByVal dwPrevInnerContentType As Long, _
                                            pdwMsgType As Long, pdwInnerContentType As Long, _
                                            ByVal pbDecoded As String, pcbDecoded As Long, _
                                            ppXchgCert As Long, ppSignerCert As Long) As Long

Public Function leggiFileFirmato(ByVal NomeFile As String) As String
    ' Funzione per leggere il contenuto di un file firmato p7m
    ' [NomeFile] nome del file da leggere completo di percorso
    ' Restituisce il contenuto del file firmato
 
    On Error Resume Next
    Dim dwMsgTypeFlags As Long, i As Long
    Dim pDecryptPara As CRYPT_DECRYPT_MESSAGE_PARA
    Dim pVerifyPara As CRYPT_VERIFY_MESSAGE_PARA
    Dim dwSignerIndex As Long
    Dim dwPrevInnerContentType As Long
    Dim pdwMsgType As Long, pdwInnerContentType As Long
    Dim ppXchgCert As Long, ppSignerCert As Long
    Dim m_lHCryptProv As Long               ' Handle for the cryptographic service provider (CSP)
 
    Dim messaggioFirmato As String
    Dim messaggioFirmato_L As Long          ' Lunghezza messaggio
    Dim messaggioDecodificato As String
    Dim messaggioDecodificato_L As Long
 
    Dim iFile As Integer
    iFile = FreeFile
    Open NomeFile For Binary Access Read As #iFile
    messaggioFirmato = Input(LOF(iFile), iFile)
    Close #iFile
 
    messaggioDecodificato = Base64Decode(messaggioFirmato)  ' Verifica codifica base64
    If Err.Number <> 0 Then     ' = -2147467259  "Errore durante l'analisi di "..." come tipo di dati bin.base64."
        Err.Clear
    Else
        messaggioFirmato = messaggioDecodificato
    End If
    messaggioFirmato_L = Len(messaggioFirmato)  ' Lunghezza
    messaggioDecodificato = String(messaggioFirmato_L, vbNullChar)
    messaggioDecodificato_L = 0 'Len(messaggioDecodificato)
 
    ' strutture dati
    pVerifyPara.cbSize = 20
    pVerifyPara.dwMsgAndCertEncodingType = X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING  '--- The encoding type
    pVerifyPara.hCryptProv = m_lHCryptProv      '--- The CSP handle
    ' -
    pDecryptPara.cbSize = 16
    pDecryptPara.dwMsgAndCertEncodingType = pVerifyPara.dwMsgAndCertEncodingType    'X509_ASN_ENCODING Or PKCS_7_ASN_ENCODING
    'pDecryptPara.cCertStore = 0  '1000
    pDecryptPara.dwFlags = CMSG_SIGNED_AND_ENVELOPED
    pdwMsgType = CMSG_DATA_FLAG
    dwMsgTypeFlags = CMSG_SIGNED_FLAG    ' CMSG_DATA_FLAG
    pdwInnerContentType = 0
 
    i = CryptDecodeMessage(dwMsgTypeFlags, pDecryptPara, _
                             pVerifyPara, dwSignerIndex, _
                             messaggioFirmato, messaggioFirmato_L, _
                             dwPrevInnerContentType, pdwMsgType, _
                             pdwInnerContentType, messaggioDecodificato, _
                             messaggioDecodificato_L, ppXchgCert, ppSignerCert)
    i = CryptDecodeMessage(dwMsgTypeFlags, pDecryptPara, _
                             pVerifyPara, dwSignerIndex, _
                             messaggioFirmato, messaggioFirmato_L, _
                             dwPrevInnerContentType, pdwMsgType, _
                             pdwInnerContentType, messaggioDecodificato, _
                             messaggioDecodificato_L, ppXchgCert, ppSignerCert)
    Dim alfa As String
    alfa = "<!--?xml version=""1.0"" "
    i = InStr(1, (messaggioDecodificato), alfa, vbTextCompare)
    If i --> 0 Then
        messaggioDecodificato = Mid(messaggioDecodificato, i)
    End If
    If Err.Number = 0 Then
        leggiFileFirmato = messaggioDecodificato
    End If
 
End Function
 
Function Base64Decode(ByVal vCode)
    On Error Resume Next
    Dim oXML, oNode
    Set oXML = CreateObject(lb_XML_DOM)
    Set oNode = oXML.createElement("base64")
    oNode.DataType = "bin.base64"
    oNode.Text = vCode
    If Err.Number = 0 Then
        Base64Decode = Stream_BinaryToString(oNode.nodeTypedValue)
    End If
    Set oNode = Nothing: Set oXML = Nothing
End Function