Question

我创建了一个VBA模块：

在outlook中搜索特定的电子邮件
从找到的电子邮件中抓取excel文件附件
格式化excel文件附件（添加颜色和网格以使其看起来更具可呈现性）
将格式化的Excel文件保存到我的桌面
使用格式化的Excel文件作为附件向我们的客户发送电子邮件（并将excel文件粘贴到电子邮件正文中）

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

我的代码工作得很好，并且多次没有问题。但是，每次处理时都会随机弹出“1004运行时错误”。当我调试时，我需要'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", "client1@email.com")
Call Reports(email_1)

f = 1

email_2 = Array("C:\User\Desktop\", "CA Test Results", "CA_Reports", "client2@email.com")
Call Reports(email_2)

f = 2

email_3 = Array("C:\User\Desktop\", "NY Test Results", "NY_Reports", "client3@email.com")
Call Reports(email_3)

email_4 = Array("C:\User\Desktop\", "TX Test Results", "TX_Reports", "client4@email.com")
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

所以我找到了一个适合我的解决方案，但也许不是其他有同样问题的解决方案。我将我的工作簿设置为@findwidow和@ R3uk建议。我只是把＆＃34; On Error Resume Next＆＃34;并将一个额外的副本保存在一个新的地方，我将附件从中拉出来放在电子邮件中。

                 On Error Resume Next
                 wB.Save

                 wB.SaveCopyAs ("C:\Users\Ken\Desktop\" & saveAs & ".xls")

                 Set rng = Worksheets(saveAs).UsedRange
             Next olAtt
    End If

它不会在错误期间保存格式化的excel文件，但是现在这种情况很少发生，而且仅适用于我们自己的文档。它现在可以轻松地继续通过客户端阵列循环（实际上看起来更快）。谢谢你的帮助。

ActiveWorkbook.Save上的VBA'1004'错误

1 个答案: