我正在从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 = "nj@occinc.com" 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: 555-555-5555 Ext:
Excavator Information:
Caller: NO ONE
Phone: 555-555-5555 Ext:
Excavator: NO ONE
Address: 123 FAKE ST
City: SPRINGFIELD
Phone: 555-555-5555 Ext: Fax:
Cellular:
Email: EMAIL@EMAIL.COM
End Request
答案 0 :(得分：0)
考虑此修订代码。它首先从电子邮件正文中提取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