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

我试图在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打开文件，而不先将其保存到磁盘

代码：

你能：

保存文件

打开文件以确定正确的文件名

关闭文件

重命名文件

---

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

为Craig干杯，这是一个想法，我将在明天早上查看并让您知道。恐怕无法在Outlook中打开该文件（您需要先保存它），但如果Craig的答案有效，您能将其标记为答案吗？

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