VBA'1004'错误在ActiveWorkbook.Save

我创build了一个VBA模块：

• 在Outlook中search特定的电子邮件
• 从它find的电子邮件中抓取excel文件附件
• 格式的Excel文件附件（添加颜色和网格，使其看起来更能呈现）
• 将格式化的excel文件保存到我的桌面上
• 将格式化的excel文件作为附件发送给我们的客户（并将excel文件粘贴到电子邮件正文中）

**我使用多个arrays发送给个人客户

我的代码工作得很好，并且没有多less问题。 但是，现在每处理一次，它会随机popup一个“1004运行时错误”。 当我debugging时，我需要“ActiveWorkbook.Save”。 通常如果我再次运行它，它工作得很好，但我需要它更友好的用户使用。 代码如下。

Public f As Integer 'format integer Sub Clients() 'Array([file destination to be saved], [subject of file being searched in outlook], [file name given when saved], [emails the report is going to]) f = 0 email_1 = Array("C:\User\Desktop\", "FL Test Results", "FL_Reports", "[e-mail]") Call Reports(email_1) f = 1 email_2 = Array("C:\User\Desktop\", "CA Test Results", "CA_Reports", "[e-mail]") Call Reports(email_2) f = 2 email_3 = Array("C:\User\Desktop\", "NY Test Results", "NY_Reports", "[e-mail]") Call Reports(email_3) email_4 = Array("C:\User\Desktop\", "TX Test Results", "TX_Reports", "[e-mail]") Call Reports(email_4) End Sub Function Reports(a As Variant) Dim rng As Range Dim OutApp As Object Dim OutMail As Object Dim olApp As Outlook.Application Dim olNs As Namespace Dim olFldr As MAPIFolder Dim olItms As Items Dim olMi As MailItem Dim olEmail As Outlook.MailItem Dim olAtt As Attachment Dim subj As String Dim saveAs As String Dim emails As String Dim FilePath As String FilePath = a(0) subj = a(1) saveAs = a(2) emails = a(3) Set olApp = GetObject(, "Outlook.Application") Set olNs = olApp.GetNamespace("MAPI") Set olFldr = olNs.GetDefaultFolder(olFolderInbox) Set olItms = olFldr.Items Set olEmail = olApp.CreateItem(olMailItem) With Application .EnableEvents = False .ScreenUpdating = False End With Set rng = Nothing Set rng = ActiveSheet.UsedRange Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) Set olMi = olItms.Find("[Subject] = " & Chr(34) & subj & Chr(34)) If Not (olMi Is Nothing) Then For Each olAtt In olMi.Attachments olAtt.SaveAsFile FilePath & saveAs & ".xls" Workbooks.Open (FilePath & saveAs & ".xls") Call format.Run 'Seperate file that formats the raw excel sheet to look more pretty If f = 0 Then Call format.DeleteOldClasses 'different ways clients want there excel file info sorted ElseIf f = 1 Then Call format.sortByDate Else End If ActiveWorkbook.Save '#######This is where the error pops up Set rng = Worksheets(saveAs).UsedRange Next olAtt End If On Error Resume Next With OutMail .Attachments.Add FilePath & saveAs & ".xls" .To = emails .CC = "" .BCC = "" .subject = subj .HTMLBody = RangetoHTML(rng) .send End With On Error GoTo 0 ActiveWorkbook.Close Kill (FilePath & saveAs & ".xls") With Application .EnableEvents = True .ScreenUpdating = True End With Set OutMail = Nothing Set OutApp = Nothing Set olAtt = Nothing Set olMi = Nothing Set olFldr = Nothing Set olNs = Nothing Set olApp = Nothing End Function Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006 ' Working in Office 2000-2013 Dim fso As Object Dim ts As Object Dim TempFile As String Dim TempWB As Workbook TempFile = Environ$("temp") & "\" & format(Now, "dd-mm-yy h-mm-ss") & ".htm" 'Copy the range and create a new workbook to past the data in rng.Copy Set TempWB = Workbooks.Add(1) With TempWB.Sheets(1) .Cells(1).PasteSpecial Paste:=8 .Cells(1).PasteSpecial xlPasteValues, , False, False .Cells(1).PasteSpecial xlPasteFormats, , False, False .Cells(1).Select Application.CutCopyMode = False On Error Resume Next .DrawingObjects.Visible = True .DrawingObjects.delete On Error GoTo 0 End With 'Publish the sheet to a htm file With TempWB.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=TempFile, _ Sheet:=TempWB.Sheets(1).Name, _ Source:=TempWB.Sheets(1).UsedRange.Address, _ HtmlType:=xlHtmlStatic) .Publish (True) End With 'Read all data from the htm file into RangetoHTML Set fso = CreateObject("Scripting.FileSystemObject") Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2) RangetoHTML = ts.readall ts.Close RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _ "align=left x:publishsource=") 'Close TempWB TempWB.Close savechanges:=False 'Delete the htm file we used in this function Kill TempFile Set ts = Nothing Set fso = Nothing Set TempWB = Nothing End Function 

感谢您的时间和帮助。

Answer 1

所以我find了适用于我的解决scheme，但也许不是其他问题的解决scheme。 我把我的工作簿设置为@findwidow和@ R3ukbuild议。 我只是把“On Error Resume Next”放在一个新的地方，我把附件从电子邮件中放入。

  On Error Resume Next wB.Save wB.SaveCopyAs ("C:\Users\Ken\Desktop\" & saveAs & ".xls") Set rng = Worksheets(saveAs).UsedRange Next olAtt End If 

在错误期间，它不会保存格式化的excel文件，但是现在这种情况很less发生，仅用于我们自己的文档。 它现在继续通过客户端数组的循环（实际上似乎更快）。 感谢您的帮助。