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

正如@Shai在评论中所提到的，问题是您的宏在每次运行时都会打开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

Answer 2

或者，您可以使用其他方法检查您的工作簿是否已打开，没有错误陷阱。您可以遍历打开的Excel工作簿，并将它们与您要查找的FullName进行比较（"\\C:\Rachael\VBAs\Control Panels.xlsm"）。

如果匹配＆gt;＆gt;然后Set oXLwb到那个工作簿。

如果没有匹配＆gt;＆gt;然后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

VBA一直试图打开工作表，但不想要它

2 个答案: