QTP代码从EML文件下载PNG附件失败问题求助

我使用QTP编写代码从EML文件中提取PNG附件时遇到问题，最终保存的文件并非正确的附件内容。预期效果是将EML文件中的PNG附件保存到指定文件夹，但下面的代码无法实现该功能：

' Define the path to your EML file
emlFilePath = "C:\path\to\your\email.eml"

' Create a File System Object
Set fso = CreateObject("Scripting.FileSystemObject")

' Check if the EML file exists
If fso.FileExists(emlFilePath) Then
    ' Open the EML file
    Set emlFile = fso.OpenTextFile(emlFilePath, 1)

    ' Read the content of the EML file line by line
    Do Until emlFile.AtEndOfStream
        line = emlFile.ReadLine

        ' Check if the line contains an attachment
        If InStr(1, line, "Content-Disposition: attachment;", vbTextCompare) > 0 Then
            ' Extract the attachment filename
            attachmentFilename = Mid(line, InStrRev(line, "filename=") + 10)

            ' Remove quotes and any leading or trailing spaces
            attachmentFilename = Replace(attachmentFilename, """", "")
            attachmentFilename = Trim(attachmentFilename)

            ' Copy the attachment to a desired location
            ' For example, to copy it to the desktop
            destinationPath = "C:\Users\<your_username>\Desktop\" & attachmentFilename
            fso.CopyFile emlFilePath, destinationPath

            ' Exit the loop after copying the attachment
            Exit Do
        End If
    Loop

    ' Close the EML file
    emlFile.Close
Else
    MsgBox "EML file not found: " & emlFilePath
End If

' Clean up
Set fso = Nothing

' Define the path to your EML file
emlFilePath = "C:\path\to\your\email.eml"

' Create a File System Object
Set fso = CreateObject("Scripting.FileSystemObject")

' Check if the EML file exists
If fso.FileExists(emlFilePath) Then
    ' Open the EML file
    Set emlFile = fso.OpenTextFile(emlFilePath, 1)

    ' Read the content of the EML file line by line
    Do Until emlFile.AtEndOfStream
        line = emlFile.ReadLine

        ' Check if the line contains an attachment
        If InStr(1, line, "Content-Disposition: attachment;", vbTextCompare) > 0 Then
            ' Extract the attachment filename
            attachmentFilename = Mid(line, InStrRev(line, "filename=") + 10)

            ' Remove quotes and any leading or trailing spaces
            attachmentFilename = Replace(attachmentFilename, """", "")
            attachmentFilename = Trim(attachmentFilename)

            ' Copy the attachment to a desired location
            ' For example, to copy it to the desktop
            destinationPath = "C:\Users\<your_username>\Desktop\" & attachmentFilename
            fso.CopyFile emlFilePath, destinationPath

            ' Exit the loop after copying the attachment
            Exit Do
        End If
    Loop

    ' Close the EML file
    emlFile.Close
Else
    MsgBox "EML file not found: " & emlFilePath
End If

' Clean up
Set fso = Nothing

问题分析 #

原代码存在核心逻辑错误：

• 错误复制整个EML文件：代码用fso.CopyFile直接复制完整EML文件作为附件，完全没有提取附件的实际内容。
• 未处理EML附件编码：EML中的附件以Base64编码存储，原代码仅识别了文件名行，未处理编码后的附件数据。
• 存在冗余重复代码，逻辑效率低下。

修正后的代码 #

以下代码可正确识别并提取EML中的PNG附件，解码后保存为原始文件：

' 配置参数
emlFilePath = "C:\path\to\your\email.eml"
saveFolder = "C:\Users\<your_username>\Desktop\" ' 附件保存目录

Set fso = CreateObject("Scripting.FileSystemObject")
Set base64 = CreateObject("Microsoft.XMLDOM").CreateElement("b64")

' 检查EML文件是否存在
If Not fso.FileExists(emlFilePath) Then
    MsgBox "EML文件不存在：" & emlFilePath
    Set fso = Nothing
    Set base64 = Nothing
    Exit Sub
End If

' 确保保存目录存在
If Not fso.FolderExists(saveFolder) Then
    fso.CreateFolder saveFolder
End If

Set emlFile = fso.OpenTextFile(emlFilePath, 1)
inAttachment = False
attachmentContent = ""
attachmentFilename = ""

Do Until emlFile.AtEndOfStream
    line = emlFile.ReadLine
    
    ' 识别附件起始，提取文件名
    If InStr(1, line, "Content-Disposition: attachment;", vbTextCompare) > 0 Then
        fnStart = InStr(line, "filename=")
        If fnStart > 0 Then
            attachmentFilename = Mid(line, fnStart + 9)
            attachmentFilename = Replace(attachmentFilename, """", "")
            attachmentFilename = Trim(attachmentFilename)
            ' 仅处理PNG附件
            If LCase(fso.GetExtensionName(attachmentFilename)) = "png" Then
                ' 跳过头信息，定位到Base64内容
                Do Until emlFile.AtEndOfStream
                    line = emlFile.ReadLine
                    If Trim(line) = "" Then Exit Do
                Loop
                inAttachment = True
            End If
        End If
    End If
    
    ' 收集Base64编码内容，直到遇到附件结束标记
    If inAttachment Then
        If InStr(1, line, "--", vbTextCompare) > 0 Then
            Exit Do
        End If
        attachmentContent = attachmentContent & Trim(line)
    End If
Loop

emlFile.Close

' 解码并保存PNG附件
If attachmentFilename <> "" And attachmentContent <> "" Then
    base64.DataType = "bin.base64"
    base64.Text = attachmentContent
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 1 ' 二进制模式
    stream.Open
    stream.Write base64.NodeTypedValue
    stream.SaveToFile saveFolder & attachmentFilename, 2 ' 覆盖已存在文件
    stream.Close
    Set stream = Nothing
    MsgBox "PNG附件已保存：" & saveFolder & attachmentFilename
Else
    MsgBox "未找到PNG附件"
End If

' 清理对象
Set emlFile = Nothing
Set fso = Nothing
Set base64 = Nothing

修正说明 #

• 新增Base64解码逻辑：利用Microsoft.XMLDOM节点将编码内容转换为二进制数据。
• 正确识别附件的起始与结束边界：跳过EML头信息，仅收集附件的编码块。
• 增加PNG过滤：只处理目标类型附件，避免无效提取。
• 修复文件保存逻辑：将解码后的二进制数据写入目标文件，而非复制整个EML。
• 移除冗余代码，优化流程效率。

内容的提问来源于stack exchange，提问作者chandan ghag