I get some items duplicated when I iterate the Inbox of an IMAP folder looking for messages with a particular subject line and sender e-mail address. For instance, in Outlook application I can see just 3 messages passing the filter, but the following script results in 5 messages with one of the messages read 3 times. I have been checking and each duplicated element has different ConversationID even when the subject line and body text is the same. From where those duplicates are coming if I cannot see them in the Outlook panel?
Thanks in advance!
Private Sub GetFromFolder(ofldr)
Dim oItem
Dim oSubFldr
Dim sBadEmail
Dim matches
Dim colMail
Dim i
Dim key
Set colMail = CreateObject("Scripting.Dictionary")
i = 1
' Process all mail items in this folder
For Each oItem In ofldr.Items
If TypeName(oItem) = "MailItem" Then
With oItem
If StrComp(.Subject, g_SubjectLine) = 0 And StrComp(.SenderEmailAddress, g_SystemEmailAddress) = 0 Then
'ProcessQuery .Body
colMail.Add i, oItem
i = i + 1
End If
End With
End If
Next
For Each key In colMail.Keys
ProcessQuery colMail.Item(key).Body
Next
set colMail = Nothing
End Sub
Related
I am trying to run a VBScript that searches all the Incoming messages for a specific string on the subject field and replaces it with something else but keeping the rest of the subject content. So far, this is my code but im not getting any results.
Incoming mails subject: [EXTERNAL] abcdfed ghijk lmno
What i need: [*] abcdfed ghijk lmno
Sub RunAScriptRuleRoutine(MyMail As MailItem)
Dim strID As String
Dim olNS As Outlook.NameSpace
Dim msg As Outlook.MailItem
Dim rply As Outlook.MailItem
strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set msg = olNS.GetItemFromID(strID)
' do stuff with msg, e.g.
msg.Subject = Replace(msg.Subject, "[EXTERNAL]", "[*]")
msg.Save
Set msg = Nothing
Set olNS = Nothing
End Sub
I will appreciate your help
Changes to the subject for received messages will only be reflected in the header UI. You also have to change the MailItem.ConversationTopic value, but it is read-only. However, you can use PropertyAccessor.SetProperty("http://schemas.microsoft.com/mapi/proptag/0x0070001F", "New subject") to update it.
Excel VBA beginner coming back for more. I am creating a macro that does the following two things:
1) Searches through multiple worksheets in a single workbook for a specific piece of data (a name), variable A below
2) If that name appears, to copy a specific range of cells from the worksheet (variable X below) to the master file (variable B below)
Sub Pull_X_Click()
Dim A As Variant 'defines name
Dim B As Workbook 'defines destination file
Dim X As Workbook 'defines existing report file as source
Dim Destination As Range 'defines destination for data pulled from report
Dim ws As Worksheet
Dim rng As Range
A = Workbooks("B.xlsm").Worksheets("Summary").Range("A1").Value
Set B = Workbooks("B.xlsm")
Set X = Workbooks.Open("X.xlsm")
Set Destination = Workbooks("B").Worksheets("Input").Range("B2:S2")
'check if name is entered properly
If A = "" Then
MsgBox ("Your name is not visible; please start from the Reference tab.")
Worksheets("Reference").Activate
Exit Sub
End If
X.Activate
For Each ws In X.Worksheets
Set rng = ws.Range("A" & ws.Rows.Count).End(xlUp)
If InStr(1, rng, A) = 0 Then
Else
X.ActiveSheet.Range("$A$2:$DQ$11").AutoFilter Field:=1, Criteria1:=A
Range("A7:CD7").Select
Selection.Copy
Destination.Activate
Destination.PasteSpecial
End If
Next ws
Application.ScreenUpdating = False
End Sub
UPDATE: I managed to resolve the previous compile error, and it seems that the code (should?) work. However, it gets to this step:
X.Activate
...and then nothing happens. There's no run-time errors or anything, but it doesn't seem to be searching through the file (variable X) or pulling any of the data based on the presence of variable A. Any thoughts?
What I would've done is loop through the rows and evaluate the column in which the necessary data appears and then avoiding copy/paste just make the target range equal to the source range:
Sub SearchNCopy()
Dim A As String 'The String you are searching for
Dim b As String ' the string where you shall be searching
Dim wbs, wbt As Workbook ' Declare your workbooks
Dim wss As Worksheet
Dim i, lrow As Integer
Set wbt = Workbooks("B.xlsm") 'Set your workbooks
Set wbs = Workbooks.Open("X.xlsm")
A = wbt.Worksheets("Summary").Range("A1").Value
If A = "" Then
MsgBox ("Your name is not visible; please start from the Reference tab.")
Worksheets("Reference").Activate
Exit Sub
End If
For Each wss In wbs.Worksheets 'Loop through sheets
lrow = wss.Cells(wss.Rows.Count, "A").End(xlUp).Row 'Find last used row in each sheet - MAKE SURE YOUR SHEETS DONT HAVE BLANKS BETWEEN ENTIRES
For i = 1 To lrow Step 1 'Loop through the rows
b = wss.Range("A" & i).Value 'Assign the value to the variable from column a of the row
If Not InStr(1, b, A) = 0 Then 'Evaluate the value in the column a and if it contains the input string, do the following
wbt.Worksheets("Input").Range("B2:CC2") = wss.Range("A" & i & ":CD" & i) 'copies the range from one worksheet to another avoiding copy/paste (much faster)
End If
Next i
Next wss
End Sub
I want to use a macro in outlook 2013. This macro is supposed to mark any emails arriving a specific folder ('work' folder) as read. I'm not familiar with vb. Any help/guidance is much appreciated!
No sure, I have heard this one before of wanting emails automatically read. You have two options:
a) Use Ctrl-A (select all mail in folder), Ctrl-Q (mark selection as read)
b) Use New Email Event something like:
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
vID = Split(EntryIDCollection, ",")
Dim i as Long, objMail as Outlook.MailItem
For i = 0 To UBound(vID)
Set objMail = Application.Session.GetItemFromID(vID(i))
objMail.Unread = False
Next i
End Sub
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
' version to select folder
Dim i As Long, objMail As Outlook.MailItem, mpfInbox As Outlook.Folder
Set mpfInbox = Application.GetNamespace("MAPI").Folders("YOURACCOUNT").Folders("[Gmail]").Folders("Sent Mail")
For i = 1 To mpfInbox.Items.Count
If mpfInbox.Items(i).Class = olMail Then
Set objMail = mpfInbox.Items.Item(i)
objMail.UnRead = False
End If
Next i
End Sub
You can set up a rule which can trigger your macro.
I'd not suggest working with the NewMailEx event because it is not fired in some case and may introduce issues. See Outlook NewMail event unleashed: the challenge (NewMail, NewMailEx, ItemAdd) for more information.
trying to get some VBA code together to basically be able to run my rules from a button on my toolbar within outlook 2007. The following code runs the rules on my exchange server inbox, which is empty as everything moves to my "Personal Inbox". I just want to change the code below to read my personal inbox and not my exchange mailbox inbox. Have searched on the web and cant find my answer and hence my post -
Sub RunAllInboxRules()
Dim st As Outlook.Store
Dim myRules As Outlook.Rules
Dim rl As Outlook.Rule
Dim count As Integer
Dim ruleList As String
'On Error Resume Next
' get default store (where rules live)
Set st = Application.Session.DefaultStore
' get rules
Set myRules = st.GetRules
' iterate all the rules
For Each rl In myRules
' determine if it's an Inbox rule
If rl.RuleType = olRuleReceive Then
' if so, run it
rl.Execute ShowProgress:=True
count = count + 1
ruleList = ruleList & vbCrLf & rl.Name
End If
Next
' tell the user what you did
ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
MsgBox ruleList, vbInformation, "Macro: RunAllInboxRules"
Set rl = Nothing
Set st = Nothing
Set myRules = Nothing
End Sub
Try this. I have tested on my machine. This logs into the mailbox you are logged onto and runs the rules accordingly
Sub RunAllInboxRules()
Dim objOL As Outlook.Application
Dim st As Outlook.Store
Dim myRules As Outlook.Rules
Dim rl As Outlook.Rule
Dim count As Integer
Dim ruleList As String
Dim fldInbox As Object
Dim gnspNameSpace As Outlook.NameSpace
'On Error Resume Next
' get default store (where rules live)
'Logs into Outlook session
Set objOL = Outlook.Application
Set gnspNameSpace = objOL.GetNamespace("MAPI") 'Outlook Object
'Logs into the default Mailbox Inbox
'set the store to the mailbox
Set st = gnspNameSpace.GetDefaultFolder(olFolderInbox).Store
' get rules
Set myRules = st.GetRules
' iterate all the rules
For Each rl In myRules
' determine if it's an Inbox rule
If rl.RuleType = olRuleReceive Then
' if so, run it
rl.Execute ShowProgress:=True
count = count + 1
ruleList = ruleList & vbCrLf & rl.Name
End If
Next
' tell the user what you did
ruleList = "These rules were executed against the Inbox: " & vbCrLf & ruleList
MsgBox ruleList, vbInformation, "Macro: RunAllInboxRules"
Set rl = Nothing
Set st = Nothing
Set myRules = Nothing
End Sub
My marketing department, bless them, has decided to make a sweepstakes where people enter over a webpage. That is great but the information isn't stored to a DB of any sort but is sent to an exchange mail box as an email. Great.
My challenge is to extract the entry (and marketing info) from these emails and store them someplace more useful, say a flat file or CSV. The only saving grace is that the emails have a highly consistant format.
I am sure I could spend the time saving all the emails to files and then write an app to munge through them all but was hoping for a much more elegant solution. Can I programmatically access an exchange mailbox, read all the emails and then save that data?
Here is the code I used....
Private Sub btnGo_Click()
If ComboBox1.SelText <> "" Then
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objMail As mailItem
//Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
//Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
For Each objFolder In objInbox.Folders
If (objFolder.Name = ComboBox1.SelText) Then
Set objInbox = objFolder
End If
Next objFolder
//Loop through the items in the Inbox
Dim count As Integer
count = 1
For Each objMail In objInbox.Items
lblStatus.Caption = "Count: " + CStr(count)
If (CheckBox1.Value = False Or objMail.UnRead = True) Then
ProcessMailItem (objMail.Body)
count = count + 1
objMail.UnRead = False
End If
Next objMail
End If
End Sub
Private Sub ProcessMailItem(strBody As String)
Open "C:\file.txt" For Append As 1
Dim strTmp As String
strTmp = Replace(strBody, vbNewLine, " ")
strTmp = Replace(strTmp, vbCrLf, " ")
strTmp = Replace(strTmp, Chr(13) & Chr(10), " ")
strTmp = Replace(strTmp, ",", "_")
//Extra Processing went here (Deleted for brevity)
Print #1, strTmp
Close #1
End Sub
Private Function Strip(strStart As String, strEnd As String, strBody As String) As String
Dim iStart As Integer
Dim iEnd As Integer
iStart = InStr(strBody, strStart) + Len(strStart)
If (strEnd = "xxx") Then
iEnd = Len(strBody)
Else
iEnd = InStr(strBody, strEnd) - 1
End If
Strip = LTrim(RTrim(Mid(strBody, iStart, iEnd - iStart)))
End Function
Private Sub UserForm_Initialize()
Dim objOutlook As New Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objInbox As MAPIFolder
Dim objFolder As MAPIFolder
//Get the MAPI reference
Set objNameSpace = objOutlook.GetNamespace("MAPI")
//Pick up the Inbox
Set objInbox = objNameSpace.GetDefaultFolder(olFolderInbox)
//Loop through the folders under the Inbox
For Each objFolder In objInbox.Folders
ComboBox1.AddItem objFolder.Name
Next objFolder
End Sub
There's lots of different ways to get at the messages in an exchange mailbox, but since it seems this is something you're only going to want to run once to extract the data I'd suggest writing a VBA macro to run inside Outlook itself (having opened the exchange mailbox in question within Outlook). It's pretty easy to iterate through the mail items in a specific mailbox and read the body text from them. You can then write a text file with just the stuff you want.