StackOverflow2013

Note that there are some explanatory texts on larger screens.

plurals

POMy outlook VBA code drops the odd email
primarykey
Id
6150178
data
AcceptedAnswerId
6152254
AnswerCount
2
ClosedDate
CommentCount
4
CommunityOwnedDate
CreationDate
2011-05-27T09:16:04.580
FavoriteCount
0
LastActivityDate
2015-02-23T19:26:53.233
LastEditDate
2015-02-23T19:26:53.233
LastEditorUserId
3204551
OwnerUserId
591918
ParentId
0
PostTypeId
1
Score
2
ViewCount
2070
LastEditorDisplayName
text
Body
I put together some VBA code for Outlook 2007 which has been working predominantly fine. Its basically designed to check incoming messages and store the subject, body etc into a database and the attachment into a folder. In general, it works fine, but out of 100 messages or so, it drops the odd email. I previously had a problem where some emails were not being processed and stored in the database, but then discovered there was an issue with illegal characters, which i have solved now, so that cant be it. I've compared the emails being dropped to the one's that arent, in terms of message header, content to and from fields and i cant see any difference between the two emails at all, so am completely perplexed as to why they're being dropped. When i copy the content of the email and forward it back to the system again, the VBA code processes it fine. I am pasting the code below (the code links to some modules which are used for checking illegal characters or concatenating strings) <pre><code>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 </code></pre>
Tags
<vba><outlook><outlook-vba>
Title
My outlook VBA code drops the odd email
singulars
PostAcceptedAnswerId
1. PO
 singulars
 PostTypePostTypeId
 PTAnswer
PostParentId
1. This table or related slice is empty.
PostTypePostTypeId
1. PTQuestion
UserLastEditorUserId
1. This table or related slice is empty.
UserOwnerUserId
1. USKhuram Malik
plurals
PostLinksPostIdRelatedPostId
1. This table or related slice is empty.
PostLinksRelatedPostIdPostId
1. This table or related slice is empty.
PostsAcceptedAnswerId
1. This table or related slice is empty.
PostsParentIdCreationDate
1. PO
 singulars
 PostTypePostTypeId
 PTAnswer
2. PO
 singulars
 PostTypePostTypeId
 PTAnswer
VotesPostIdCreationDate
1. VO
 singulars
 PostPostId
 POMy outlook VBA code drops the odd email
 UserUserId
 This table or related slice is empty.
 VoteTypeVoteTypeId
 VTUpMod
2. VO
 singulars
 PostPostId
 POMy outlook VBA code drops the odd email
 UserUserId
 This table or related slice is empty.
 VoteTypeVoteTypeId
 VTUpMod
CommentsPostId

Querying!

Guidance

A row detail

Detail views are divided into sections. All the information in the data section comes from columns in the selected row. The other sections display data from other, related rows.

Related data can be related in a to-one or a to-many fashion. Captions of data related in a to-many fashion link to a list view showing a filtered view of the table.

Try moving around until you find a non-empty to-many entry and click on the label to get to one. You can move back to the root by clicking on the database name in the header.