I want to replace in the active email the "text1" with "text2" . Here is my code:
Sub Custmod()
Dim olItem As Outlook.MailItem
Dim objOL As Outlook.Application
Dim olOutMail As Outlook.MailItem
Dim sText As String
Dim vText As String
Dim strBody As String
Set objOL = Application
Set objItem = objOL.ActiveInspector.CurrentItem
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.body
vText = Split(sText, Chr(13))
For i = 1 To UBound(vText)
If InStr(1, vText(i), "TEXT1") Then
olItem.body = Replace(vText(i), "TEXT2", "")
Next i
End Sub
Any help is welcomed. Thank you.
It looks like you are trying to use an array when not needed.
Replace works on multiple instances of the same word.
Option Explicit
Sub Custmod()
Dim olItem As mailItem
Set olItem = CreateItem(olMailItem)
olItem.body = "TEXT1" & Chr(13) & "Here is some stuff." & Chr(13) & "TEXT1 again."
olItem.Display
MsgBox olItem.body
olItem.body = Replace(olItem.body, "TEXT1", "TEXT2")
MsgBox olItem.body
Set olItem = Nothing
End Sub
Related
.Body of Mailitem is not returning anything
I am using the entryID to get access to the inbound email and set the object using Application.Session.GetItemFromID
strID = olitem.EntryID
Set olitem = Application.Session.GetItemFromID(strID)
Once I set olitem
Set olitem = Application.Session.GetItemFromID(strID)
it shows the email has been accessed, but when sText = olitem.Body is run stext ends up empty.
Here is the entire code that is fired from an Outlook Rule.
Sub ParseEPDMRequest(olitem As Outlook.MailItem)
Dim arr() As String
Dim ECONum As String
Dim ReqID As String
Dim sText As String
Dim strID As String
strID = olitem.EntryID
Set olitem = Application.Session.GetItemFromID(strID)
sText = olitem.Body
arr = Split(olitem.Body, ":")
arr = Split(arr(15), " ")
ECONum = GetECONum(arr(8))
sText = olitem.Subject
ReqID = GetReqId(sText)
Call TEAMtoEPDMPush(ECONum & ".xml", ReqID)
End Sub
Under certain circumstances the message can have no plain text body. You have to check the format of the body (see BodyFormat property):
strID = olitem.EntryID
Set olitem = Application.Session.GetItemFromID(strID)
If olitem.BodyFormat=OlBodyFormat.olFormatPlain Then
sText = olitem.Body
...
ElseIf olitem.BodyFormat=OlBodyFormat.olFormatHTML Then
...
I get a generated report by Oracle web app every week. I got a macro working to extract that attachment report from my email, but for some reason the date filter doesn't do anything and it saves all the attachments with the email subject "VERIPRD: XXVER Veritiv Aging Report Main: PETROP01" (which is the subject of the report that I want, but I get this weekly, and I only need to extract the most current one)
Also, the report comes with a .out extension which can be opened up with Excel, but if I save that file within the macros as xlsx it gets corrupted.
So what I need is for this macro to actually filter by date, and Subject line (mentioned above), save the .out file as an Excel file titled "Aging Report" and, if there's already an "Aging Report" in destination folder, to replace that previous excel file and not prompt with a message asking me if I want to replace it.
Here's the code I have so far which I put in MS outlook:
Public Sub Extract_Outlook_Email_Attachments()
Dim OutlookOpened As Boolean
Dim outApp As Outlook.Application
Dim outNs As Outlook.NameSpace
Dim outFolder As Outlook.MAPIFolder
Dim outAttachment As Outlook.attachment
Dim outItem As Object
Dim saveFolder As String
saveFolder = "C:\Users\borjax01\Desktop\aging reports"
Dim outMailItem As Outlook.MailItem
Dim inputDate As String, subjectFilter As String
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\" & "Aging
Report.out"
inputDate = InputBox("Enter date to filter the email subject", "Extract
Outlook email attachments")
If inputDate = "" Then Exit Sub
InputDateFilter = inputDate
subjectFilter = ("VERIPRD : XXVER Veritiv Aging Report Main : PETROP01")
OutlookOpened = False
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set outApp = New Outlook.Application
OutlookOpened = True
End If
On Error GoTo 0
If outApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
Exit Sub
End If
Set outNs = outApp.GetNamespace("MAPI")
Set outFolder = outNs.PickFolder
If Not outFolder Is Nothing Then
For Each outItem In outFolder.Items
If outItem.Class = Outlook.OlObjectClass.olMail Then
Set outMailItem = outItem
If outMailItem.Subject = subjectFilter Then
Debug.Print outMailItem.Subject
For Each outAttachment In outMailItem.Attachments
outAttachment.SaveAsFile saveFolder
Set outAttachment = Nothing
Next
End If
End If
Next
End If
If OutlookOpened Then outApp.Quit
Set outApp = Nothing
End Sub
A post might get answers more quickly if broken into multiple single questions as is expected in this Q & A.
Public Sub Extract_Outlook_Email_Attachments()
Dim OutlookOpened As Boolean
Dim OutApp As outlook.Application
Dim outNs As outlook.Namespace
Dim outFolder As outlook.MAPIFolder
Dim outAttachment As outlook.Attachment
Dim outItem As Object
Dim saveFolder As String
Dim outMailItem As outlook.MailItem
Dim inputDate As String, subjectFilter As String
Dim fldrItems As Items
Dim resultItems As Items
Dim strFilter As String
saveFolder = "C:\Users\borjax01\Desktop\aging reports"
saveFolder = "H:\test2"
'If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\" & "Aging Report.out"
If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"
' subjectFilter = ("VERIPRD : XXVER Veritiv Aging Report Main : PETROP01")
' No "Re:" nor "Fw:"
subjectFilter = "VERIPRD : XXVER Veritiv Aging Report Main : PETROP01"
OutlookOpened = False
On Error Resume Next
Set OutApp = getObject(, "Outlook.Application")
If Err.number <> 0 Then
Set OutApp = New outlook.Application
OutlookOpened = True
End If
On Error GoTo 0
If OutApp Is Nothing Then
MsgBox "Cannot start Outlook.", vbExclamation
Exit Sub
End If
Set outNs = OutApp.GetNamespace("MAPI")
Set outFolder = outNs.PickFolder
If Not outFolder Is Nothing Then
Set fldrItems = outFolder.Items
strFilter = "[Subject] = '" & subjectFilter & "'"
Debug.Print strFilter
Set resultItems = fldrItems.Restrict(strFilter)
'Debug.Print resultItems.count
resultItems.Sort "[ReceivedTime]", True
For Each outItem In resultItems
If outItem.Class = outlook.OlObjectClass.olMail Then
Set outMailItem = outItem
If outMailItem.subject = subjectFilter Then
Debug.Print " outMailItem.subject: " & outMailItem.subject
Debug.Print " outMailItem.ReceivedTime: " & outMailItem.ReceivedTime
For Each outAttachment In outMailItem.Attachments
Debug.Print " outAttachment.DisplayName: " & outAttachment.DisplayName
If InStr(outAttachment.DisplayNamem, ".out") Then
outAttachment.SaveAsFile saveFolder & outAttachment.DisplayName
Exit Sub '<-- exit when most recent is saved
End If
Next
End If
End If
Next
End If
If OutlookOpened Then OutApp.Quit
Set OutApp = Nothing
End Sub
I have a macro that will open a reply to a selected email with a template. However, the rest of the images in the email machine now just showe a red cross.
Can anyone see why this might be happening?
Sub TacReply()
Dim origEmail As MailItem
Dim replyEmail As MailItem
Set origEmail = Application.ActiveExplorer.Selection(1)
Set replyEmail = Application.CreateItemFromTemplate("S:\Share\TWGeneral.oft")
replyEmail.To = origEmail.SenderEmailAddress
replyEmail.Subject = origEmail.Subject
replyEmail.HTMLBody = replyEmail.HTMLBody & origEmail.Reply.HTMLBody
replyEmail.SentOnBehalfOfName = "email#address.com"
replyEmail.Display
End Sub
Thanks :)
Just in case anyone has the same problem, here was the solution I used:
Sub Forward_Mail_Outlook_With_Signature_Html_2()
Dim MyItem As Object
Dim MyFwdItem As MailItem
Dim SigString As String
Dim Signature As String
Set MyItem = ActiveExplorer.Selection(1).reply
If MyItem.Class = olMail Then
Set MyFwdItem = MyItem.Forward
'Change only Mysig.htm to the name of the signature
SigString = Environ("appdata") & _
"\Microsoft\Signatures\Your Signature.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
With MyFwdItem
.To = MyFwdItem.SenderEmailAddress
.subject = MyFwdItem.subject
.HTMLBody = "<br>" & Signature & .HTMLBody
.SentOnBehalfOfName = "youremail#address.com"
.Display
End With
Else
MsgBox "Select a mailitem."
End If
ExitRoutine:
Set MyItem = Nothing
Set MyFwdItem = Nothing
End Sub
Private Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
I am running the following script on the event that I receive an email from a specific address with a specific subject. The goal is to tag an email with a hyperlink that will be useful for the recipient of said email to have in the original message's body.
Option Explicit
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
'On Error Resume Next
Set objOL = Application
strID = MyMail.EntryID
Set MyMail = Application.Session.GetItemFromID(strID)
If Not MyMail Is Nothing Then
Set objNS = objOL.Session
MyMail.BodyFormat = olFormatHTML
If MyMail.BodyFormat = olFormatHTML Then
MsgBox ("set to html")
End If
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
MsgBox ("Hyperlink appended!")
Else
MsgBox ("Failure!")
End If
End Sub
While I get the message box telling me that the proper event occurred it appears that no actual changes are made (or are not being saved properly?).
This is the first work I have done with any kind of programming. I've gone through some tutorials for VB specifically, but I am very new to this. Any help/guidance is much appreciated!
This is a classic case of needing to use Option Explicit to require explicit variable declarations. Use this, since you are learning VBA. Also avoid the habit of using On Error Resume Next as this ignores all error handling.
You might not realize this but you are referring to your mail item in the following ways:
MyMail
objItem
objMsg
objMail
Note that the following two commands
objMsg.HTMLBody
objMail.Save
are performed on non-existent objects.
Remove the above three extra references:
Sub Megatron(MyMail As MailItem)
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objItem As Object
Dim strID As String
Dim strLink As String
Dim strNewText As String
Dim strLinkText As String
strLink = "http://www.example.com"
strLinkText = "Click on this Example!"
strNewText = "<p><a href=" & Chr(34) & strLink & _
Chr(34) & ">" & strLinkText & "</a></p>"
MyMail.HTMLBody = Replace(MyMail.HTMLBody, "</body>", _
strNewText, 1, 1, vbTextCompare)
MyMail.Save
end Sub
You also don't need the cleanup either.
I need a rule (or most probably a VBA macro) to sort my mails. In case I have per say "REPORT" in the filename of the attachment of a newly received mail than I would like to move that mail to a different folder, let say "REPORTS" folder.
How can I achieve this?
I already to set a rule on the mail header but that did not seem to solve the matter.
Thanks in advance!
Used code from http://www.outlookcode.com/article.aspx?id=62 and http://blog.saieva.com/2010/03/27/move-messages-to-folders-with-outlook-vba/
'code goes in "ThisOutlookSession" module
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim arr() As String
Dim i As Integer
Dim ns As Outlook.NameSpace
Dim itm As MailItem
Dim m As Outlook.MailItem
Dim att As Outlook.Attachment
On Error Resume Next
Set ns = Application.Session
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set itm = ns.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
If m.Attachments.Count > 0 Then
For Each att In m.Attachments
If UCase(att.FileName) Like "*REPORT*" Then
MoveToFolder m, "MoveTest"
Exit For
End If
Next att
End If
End If
Next
Set ns = Nothing
Set itm = Nothing
Set m = Nothing
End Sub
Sub MoveToFolder(mItem As MailItem, folderName)
'###you need to edit this for your account name###
Const mailboxNameString As String = "Mailbox - firstname lastname"
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olDestFolder As Outlook.MAPIFolder
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olDestFolder = olNameSpace.Folders(mailboxNameString).Folders(folderName)
Debug.Print "[" & Date & " " & Time & "] " & _
": folder = " & folderName & _
"; subject = " & mItem.Subject & "..."
mItem.Move olDestFolder
End Sub