Question

所以我在Mcirosoft Outlook中有这个代码。代码在新邮件进入时运行，并根据发件人的名称和附件，保存文本文件并将数据导入2个访问数据库，并运行数据库中预先构建的某些查询。当来自正确的发件人且具有正确附件的2封电子邮件进入时代码出错。代码正确处理第一封电子邮件，但是当第二封电子邮件被处理时，代码在下面的粗线处出错。

Option Explicit
Private Sub Application_NewMail()

Dim ns As NameSpace
Dim inbox As MAPIFolder
Dim Item As MailItem
Dim atmt As Attachment
Dim fso As FileSystemObject
Dim fs As TextStream
Dim dt, invfn, misfn, invdr, misdr, dbfn As String
Dim invt, mist As Boolean
Dim db As Object

Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set fso = New FileSystemObject

If inbox.UnReadItemCount = 0 Then
    Exit Sub
    Else
    For Each Item In inbox.Items.Restrict("[UnRead] = True")
        If Item.SenderName = "Menon, Jayesh" Then
            dt = Left(Right(Item.Subject, 12), 10)
            For Each atmt In Item.Attachments
                If atmt.FileName = "InvalidLoans.txt" Then
                    invfn = "ERLMF_InvalidLoans_" & dt & ".txt"
                    invdr = "C:\Documents and Settings\U299482\Desktop\Data Drop\" & _
                    invfn
                    atmt.SaveAsFile invdr                    
                    Set fs = fso.OpenTextFile(invdr)
                    If fs.Read(23) = "Invalid Loans Count = 0" Then
                        invt = False
                        Else
                        invt = True
                    End If
                    fs.Close
                End If
                If atmt.FileName = "MissingLoans.txt" Then
                    misfn = "ERLMF_MissingLoans_" & dt & ".txt"
                    misdr = "C:\Documents and Settings\U299482\Desktop\Data Drop\" & _
                    misfn
                    atmt.SaveAsFile misdr
                    Set fs = fso.OpenTextFile(misdr)
                    If fs.Read(23) = "Missing Loans Count = 0" Then
                        mist = False
                        Else
                        mist = True
                    End If
                    fs.Close
                End If
            Next
            If invt = True Or mist = True Then
                Set db = CreateObject("Access.Application")
                dbfn = "C:\Documents and Settings\U299482\Desktop\Databases\BPDashboard.accdb"
                With db
                    .OpenCurrentDatabase dbfn, True
                    .Visible = True
                    If invt = True Then
                        .DoCmd.TransferText acImportDelim, "Lns_Spec", "Invalid_Lns", invdr, True
                    End If
                    If mist = True Then
                        .DoCmd.TransferText acImportDelim, "Lns_Spec", "Missing_Lns", misdr, True
                    End If
                    .Quit
                End With
                Set db = Nothing
            End If
            If invt = True Then
                Set db = CreateObject("Access.Application")
                dbfn = "C:\Documents and Settings\U299482\Desktop\Databases\CORE IDP.accdb"
                With db
                    .OpenCurrentDatabase dbfn, True
                    .Visible = True
                    **CurrentDb.Execute "A0_Empty_ERLMF_InvalidLoans_2013-04-02", dbFailOnError**
                    .DoCmd.TransferText acImportDelim, "Lns_Spec", "ERLMF_InvalidLoans_2013-04-02", invdr, True
                    CurrentDb.Execute "AppendERLMF", dbFailOnError
                    CurrentDb.Execute "FaxRF Crystal Append", dbFailOnError
                    .Quit
                End With
                Set db = Nothing
            End If
            Item.UnRead = False
        End If
    Next
End If

End Sub

Answer 1

我认为你正在获得重叠.Execute命令。您需要确保第一次执行在开始下一次之前完成。要修复，我首先声明一个公共变量Executing，然后将下面的代码移动到自己的方法中。

Sub Execute()

  Executing = True

  Set db = CreateObject("Access.Application")
  dbfn = "C:\Documents and Settings\U299482\Desktop\Databases\CORE IDP.accdb"
  With db
    .OpenCurrentDatabase dbfn, True
    .Visible = True
    CurrentDb.Execute "A0_Empty_ERLMF_InvalidLoans_2013-04-02", dbFailOnError
    .DoCmd.TransferText acImportDelim, "Lns_Spec", "ERLMF_InvalidLoans_2013-04-02", invdr, True
    CurrentDb.Execute "AppendERLMF", dbFailOnError
    CurrentDb.Execute "FaxRF Crystal Append", dbFailOnError
    .Quit
  End With
  Set db = Nothing

  Executing = False

End Sub

然后，在调用该函数时，用一个循环来包围它，该循环测试Executing是否为假。

Do
  If Executing = False Then
    Execute
    Exit Do
  End If
Loop

远程服务器计算机不存在或不可用（错误＃462）

1 个答案: