How do I write a VBA method that replaces the subject if there is a specific word in the subject. This code would find a certain key word (different than the subject key word) in the body of the email. It would then replace the subject line with 13 charactars after the key word found in the body of the text.
The below was already found but doesn't mention how to find anything in the body of the email. And I don't get the MAPI reference.
Any help would truly be appreciated
Thank You in advance for any assistance
Rick
Sub RewriteSubject(MyMail As MailItem)
Dim mailId As String
Dim outlookNS As Outlook.NameSpace
Dim myMailItem As Outlook.MailItem
mailId = MyMail.EntryID
Set outlookNS = Application.GetNamespace("MAPI")
Set myMailItem = outlookNS .GetItemFromID(mailId)
' Do any detection here
mailItem.Subject = "Dept - " & mailItem.Subject
myMailItem.Save
Set mailItem = Nothing
Set outlookNS = Nothing
End Sub
If it is for all new messages then you can use the following
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim v As Variant
For Each v In Array("first", "second")
If InStr(1, Item.Subject, v, vbTextCompare) <> 0 Then
SearchForAttachWords = True
End If
Next
If SearchForAttachWords = True Then
Item.Subject = "Whatever subject you want"
End If
End Sub
Hope this helps.
Related
When resolve all cannot process (due to multiple users on our system with the same first/last name) the macro fails to run. Is there a way to get outlook to display the names and let me select which john doe I want (if not then maybe just remove the names it can't resolve).
Sub Reply_All_From_Folder()
Dim original As MailItem
Dim reply As MailItem
Set original = ActiveInspector.CurrentItem.ReplyAll
Set reply = Application.CreateItem(olMailItem)
With reply
.SentOnBehalfOfName = "folder#work.com"
.Subject = original.Subject
.To = Replace(original.To, "emailoRemove#test.com", "")
.CC = original.CC
.HTMLBody = original.HTMLBody
.Recipients.ResolveAll
.Display
End With
End Sub
You can simulate pressing the Check Names button if ResolveAll is false.
Sub Reply_All_From_Folder_NotResolveAll()
Dim trueoriginal As mailItem
Dim original As mailItem
Dim reply As mailItem
Set trueoriginal = ActiveInspector.currentItem
Set original = ActiveInspector.currentItem.ReplyAll
Set reply = CreateItem(olMailItem)
With reply
.subject = original.subject
.To = original.To & "; notaresolvablename" & "; smith, john"
If Not .Recipients.ResolveAll Then
.Display
ActiveInspector.CommandBars.ExecuteMso ("CheckNames")
Else
.Send
End If
End With
trueoriginal.Close olDiscard
ExitRoutine:
Set trueoriginal = Nothing
Set original = Nothing
Set reply = Nothing
End Sub
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.
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.
I have the following code:
Option Explicit
Dim WithEvents TargetFolderItems As Items
'set the string constant for the path to save attachments
Const FILE_PATH As String = "H:\Attachment"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.Folders.Item( _
"Inbox").Folders.Item("BS CDGL").Items
End Sub
Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
Dim olAtt As Attachment
Dim i As Integer
If Item.Attachments.Count > 0 Then
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
'save the attachment
olAtt.SaveAsFile FILE_PATH & olAtt.FileName
Next
End If
Set olAtt = Nothing
End Sub
Private Sub Application_Quit()
Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing
End Sub
It throws an error at line 2 character 16, the "TargetFolderItems" part, the code is to automatically save attachments from emails in the inbox in Outlook, any help on getting this working would be much appreciated :)
Thanks
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.