Outlook VBA 从附件中找到的字符串中获取附件文件名

Question

我正在尝试在 Outlook (VBA) 中编写一些代码，以便在附件到达时自动将它们保存到文件中。但是，困难在于我要保存它们的文件名部分来自文件的内容（例如，附件称为“10-0123.xls”并包含来自 Lockyer Valley 的数据。我想要磁盘上的文件称为“10-0123_Lockyer.xls”）。对位置（在本例中为“Lockyer”）的唯一引用在附件中，并且数字（在本例中为“10-0123”）和位置（在本例中为“Lockyer”）随每封电子邮件而变化。

我找到了一种方法，将文件按原样保存到磁盘（'10-0123.xls'），打开它，在文件中找到字符串（'Lockyer'），保存为新文件名（'10-0123_Lockyer.xls'），然后杀死原始文件（'10-0123.xls'），但由于文件很大，运行宏需要一段时间。有没有更有效的方法来实现这一目标？也许是一种直接从 Outlook 打开文件而不先将其保存到磁盘的方法？

代码：

unPrntdRprts = "C:\New Reports"
For Each Attachment In MailItem.Attachments
    AtNameExt = Attachment.DisplayName
    AtExt = Right(AtNameExt, 4)
    AtName = Left(AtNameExt, Len(AtNameExt) - 4)
    XLApp.DisplayAlerts = False
    Attachment.SaveAsFile (UnPrntdRprts & "\" & AtNameExt)
    XLApp.DisplayAlerts = True
    XLApp.Workbooks.Open (UnPrntdRprts & "\" & AtNameExt)
    SiteName = XLApp.Workbooks(AtNameExt).Worksheets(1).Range("A24").Value
    SavName = AtName & "_" & SiteName & AtExt
    XLApp.DisplayAlerts = False
    XLApp.Workbooks(AtNameExt).SaveAs (UnPrntdRprts & "\" & SavName)
    XLApp.DisplayAlerts = True
    XLApp.Workbooks(SavName).Close
    Kill (UnPrntdRprts & "\" & AtNameExt)
Next

Answer 1

你能：

1. 保存文件
2. 打开文件以确定正确的文件名
3. 关闭文件
4. 重命名文件

这将删除第二个保存功能。