Excel 将转换xls到xlsx功能添加到Outlook VBA代码

我有一个工作VBA脚本，用于将文件下载到特定位置（如果它们与主题匹配）

我想将这些文件自动转换为.xlsx。我在网上找到了完成第二部分的代码

（我已在VBA库中添加了对Microsoft Excel XX.X对象库的引用。）

自动下载/重命名代码：

Public Sub save95Attachment(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
Dim filePath As String
Dim tempPath As String
Dim ExcelApp As Excel.Application
Dim wb As Excel.Workbook

saveFolder = "C:\Users\username\Documents\OLAttachments\Temp"
dateFormat = Format(itm.ReceivedTime, "yyyymmdd")

For Each objAtt In itm.Attachments
filePath = saveFolder & "\" & dateFormat & "_file" & ".xls"
    objAtt.SaveAsFile filePath
    Set objAtt = Nothing
Next
End Sub

Public Sub ConvertXlsToXlsx(Atmt As Attachment, FullFileName_And_Path As String)
  Dim tempPath As String
  Dim ExcelApp As Excel.Application
  Dim wb As Excel.Workbook

  tempPath = Environ("TEMP") & "\converttemp.xls"
  Atmt.SaveAsFile tempPath

  ExcelApp = New Excel.Application
  Set wb = ExcelApp.Workbooks.Open(tempPath)
  wb.SaveAs FullFileName_And_Path, Excel.XlFileFormat.xlOpenXMLWorkbook
  wb.Close False
  Set wb = Nothing
  ExcelApp.Quit
  Set ExcelApp = Nothing

  Kill wb 'Clean up the temp file
End Sub

转换为xlsx的代码：

Public Sub save95Attachment(itm As Outlook.MailItem)

Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
Dim filePath As String
Dim tempPath As String
Dim ExcelApp As Excel.Application
Dim wb As Excel.Workbook

saveFolder = "C:\Users\username\Documents\OLAttachments\Temp"
dateFormat = Format(itm.ReceivedTime, "yyyymmdd")

For Each objAtt In itm.Attachments
filePath = saveFolder & "\" & dateFormat & "_file" & ".xls"
    objAtt.SaveAsFile filePath
    Set objAtt = Nothing
Next
End Sub

Public Sub ConvertXlsToXlsx(Atmt As Attachment, FullFileName_And_Path As String)
  Dim tempPath As String
  Dim ExcelApp As Excel.Application
  Dim wb As Excel.Workbook

  tempPath = Environ("TEMP") & "\converttemp.xls"
  Atmt.SaveAsFile tempPath

  ExcelApp = New Excel.Application
  Set wb = ExcelApp.Workbooks.Open(tempPath)
  wb.SaveAs FullFileName_And_Path, Excel.XlFileFormat.xlOpenXMLWorkbook
  wb.Close False
  Set wb = Nothing
  ExcelApp.Quit
  Set ExcelApp = Nothing

  Kill wb 'Clean up the temp file
End Sub

在Outlook规则自动下载/重命名后，我希望文件自动转换为xlsx，并删除旧文件。

在这一行之后

objAtt.SaveAsFile filePath

运行这个

convertXLStoXLSX filePath

并在代码中包含此子项：

Sub convertXLStoXLSX(fullFilePath as String)

    Dim xlApp As New Excel.Application 
    Dim wb as Excel.Workbook

    Set wb = xlApp.Workbooks.Open(fullFilePath)
    wb.SaveAs fullFilePath, Excel.XlFileFormat.xlOpenXMLWorkbook
    wb.Close False

    xlApp.Quit

End Sub

最后，要使上述功能发挥作用，请确保在VBE中的Tools>References中选择

MicrosoftExcel对象库X.X

实际上，如果在附件循环之外打开/关闭Excel，效率会更高。不过我会让你重构它。

这是我的

Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)

Dim oAttachment As Outlook.Attachment
Dim filePath As String
Dim xlApp As New Excel.Application
Dim wb As Excel.Workbook

filePath = "\\server\shared_folder\your_File_Name.xlsx"

For Each oAttachment In MItem.Attachments
    oAttachment.SaveAsFile "C:\temp\My_Temp_file_Name.xls"
    Set wb = xlApp.Workbooks.Open("C:\temp\My_Temp_file_Name.xls")
    wb.SaveAs filePath, Excel.XlFileFormat.xlOpenXMLWorkbook
    wb.Close False
    xlApp.Quit
Next


End Sub

---

谢谢你的回复！我尝试了你所说的，用你编写的代码替换我的convertXLStoXLSX代码，并添加到行

convertXLStoXLSX文件路径

，但没有成功。它保存到预期的文件位置，但作为XLS文件。当我将您的convertXLStoXLSX添加到我的convertXLStoXLSX中时，程序中不会发生任何事情。收到电子邮件后，它甚至不会保存。@user9843227-关于您的第二条评论，您不能在一个项目中有两个同名的模块。这就是为什么它不会运行。在第一条注释中，将

wb.SaveAs-fullFilePath，…

替换为'wb.SaveAs-replace（fullFilePath，.xlsx，“”），…`并查看是否有效。只尝试使用

wb.SaveAs-replace（fullFilePath，.xlsx，“”），…

。现在，当我单击它保存的xls文件时，它在前5秒钟显示“此文件已被用户锁定以进行编辑”，然后它允许我正常打开它，但它保存为xls。@user9843227-这里有一些技巧我记不起来了。我发现我也输入错误，请尝试

Replace（fullFilePath，.xls，”）

和/或

Replace（fullFilePath，.xls，.xlsx）