Question

让我首先简要说明我的项目目前完成的工作。我在“ ThisOutlookSession”中有3个子例程。一个检查最后30个未读邮件，然后将主题发送给检查其内容以查找关键字的子邮件；另一个检查相同内容，但处理Items_ItemAdd事件（新收到的邮件），而我暗示已检查的最后一个子邮件主题行，如果找到关键字，则调用名为“ ExcelConnection”的模块，这就是问题的根源。

在“ ExcelConnection”模块中，我有以下代码可打开工作簿：

    var model = new TestDTO() { Foo = "abc", Nested = new NestedClass()};
    JsonPatchDocument<TesDTO> patchDoc = new JsonPatchDocument<TestDTO>();
    patchDoc.Replace(e => e.Foo , model.Foo );
    patchDoc.Replace(e => e.Nested.Bar, model.Nested.Bar);

问题是：此过程大约需要一分钟左右的时间，然后经过ExitSave点，在该点保存，关闭工作簿，然后应用程序“退出”，但如果有另一个一封邮件在它完成运行之前出现，并且“ ExitSaving”出现错误，提示我无法打开工作簿，因为它已经打开。这也将停止初始实例，结果是工作簿在后台保持打开状态，无法手动关闭它，也无法对其进行编辑，因为它一直说正在被“另一个用户”（Outlook）修改。

是否有任何方法告诉宏等待所有操作完成后再运行？仅当两封带有关键字的邮件在不到一分钟的时间内相互收到时，这种情况才会发生。

如果您有任何疑问或需要更多代码示例，请告诉我！谢谢。

编辑： 这是“ ExcelConnection”模块的代码，该模块由电子邮件主题行中的关键字触发。

Dim oXL As Object
Dim oWS As Object
Dim lngRow As Long

Set oXL = CreateObject("Excel.Application")
oXL.Workbooks.Open FileName:="T:\Capstone Proj\TimeStampsOnly.xlsx", AddTOMRU:=False, UpdateLinks:=False

'// Change sheet name to suit
Set oWS = oXL.Sheets("TimeStamps")

感谢大家的帮助。

Answer 1

我不习惯从Outlook中操纵Excel，因此此代码可能需要进行一些调整。子Main将继续检查特定的工作簿，直到它被打开并且不是只读的为止。完成代码后，它关闭工作簿并退出循环。唯一的缺点是，代码将继续运行，直到可以访问工作簿为止。您可以添加一个计数器来跟踪尝试次数，并在达到特定次数后退出。

功能ExtractName和WorkbookIsOpen是Main下面包含的支持功能。

Public Function Main(wbkLoc As String) As Boolean
    Dim wbk As Workbook

    Do While Not WorkbookIsOpen(ExtractName(wbkLoc)) Then
        Set wbk = Workbooks.Open(wbkLoc)

        'Will open read-only if shared file is already open on another computer
        If wbk.ReadOnly Then
            wbk.Close SaveChanges:=False
        Else
            'ExcelConnection code
            wbk.Close SaveChanges:=True
            Exit Do
        End If
        DoEvents
    Loop

    Set wbk = Nothing
End Function

'Allows use of location variable in Main without hardcoding workbook name
Private Function ExtractName(longName As String) As String
    Dim lastDash As Integer
    Dim extension As Integer

    extension = InStr(1, StrReverse(longName), ".")
    lastDash = InStr(1, StrReverse(longName), "\")
    ExtractName = StrReverse(Mid(StrReverse(longName), extension + 1, lastDash - extension - 1))
End Function

' Returns true if workbook is already open on same computer
Private Function WorkbookIsOpen(rsWbkName As String) As Boolean
    On Error Resume Next
    WorkbookIsOpen = CBool(Len(Workbooks(rsWbkName).Name) > 0)
End Function

Answer 2

在Outlook中，最小自动发送和接收可以设置为1分钟，如下所示。

是的，如果您的过程需要1分钟左右，那么您可以将其增加到5分钟或任何您想要的时间，但这可能无法使您及时了解最新电子邮件。我的设置为 1分钟。您可能称我为偏执 0_0 ！

因此，当您像我一样偏执时，还有什么选择？如果有一种方法可以在 1分钟左右内而不是在 1秒左右内运行代码，那么您的问题就应该得到解决。对？：）

使用OLEDB写入Excel文件。如果相关单元格为空，则此代码将找到作业编号并写入该行，然后在少于 2秒

的时间内保存文件

Const FName As String = "T:\Capstone Proj\TimeStampsOnly.xlsx"
Const SheetName As String = "TimeStamps"

Const adUseClient = 3
Const adOpenDynamic = 2
Const adLockOptimistic = 3
Const adCmdText = &H1

Const Col_A As String = "Put Column A header here"
Const Col_B As String = "Put Column B header here"
Const Col_C As String = "Put Column C header here"
Const Col_D As String = "Put Column D header here"
Const Col_E As String = "Put Column E header here"
Const Col_F As String = "Put Column F header here"

Public Sub ExcelConnect(msg As Outlook.MailItem, LType As String)
    Dim ReceivedTime As String, jobnum As String
    Dim conString As String

    Dim objRecordset As Object, objConnection As Object

    ReceivedTime = msg.ReceivedTime
    jobnum = Trim(Right(Split(msg.Subject, "-", 2)(0), 8))

    conString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                FName & _
                ";Extended Properties=""Excel 12.0;HDR=Yes"""

    Set objConnection = CreateObject("ADODB.Connection")
    Set objRecordset = CreateObject("ADODB.Recordset")

    objConnection.Open conString

    objRecordset.CursorLocation = adUseClient
    objRecordset.Open "Select * FROM [" & SheetName & "$] WHERE " & Col_A & " ='" & jobnum & "'", _
    objConnection, adOpenDynamic, adLockOptimistic, adCmdText

    If objRecordset.RecordCount > 0 Then
        With objRecordset
            Select Case LType
                Case "MDIQE"
                    If Len(Trim(.Fields.Item(Col_C).Value)) = 0 Then
                        .Fields.Item(Col_B).Value = ReceivedTime
                        .Fields.Item(Col_C).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIQ"
                    If Len(Trim(.Fields.Item(Col_B).Value)) = 0 Then
                        .Fields.Item(Col_B).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIE"
                    If Len(Trim(.Fields.Item(Col_C).Value)) = 0 Then
                        .Fields.Item(Col_C).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIR"
                    If Len(Trim(.Fields.Item(Col_D).Value)) = 0 Then
                        .Fields.Item(Col_D).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIP"
                    If Len(Trim(.Fields.Item(Col_E).Value)) = 0 Then
                        .Fields.Item(Col_E).Value = ReceivedTime
                        .Update
                    End If
                Case "MDIF"
                    If Len(Trim(.Fields.Item(Col_F).Value)) = 0 Then
                        .Fields.Item(Col_G).Value = ReceivedTime
                        .Update
                    End If
            End Select
        End With
    End If

    objConnection.Close
End Sub

以上代码已通过我的excel文件进行了尝试和测试。如果您遇到任何问题，请告诉我，我们将尝试修复它。

Outlook VBA宏运行过于频繁时出错

2 个答案: