我为Outlook 2007整理了一些VBA代码，这些代码一直很好用。 它基本上用于检查传入的消息并将主题，正文等存储到数据库中并将附件存储到文件夹中。一般情况下，它工作正常，但在100条消息中，它会丢弃奇怪的电子邮件。
我以前遇到过一些问题，其中一些电子邮件没有被处理并存储在数据库中，但后来发现存在非法字符的问题，我现在已经解决了，所以不能这样。我已经将丢弃的电子邮件与消息标题，内容与字段之间的内容进行了比较，我根本看不到两个电子邮件之间的任何差异，所以我完全感到困惑为什么他们被丢弃当我复制电子邮件的内容并再次将其转发回系统时，VBA代码处理得很好。
我粘贴下面的代码（代码链接到一些用于检查非法字符或连接字符串的模块）
Sub SaveIncomingEmails(Items As Outlook.MailItem) ' enable this to run macro inbound emails
Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection
' ================================================================
' Open a Connection using an ODBC DSN named "Delphi".
' ================================================================
cnn.Open "MyDB", "MyUsername", "MyPassword"
' ================================================================
' Constants declaration
' ================================================================
Const olFolderInbox = 6
Const olTxt = 0
' ================================================================
' variable declaration
' ================================================================
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim SenderName As String
Dim i As Integer
Dim strSQLquery As String
Dim strSQLquery1 As String
Dim strSQLGTDResourceQuery As String
Dim MessageHeader As String
Dim strCommandQuery As String
Dim strGTDIdQuery As String
Dim AttachmentStr As String
Dim strFailedRcp As String
Dim strSubject As String
Dim hasattachment As String
Dim AttachmentType As String
Dim SenderAuthorised As String
Dim strToEmail As String
Dim strFromEmail As String
Dim strBody As String
Dim strSentDate As String
Dim strReceivedDate As String
Dim StrUniqueID As String
Dim strCommandDate As String
Dim strDomain As String
Dim strBodyStripped As String
Dim strSubjectStripped As String
Dim rs As Object
Dim strGoalId As String
Dim strFile As String
Dim strSenderAccountDescription As String
Dim strContentType As String
Dim strMimeVersion As String
Dim strReceived As String
' ================================================================
' Intializing variables
' ================================================================
i = 0
Set objItem = Items
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set colMailItems = objFolder.Items
Set Item = objItem
strToEmail = Items.To
strFromEmail = Items.SenderEmailAddress
strSubject = Items.Subject
strBody = Items.Body
strSentDate = Items.SentOn
strReceivedDate = Items.ReceivedTime
'Initialize variables in a given format
StrUniqueID = Format(Items.ReceivedTime, "ddmmyyyyhhnnss") & Items.SenderEmailAddress
strCommandDate = Format(Items.ReceivedTime, "mm/dd/yyyy_hh:nn:ss")
' Grab the sender domain by stripping the last portion of the email address using the getdomain function
strDomain = Module2.GetDomain(Items.SenderEmailAddress)
' Strip the body of illegal characters and replace with legal characters for insertion into SQL
strBodyStripped = Module3.RemoveIllegalCharacters(Items.Body)
strSubjectStripped = Module4.RemoveIllegalCharacters(Items.Subject)
AttachmentStr = "images/no_attachment.png"
' ================================================================
' ================================================================
' ================================================================
' =====================================================
' Check list of authorised senders for xsCRM commands.
' Populate email addresses here
' =====================================================
If (InStr(strFromEmail, "AuthorisedSender1@email.com") > 0) Or (InStr(strFromEmail, "AuthorisedSender2@email.com") > 0) Or (InStr(strFromEmail, "AuthorisedSender3@email.com") > 0) Then
SenderAuthorised = "true"
End If
' ======================================================
' ======================================================
' ======================================================
' ================================================================
' check if subject holds a command
' ================================================================
'check to see if email sender is authorised
If SenderAuthorised = "true" Then
' Check if the subject line contains the string xs4crm is true
If InStr(strSubject, "xs4crm") > 0 Then
'If its true then do this
strCommandQuery = "INSERT INTO XSCRMEMAILCOMMAND (" & vbCrLf & _
"FromEmail," & vbCrLf & _
"command," & vbCrLf & _
"date," & vbCrLf & _
"Body" & vbCrLf & _
") VALUES ('" & strFromEmail & "','" & strSubject & "',GETDATE(),'" & strBody & "')"
Set rs = cnn.Execute(strCommandQuery)
'Look for a GTDID string so that we can save data to resources table
If InStr(strSubject, "gtdid=") > 0 Then
'Set the hasattachment variable to zero since we only want to run this loop if there are no attachments
hasattachment = "0"
'Set the variable to 1 so that we that our next if statement can only run if there are no attachments
For Each Atmt In Item.Attachments
hasattachment = "1"
Next Atmt
If hasattachment = "0" Then
'Grab the GTDId so we know which goal this resource belongs too.
strGoalId = Module5.GetHeaderProperty(strSubject, "gtdid=", ";", 5)
'Save data to table
strGTDIdQuery = "INSERT INTO XSCRMGTDRESOURCES (" & vbCrLf & _
"GoalId," & vbCrLf & _
"insertdatetime" & vbCrLf & _
") VALUES ('" & strGoalId & "',GETDATE())"
Set rs = cnn.Execute(strGTDIdQuery)
End If
End If
End If
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Create folders for atttachments
' ================================================================
' Save any attachments found
For Each Atmt In Item.Attachments
AttachmentStr = "images/attachment.png" 'because it has gone into attachment loop the icon is now required.
'Create the subfolder for the attachment if it doesnt exist based on sender domain
Dim fso
Dim fol As String
fol = "c:\OLAttachments\" & strDomain
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fol) Then
fso.CreateFolder (fol)
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' save attachments
' ================================================================
FileName = "C:\OLAttachments\" & strDomain & "\" & _
Format(Item.CreationTime, "ddmmyyyy-") & Items.SenderEmailAddress & "-" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
strFile = Atmt.FileName
strSQLquery1 = "INSERT INTO XSCRMEMAILSATTACHMENTS (" & vbCrLf & _
"FileSavedIn," & vbCrLf & _
"ActualFileName," & vbCrLf & _
"UniqueIdentifier," & vbCrLf & _
"SendersEmail" & vbCrLf & _
") VALUES ('" & FileName & "','" & StrUniqueID & "','" & strFile & "','" & strFromEmail & "')"
Set rs = cnn.Execute(strSQLquery1)
'If there is a GTDCommand, then grab the GTDId so we know which goal this resource belongs too.
If InStr(strSubject, "gtdid=") > 0 Then
strGoalId = Module5.GetHeaderProperty(strSubject, "gtdid=", ";", 5)
End If
AttachmentType = ""
'If the attachment is png or jpg set attachment type string to image
If (InStr(Atmt.FileName, ".png") > 0) Or (InStr(Atmt.FileName, ".jpg") > 0) Then
AttachmentType = "image"
End If
'If attachment is .mov set attachment type string to video
If InStr(Atmt.FileName, ".mov") > 0 Then
AttachmentType = "video"
End If
'If the attachment is mp3 or m4a set attachment type string to audio
If (InStr(Atmt.FileName, ".mp3") > 0) Or (InStr(Atmt.FileName, ".m4a") > 0) Then
AttachmentType = "audio"
End If
'check to see if email sender is authorised
If SenderAuthorised = "true" Then
'If attachment type is an image, audio or video as per extensions above then populate the xscrmgtdresource table with following fields
If (InStr(Atmt.FileName, ".png") > 0) Or (InStr(Atmt.FileName, ".jpg") > 0) Or (InStr(Atmt.FileName, ".mov") > 0) Or (InStr(Atmt.FileName, ".m4a") > 0) Or (InStr(Atmt.FileName, ".mp3") > 0) Then
strSQLGTDResourceQuery = "INSERT INTO XSCRMGTDRESOURCES (" & vbCrLf & _
"GoalId," & vbCrLf & _
"Title," & vbCrLf & _
"Type," & vbCrLf & _
"insertdatetime," & vbCrLf & _
"ResourcePath," & vbCrLf & _
"UniqueIdentifier" & vbCrLf & _
") VALUES ('" & strGoalId & "','" & Atmt.FileName & "','" & AttachmentType & "',GETDATE(),'" & FileName & "','" & StrUniqueID & "')"
End If
Set rs = cnn.Execute(strSQLGTDResourceQuery)
End If
Next Atmt
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Setting up to work with the Email Message Header
' ================================================================
'This accesses the message header property and sets the variable MessageHeader
Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E"
MessageHeader = objItem.PropertyAccessor.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS)
If MessageHeader <> "" Then
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Accessing the message header and collecting specific info for database tables
' ================================================================
strSenderAccountDescription = Module5.GetHeaderProperty(MessageHeader, "From:", "<", 5)
strContentType = Module5.GetHeaderProperty(MessageHeader, "Content-Type:", ";", 13)
strMimeVersion = Module5.GetHeaderProperty(MessageHeader, "MIME-Version:", vbNewLine, 13)
strReceived = Module5.GetHeaderProperty(MessageHeader, "Received:", "(", 9)
'As the x-failed-recipients property does not appear in ALL messageheaders, we have to first check if it is present
If InStr(MessageHeader, "X-Failed-Recipients:") > 0 Then
'Get the MessageHeader Property value
strFailedRcp = Module5.GetHeaderProperty(MessageHeader, "X-Failed-Recipients:", vbNewLine, 20)
'Else set the variable value to blank so that we still have something to supply to the SQL query
Else
strFailedRcp = ""
End If
' ================================================================
' ================================================================
' ================================================================
' ================================================================
' Save Email into the database DeplphiDude and table xsCRMEmails for attachment based emails and without attachments
' ================================================================
If InStr(strSubject, "xs4crm") = 0 Then 'only insert if the emails is not a command
strSQLquery = "INSERT INTO XSCRMEMAILS (" & vbCrLf & _
"XFailedRecipients," & vbCrLf & _
"Received," & vbCrLf & _
"MimeVersion," & vbCrLf & _
"ContentType," & vbCrLf & _
"SendersAccountDescription," & vbCrLf & _
"FromEmail," & vbCrLf & _
"ToEmail," & vbCrLf & _
"Subject," & vbCrLf & _
"Body," & vbCrLf & _
"SentDate," & vbCrLf & _
"ReceivedDate," & vbCrLf & _
"UniqueIdentifier," & vbCrLf & _
"Status," & vbCrLf & _
"AttachmentIcon," & vbCrLf & _
"AssignedToUser," & vbCrLf & _
"EmailHeader" & vbCrLf & _
") VALUES ('" & strFailedRcp & "','" & strReceived & "','" & strMimeVersion & "','" & strContentType & "','" & strSenderAccountDescription & "', '" & strFromEmail & "','" & strToEmail & "','" & strSubjectStripped & "','" & strBodyStripped & "','" & strSentDate & "','" & strReceivedDate & "','" & StrUniqueID & "','EmailStatus_New','" & AttachmentStr & "','','" & Module4.RemoveIllegalCharacters(MessageHeader) & "')"
Set rs = cnn.Execute(strSQLquery)
End If
' ================================================================
' final steps
' ================================================================
'Delete email
objItem.Delete
Set objItem = Nothing
Set Atmt = Nothing
' ================================================================
' close connection to the sql server and end the program
' ================================================================
cnn.Close
End Sub
答案 0 :(得分：3)
答案 1 :(得分：0)
首先，您不要说您的流程的哪个部分无法正常工作。你已经展示了一个不会自行触发的例程，它必须由其他东西调用。这个东西必须附加一些条件来调用你的日常工作。这些是什么？你能否证明这一点的运作方式。
如果您使用的是规则，那么您是否可以显示规则的条件。更进一步说，如果不是规则，我们在VBEditor中为事件编码，以便您也可以看到此事件发生？这是我正在谈论的内容，并且有关于如何执行此操作的示例代码MSDN Application_New_MAIL
接下来我同意其他所有人你需要一些记录，有太多的事情发生，并且不可能分辨出鳕鱼在哪里摔倒。如果我是你，我会收到一封不起作用的电子邮件，并将其发送给自己，并在代码的开头有一个断点，以便您可以看到。你的代码实际上被调用了，然后它被失败了。