vba - 重复计数

Question

我正在从 Outlook 导入数据，并且只想导入字段中没有重复的电子邮件。

我已经尝试过 DCount，它正在工作，但它仍然会复制表单中的最后一条记录。因此，如果我导入 9 封电子邮件，然后再次点击该按钮，它将不会导入任何内容，除了表单中的最后一封电子邮件。不知道为什么仍然允许那个人通过代码......

Dim Olapp As Outlook.Application
    Dim Olmapi As Outlook.NameSpace
    Dim Olfolder As Outlook.MAPIFolder
    Dim OlAccept As Outlook.MAPIFolder
    Dim OlDecline As Outlook.MAPIFolder
    Dim OlFailed As Outlook.MAPIFolder
    Dim OlMail As Object 'Have to late bind as appointments e.t.c screw it up
    Dim OlItems As Outlook.Items
    Dim OlRecips As Outlook.Recipients
    Dim OlRecip As Outlook.Recipient
    Dim OlAcc As Outlook.Account
    Dim abody() As String
    Dim j As Long
    Dim SID As Variant
Dim stLinkCriteria As Variant
Dim rsc As DAO.Recordset
    Dim reQuest, strRequestType, StartDate, strExPdate, strMunicipality, strAddNumber, strAddName, strCrossStreet, strTypeWork, strExtWork, strExcavator, strExcPhone, strExcCell, strExcEmail, strWorkFor As String
'Create a connection to outlook
    Set Olapp = CreateObject("Outlook.Application")
    Set Olmapi = Olapp.GetNamespace("MAPI")
'Open the inbox
    Set Olfolder = Olmapi.GetDefaultFolder(olFolderInbox)
    Set OlItems = Olfolder.Items
'Reset the olitems object otherwise new incoming mails and moving mails get missed
    Set OlItems = Olfolder.Items
    For Each OlMail In OlItems
'For each mail in the collection check the subject line and process accordingly
        If OlMail.UnRead = True Or OlMail.UnRead = False Then
        'If OlMail.Sender = "[e-mail]" Then
           ' OlMail.UnRead = False 'Mark mail as read


Set rsc = Me.RecordsetClone
If Not IsNull(Me.Requestnumber.Value) Then


SID = Me.Requestnumber.Value
stLinkCriteria = "[requestnumber]=" & "'" & SID & "'"

        If DCount("requestnumber", "import table", stLinkCriteria) > 0 Then
        'Undo duplicate entry
      Me.Undo

     End If
                  End If
                  Set rsc = Nothing

            DoCmd.GoToRecord , , acNewRec
            abody = Split(OlMail.Body, Chr(13) & Chr(10))
            For j = 0 To UBound(abody)

                If abody(j) <> "" Then     
                    If InStr(1, abody(j), "Request No.:", 1) Then
                        reQuest = Mid(abody(j), InStr(abody(j), "Request No.:") + 13)
                        Me.Requestnumber = reQuest
                    End If
                    If InStr(1, abody(j), "***", 1) Then
                        strRequestType = Trim(Mid(abody(j), InStr(abody(j), "***") + 4))
                        strRequestType = ParseWord(strRequestType, 1, , True, True)
                        If strRequestType = "R" Then
                            Me.RequestType = "ROUTINE"
                        ElseIf strRequestType = "E" Then
                            Me.RequestType = "EMERGENCY"
                        ElseIf strRequestType = "U" Then
                            Me.RequestType = "UPDATE"
                        End If
                    End If
                    If InStr(1, abody(j), "Start Date/Time:", 1) Then
                        StartDate = Mid(abody(j), InStr(abody(j), "Start Date/Time:") + 17)
                        Me.DueDate = ParseWord(StartDate, 1, , True, True)
                    End If
                    If InStr(1, abody(j), "Expiration Date:", 1) Then
                        strExPdate = Mid(abody(j), InStr(abody(j), "Expiration Date:") + 17)
                        If strExPdate = " " Then
                            Me.ExPdate = Date
                        Else
                            Me.ExPdate = strExPdate
                        End If
                    End If
                    If InStr(1, abody(j), "Municipality:", 1) Then
                        strMunicipality = Mid(abody(j), InStr(abody(j), "Municipality:") + 14)
                        Me.JobAddressTown = strMunicipality
                    End If
                    If InStr(1, abody(j), "Street:", 1) Then
                        strAddNumber = Mid(abody(j), InStr(abody(j), "Street:") + 8)
                        Me.JobAddressNumber = ParseWord(strAddNumber, 1, , True, True)
                        Me.JobAddressName = ParseWord(strAddNumber, 2, , True, True) & " " & ParseWord(strAddNumber, 3, , True, True)
                    End If

                    If InStr(1, abody(j), "Nearest Intersection:", 1) Then
                        strCrossStreet = Mid(abody(j), InStr(abody(j), "Nearest Intersection:") + 21)
                        Me.SideStreet1 = Trim(strCrossStreet)
                    End If

                    If InStr(1, abody(j), "Type of Work:", 1) Then
                        strTypeWork = Mid(abody(j), InStr(abody(j), "Type of Work:") + 14)
                        Me.TypeofWork = Trim(strTypeWork)
                    End If

If InStr(1, abody(j), "Extent of Work:", 1) Then
    strExtWork = Mid(abody(j), InStr(abody(j), "Extent of Work:") + 16)
   Me.ExtentofWork = Trim(strExtWork)
End If
                          If InStr(1, abody(j), "Working For:", 1) Then
                      strWorkFor = Mid(abody(j), InStr(abody(j), "Excavator:") + 14)
                        Me.Excavator = Trim(strExcavator)
                    End If

                    If InStr(1, abody(j), "Excavator:", 1) Then
                        strExcavator = Mid(abody(j), InStr(abody(j), "Working For:") + 11)
                        Me.workingfor = Trim(strWorkFor)
                    End If

                    If InStr(1, abody(j), "Phone:", 1) Then
                        strExcPhone = Mid(abody(j), InStr(abody(j), "Phone:") + 7)
                        Me.ExcavatorPhone = Trim(ParseWord(strExcPhone, 1, , True, True))
                    End If

                    If InStr(1, abody(j), "Cellular:", 1) Then
                        strExcCell = Mid(abody(j), InStr(abody(j), "Cellular:") + 10)
                        Me.excavatorcell = Trim(strExcCell)
                    End If

                    If InStr(1, abody(j), "Email:", 1) Then
                        strExcEmail = Mid(abody(j), InStr(abody(j), "Email:") + 7)
                        Me.ExcavatorEmail = Trim(strExcEmail)
                    End If
                End If
                 End If

以下是我正在导入的电子邮件示例：

Transmit:  Date: 

*** R O U T I N E         *** Request No.: 123456789

Operators Notified: 


Start Date/Time:    01/01/18   At 00:15  Expiration Date: 01/01/18 

Location Information: 
County:     Municipality: 
Subdivision/Community:  
Street:               0 FAKE ST
Nearest Intersection: FAKE ST
Other Intersection:    
Lat/Lon: 
Type of Work: REPAIR  
Block:                Lot:                Depth: 2FT 

Extent of Work:  BEGINS 53FT W OF C/L OF INTERSECTION AND EXTENDS 785FT
 W.  MARK A 3FT RADIUS OF POLE NUMBERS 000/000, 000/000

Remarks:  
 Working For Contact:  NO ONE

Working For: NO ONE
Address:     123 FAKE ST
City:        SPRINGFIELD
Phone:       [phone]   Ext:  

Excavator Information: 
Caller:      NO ONE
Phone:       [phone]   Ext:  

Excavator:   NO ONE

Address:     123 FAKE ST
City:        SPRINGFIELD
Phone:       [phone]   Ext:          Fax:  
Cellular:     
Email:       [e-mail]

End Request

标签： vbams-access

Answer 1

考虑这个修改后的代码。它首先从电子邮件正文中提取 RequestNumber，然后在表中搜索该数据，如果未找到，则创建一条新记录。

For Each OlMail In OlItems
    If OlMail.UnRead = True Or OlMail.UnRead = False Then
        reQuest = ""
        If InStr(1, OlMail.Body, "Request No.:", 1) Then
            reQuest = Mid(OlMail.Body, InStr(OlMail.Body, "Request No.:") + 13, 9)
        End If
        If reQuest <> "" Then
            If DCount("requestnumber", "import table", "[requestnumber]='" & reQuest & "'") = 0 Then
                'save data to record
                DoCmd.GoToRecord , , acNewRec
                Me.RequestNumber = request
                'extract rest of data
                abody = Split(OlMail.Body, Chr(13) & Chr(10))
                For j = 0 To UBound(abody)
                    If abody(j) <> "" Then
                        '...
                    End If
                Next
            End If
        End If
    End If
Next