VBA 不断尝试打开工作表，但不希望它打开

Question

我有一个 VBA，可以将电子邮件从 Outlook 写入 Excel。但是，我希望此 Excel 表保持打开状态。目前我已经让工作表保持打开状态（并且只是在电子邮件进入后保存），但是每次我在我的工作簿中收到一封新电子邮件时，它都会要求我重新打开工作簿，因为 VBA 是告诉它打开工作簿。

代码如下：

Sub ExportToExcel(MyMail As MailItem)

    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
    Dim strFileName As String

    '~~> Excel Variables
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    Dim lRow As Long, fRow As Long

    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)

    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")

    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0

    '~~> Show Excel
    oXLApp.Visible = True

    '~~> Open the relevant file
    Set oXLwb = oXLApp.Workbooks.Open("\\C:\Rachael\VBAs\Control Panels.xlsm")

    '~~> Set the relevant output sheet. Change as applicable
    Set oXLws = oXLwb.Sheets("Ash Data")

    '~~> Write to outlook
    With oXLws
        '~~> Code here to output data from email to Excel File
        '~~> For example

        '* insert into last row (old alternative)
        '* you can remove this and the declare of lRow (at the top) if you don't need the old last row insert anymore.
        'lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'next new row
        '.Range("A" & lRow).Value = olMail.Body 'write into last row

        '* insert into first row
        fRow = 1 'first row
        .Rows(fRow).Insert Shift:=xlDown
        .Range("A" & fRow).Value = olMail.Body 'write into first row
    End With

    '~~> Close and Clean up Excel
    oXLwb.Save
    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing

    Set olMail = Nothing
    Set olNS = Nothing

End Sub

我不确定这段代码哪里出了问题，但也许有人知道解决这个问题的方法？

Answer 1

或者，您可以使用其他方法检查您的工作簿是否已经打开，没有错误陷阱。您可以循环浏览打开的 Excel 工作簿，并将它们与您正在寻找的 FullName ("\\C:\Rachael\VBAs\Control Panels.xlsm") 进行比较。

如果有匹配项 >> 则 Set oXLwb 到该工作簿。

如果不匹配>>然后Open相关工作簿。

代码

Dim oXLApp As Object, oXLwb As Object, oXLws As Object
Dim XLopenWB As Object
Dim Flag As Boolean

Flag = False
For Each XLopenWB In oXLApp.Workbooks
    If XLopenWB.FullName Like "\\C:\Rachael\VBAs\Control Panels.xlsm" Then
        Flag = True
        Set oXLwb = XLopenWB
        Exit For
    End If
Next XLopenWB

If Not Flag Then
    ' open the relevant workbook
    Set oXLwb = oXLApp.Workbooks.Open("\\C:\Rachael\VBAs\Control Panels.xlsm")
End If

Answer 2

正如@Shai 在 cmets 中所提到的，问题是您的宏在每次运行时都会打开 Workbook，而不管 Workbook 是否已经打开。 Siddharth Rout 对this 问题的回答提供了一个IsWorkBookOpen 函数，该函数将检查工作簿是否打开，如果返回False，您可以打开工作簿：

Function IsWorkBookOpen(FileName As String)

Dim ff As Long, ErrNo As Long

On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0

Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
End Select

End Function

然后您可以将代码更改为以下内容：

'~~> Open the relevant file
If IsWorkBookOpen("\\C:\Rachael\VBAs\Control Panels.xlsm") Then
    Set oXLwb = oXLApp.Workbooks("Control Panels.xlsm")
Else
    Set oXLwb = oXLApp.Workbooks.Open("\\C:\Rachael\VBAs\Control Panels.xlsm")
End If