如何通过Excel VBA在添加Outlook邮件附件前重命名PDF文件

需求说明 #

• 需在将PDF文件添加为Outlook邮件附件前修改其文件名，移除GDPR敏感数字
• 敏感数字存储在R.Offset(0, 3)单元格中，格式包括：
  • 10位纯数字（如0000000000）
  • 带后缀的10位数字（如0000000000-1）
  • 8位纯数字（如00000000）
• 目标PDF文件位于指定文件夹，原文件名格式为0000000000_FIRST_MIDDLE_LAST_STATEMENT.pdf，需移除文件名开头的敏感数字部分

现有代码问题 #

原代码直接使用敏感数字拼接文件名添加附件，未做脱敏处理：

Sub SendEmailFromExcel()

Dim EApp As Outlook.Application
Set EApp = New Outlook.Application
Dim EItem As Outlook.MailItem
Set EItem = EApp.CreateItem(olMailItem)
Dim path As String
Dim strbody
path = "\" 'put your path here
Dim RList As Range
Set RList = Range("A2", Range("a2").End(xlDown))
Dim R As Range

strbody = "<p >template</p>" 

For Each R In RList
    Set EItem = EApp.CreateItem(0)
    With EItem
        .SentOnBehalfOfName = ("team_email")
        .To = R.Offset(0, 1)
        .Subject = R.Offset(0, 0)
        .Attachments.Add (path & R.Offset(0, 3) + ".pdf")
        .Display
        .HTMLBody = strbody & .HTMLBody
    End With
Next R
Set EApp = Nothing
Set EItem = Nothing
End Sub

修改后的代码（实现文件名脱敏） #

以下是实现需求的完整代码，核心逻辑是找到目标文件后，指定附件在邮件中的显示名称（不修改原文件）：

Sub SendEmailFromExcel()

Dim EApp As Outlook.Application
Set EApp = New Outlook.Application
Dim EItem As Outlook.MailItem
Dim path As String
Dim strbody As String
Dim RList As Range
Dim R As Range
Dim sensitiveNum As String
Dim targetFile As String
Dim desensitizedFileName As String

' 设置文件路径（请替换为实际文件夹路径）
path = "C:\Your\Actual\Folder\Path\"
strbody = "<p>邮件模板内容</p>"

Set RList = Range("A2", Range("A2").End(xlDown))

For Each R In RList
    Set EItem = EApp.CreateItem(olMailItem)
    sensitiveNum = R.Offset(0, 3).Value
    
    ' 查找文件夹中以敏感数字开头的PDF文件
    targetFile = Dir(path & sensitiveNum & "_*.pdf")
    
    If targetFile <> "" Then
        ' 移除文件名开头的敏感数字及下划线，得到脱敏后的名称
        desensitizedFileName = Mid(targetFile, Len(sensitiveNum) + 2)
        
        With EItem
            .SentOnBehalfOfName = "team_email" ' 替换为实际发件人邮箱
            .To = R.Offset(0, 1).Value
            .Subject = R.Offset(0, 0).Value
            ' 添加附件并指定显示名称为脱敏后的文件名
            .Attachments.Add path & targetFile, olByValue, 1, desensitizedFileName
            .HTMLBody = strbody & .HTMLBody
            .Display ' 如需直接发送可改为 .Send
        End With
    Else
        ' 文件未找到时的提示
        MsgBox "未找到对应文件：" & sensitiveNum & "_*.pdf", vbExclamation
    End If
Next R

Set EApp = Nothing
Set EItem = Nothing
End Sub

关键逻辑说明 #

1. 文件定位：用Dir函数匹配敏感数字_*.pdf格式的文件，确保找到对应目标文件
2. 脱敏处理：通过Mid函数截取文件名中敏感数字和下划线之后的部分，生成无敏感信息的显示名称
3. 附件添加：调用Attachments.Add时，第四个参数指定邮件中显示的文件名，原文件的实际名称不会被修改
4. 异常处理：增加文件未找到的提示，避免程序无响应

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