I am trying to merge mails by extracting the last message in the a conversation thread. I want to keep the formatting intact so i am trying to get the last message along with the html. I am referencing Microsoft HTML Object Library like this
Dim mi As MailItem
Set mi = ActiveExplorer.Selection.Item(1)
Dim bhtml As HTMLBody
Set bhtml = mi.HTMLBody
This is giving a type mismatch error.
MailItem.HTMLBody property returns a string, not an HTLBody object.
I used Regex to extract the last message from the string returned by oMailitem.body property. Here is the pattern (.*(?=(From:.*\nSent:.*\nTo:))) it is a +ve look ahead i used the first item in match collection and set it in a match object than i extracted the last message like with left function like this lastmessage = Left(oMailItem.body,oMatch.firstindex)
Than i wrapped it up in html like this
Dim vResult, vLine, sResult As String
vResult = Split(lastMessage, vbCrLf)
For Each vLine In vResult
sResult = sResult & "</p><p>" & CStr(vLine)
Next
styledLastMessage = "<p>" & sResult & "</p>"
And finally appended to the mail i wanted to merge it with like this
Dim miBody() As String
miBody = Split(oMailItem.HTMLBody, "<div class=WordSection1>")
miBody(1) = "<p>" & styledLastMessage & "</p>" & "-------" & vbCrLf & miBody(1)
oMailItem.HTMLBody = Join(miBody, "<div class=WordSection1>")
Note: After <div class=WordSection1> the first message begins.
Related
I am very new to VBA (and programming in general) and I am looking to create a simple macro that will call for a few inputs from the user and flash-fill an email. The inputs being ID numbers that I want to concatenate to the end of a static URL and link in the body of the email. Skipping a bit for brevity, here's what I have so far:
`Sub Release()
Dim objMsg As MailItem
Set objMsg = Application.CreateItem(olMailItem)
Dim Obj1 As String
Obj1 = InputBox("Enter ID1", "Input Number Only"
If Obj1 <> ""
With objMsg
strEmailBody = "Hello ___" & "Object #" & Obj1 & "<a href=""http://....id=""&Obj1>(link)</a>"
.HTMLBody = strEmailBody`
Everything seems to perform well except the link, which is the static URL and does not concatenate in the input number as I'd like it to. Please advise!
I tried changing around the quotation marks and changing the whole URL to a variable, but I cannot seem to get more than just the string as typed to appear in the hyperlink.
It seems you just need to concatenate strings in VBA correctly:
strEmailBody = "Hello ___" & "Object #" & Obj1 & "(link)"
Note, you can use the Chr function for inserting double quotes where necessary.
strEmailBody = "Hello ___" & "Object #" & Obj1 & _
"(link)"
or a little simpler using single quotes for the href attribute value:
strEmailBody = "Hello ___" & "Object #" & Obj1 & _
"<a href='http://....id=" & Obj1 & "'>(link)</a>"
I need to save each email I send into a local folder. (These are then archived each month.)
I have code that works unless there are illegal characters in the subject line. I tried to insert code to strip illegal characters but always mess it up.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Call SaveACopy(Item)
End Sub
Sub SaveACopy(Item As Object)
Const olMsg As Long = 3
Dim m As MailItem
Dim savePath As String
Dim sSenderEmailAddress As String
If TypeName(Item) <> "MailItem" Then Exit Sub
Set m = Item
savePath = "C:\Users\Email-SENT\"
savePath = savePath & Format(Now(), "(yy.mm.dd-hh.NN ss) - ") & m.Subject & " (T) " & m.To
savePath = savePath & ".msg"
m.SaveAs savePath, olMsg
End Sub
You can use string-related functions available in VBA. For example, the Replace function returns a string, which is a substring of a string expression beginning at the start position (defaults to 1), in which a specified substring has been replaced with another substring a specified number of times. The return value of the Replace function is a string, with substitutions made, that begins at the position specified by start and concludes at the end of the expression string. It's not a copy of the original string from start to finish. So, you can strip out any illegal characters.
Also I'd suggest handling the ItemAdd of the Items class (which comes from the Sent Items folder) instead. The ItemSend event is fired when the item submitted but not being sent actually. So, any other software which handles the ItemSend event may cancel any further processing by setting the Cancel parameter to true. But when the mail item was sent out in Outlook the sent item is put to the Sent Items folder. Actually, it can be any folder if you set the SaveSentMessageFolder property which sets a Folder object that represents the folder in which a copy of the email message will be saved after being sent. For example:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim SentFolder As Folder
Dim desFolder As Folder
If TypeName(Item) = "MailItem" And Item.DeleteAfterSubmit = False Then
'Specify the sent emails
If InStr(Item.To, "shirley") > 0 Or InStr(LCase(Item.Subject), "test") > 0 Then
'Specify the folder for saving the sent emails
'You can change it as per your needs
Set SentFolder = Application.Session.GetDefaultFolder(olFolderSentMail)
Set desFolder = SentFolder.Folders("Test")
Set Item.SaveSentMessageFolder = desFolder
End If
End If
End Sub
So, then you could save sent items to the disk, not items that were submitted, but not sent yet.
Please, try the next function. It offer the possibility to replace all the illegal characters with a common legal one. Or eliminate them:
Function ReplaceIllegChars(strClean As String, strChar As String) As String
Dim strCharsToElim As String, i As Long, strSolved As String
strCharsToElim = "~""#%&*:<>,#?{|}/\[]" & Chr(10) & Chr(13)
For i = 1 To Len(strCharsToElim)
strClean = Replace(strClean, Mid$(strCharsToElim, i, 1), strChar)
Next
ReplaceIllegChars = strClean
End Function
I am not the 'father' of the above function... I found it on internet some time before, added some other characters and personalized according to my need.
You may add other characters in strCharsToElim, too.
You can test it in the next way:
Sub testReplaceIllegChars()
Dim x As String, strCorrect As String
x = "<>,today,]|[%tomorrow\?#/"
Debug.Print ReplaceIllegChars(x, "_")
Debug.Print ReplaceIllegChars(x, "") 'to only replace them...
strCorrect = ReplaceIllegChars(m.Subject, "_")
End Sub
In order to use it in your code, please replace the following code line:
savePath = savePath & Format(Now(), "(yy.mm.dd-hh.NN ss) - ") & m.Subject & " (T) " & m.To
with:
Dim strCorrect As String
strCorrect = ReplaceIllegChars(m.Subject, "_")
savePath = savePath & Format(Now(), "(yy.mm.dd-hh.NN ss) - ") & strCorrect & " (T) " & m.To
'your existing code...
I'm trying to change outlook email signatures automatically depending on a specific keyword on the subject.
On my first try I added the signature at the bottom of the email.
The signature came perfect including image and all but that there was an issue with the placement as the signature was appended at the very bottom of the email below the original text.
On my second try I set up a default signature that works as a placeholder. The macro then finds the placeholder and replaces it with the correct signature. The macro works and inserts the signature in the correct location but now the signature image is not showing up.
A couple weird things with the issue:
Image issue occurs only when composing new email. Image comes in correctly when replying or forwarding.
Signature looks okay on sender's outlook client (i.e. image is displayed before sending email).
Signature is not displayed on recipient's outlook client (tried outlook and iOS mail).
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim objMail As Outlook.MailItem
Dim strSignatureFile As String
Dim objFileSystem As Object
Dim objTextStream As Object
Dim strSignature As String
Dim sPath As String
If TypeOf Item Is MailItem Then
Set objMail = Item
emailSubject = "T " & LCase(objMail.Subject)
End If
test = "keyWord"
If InStr(emailSubject, test) = 0 Then
sPath = Environ("appdata") & "\Microsoft\Signatures\signature1.htm"
signImageFolderName = "signature1_files"
Else
sPath = Environ("appdata") & "\Microsoft\Signatures\signature2.htm"
signImageFolderName = "signature2_files"
End If
completeFolderPath = Environ("appdata") & "\Microsoft\Signatures\" & signImageFolderName
If Dir(sPath) <> "" Then
strSignature = GetSignature(sPath)
' Now replace this incomplete file path
' with complete path wherever it is used
strSignature = VBA.Replace(strSignature, signImageFolderName, completeFolderPath)
Else
strSignature = ""
End If
'Insert the signature to this email
bodySignature = "<HTML><BODY><br>" & strSignature & "</br></HTML></BODY>"
objMail.HTMLBody = Replace(objMail.HTMLBody, "SingaturePlaceHolder", bodySignature)
End Sub
Function GetSignature(fPath As String) As String
Dim fso As Object
Dim TSet As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
GetSignature = TSet.readall
TSet.Close
End Function
I have an application that will fill out the To/Subject/Body of an outlook email:
Dim App As New Outlook.Application
Dim MailItem As Outlook._MailItem = DirectCast(App.CreateItem(Outlook.OlItemType.olMailItem), Outlook._MailItem)
Dim appDataDir As String = Environment.GetFolderPath(Environment.SpecialFolder.ApplicationData) + "\Microsoft\Signatures"
Dim Signature As String = String.Empty
Dim diInfo As New DirectoryInfo(appDataDir)
If diInfo.Exists Then
Dim fiSignature As FileInfo() = diInfo.GetFiles("*.htm")
If fiSignature.Length > 0 Then
Dim sr As New StreamReader(fiSignature(0).FullName, Encoding.[Default])
Signature = sr.ReadToEnd()
If Not String.IsNullOrEmpty(Signature) Then
Dim fileName As String = fiSignature(0).Name.Replace(fiSignature(0).Extension, String.Empty)
Signature = Signature.Replace(fileName & Convert.ToString("_files/"), (Convert.ToString(appDataDir & Convert.ToString("/")) & fileName) + "_files/")
End If
End If
End If
With MailItem
.To = "asdf"
.Subject = "asdf"
.Body = txtTemplatePreview.Text & vbNewLine
End With
MailItem.Display(True)
So the function of the first If Then statement is to append my default signature to the end of the email. However, when this code is run, the signature that is appended looks to be HTML code instead of the signature itself.
In addition, I'm told that the first If Then statement will fail if the user has more than one signature. Is there a way to circumvent this?
Work with HTMLBody Property
The property Returns or sets a String representing the HTML body of the specified item. The HTMLBody property should be an HTML syntax string. Read/write.
There is no need to do any of that - the signature is added automatically when Display is called if you do not set the Body or HTMLBody property before that.
I have tried to make a script to pick up emails as they come in, reformat them and then forward on to the email in the body but I cannot work out how to read the email body. I currently have:
Sub Confirmation()
myMessage = "You recently made a request on the IT website, the details of your
request can be seen below:" & vbCr & vbCr & "Thank you, " & vbCr & "IT Support"
Dim itmOld As MailItem, itmNew As MailItem
Set itmOld = ActiveInspector.CurrentItem
Set itmNew = itmOld.Forward
itmNew.Body = myMessage & vbCr & vbCr & itmOld.Body
itmNew.Subject = "IT Web Request Confirmation"
itmNew.Display
Set itmOld = Nothing
Set itmNew = Nothing
End Sub
This opens the email adds some text to it and forwards it on.
I would like the script to open the email, read an email address from the body, use that as the to field and reformat the existing email to a nicer format.
This is the HTML from the email:
<html><body><br /><br /><table><tr><td><b>Fullname: </b></td><td>Alex Carter</td></tr><tr><td><b>OPS_Access: </b></td><td>Yes</td></tr><tr><td><b>Email_Account_Required: </b></td><td>Yes</td></tr><tr><td><b>Office_Email_Required: </b></td><td>Yes</td></tr><tr><td><b>Website_Access_Required: </b></td><td>Yes</td></tr><tr><td><b>Web_Access_Level: </b></td><td>Staff</td></tr><tr><td><b>Forum_Access_Required: </b></td><td>Yes</td></tr><tr><td><b>Date_Account_Required: </b></td><td>03/08/2013</td></tr><tr><td><b>Requested_By: </b></td><td>Alex Carter</td></tr><tr><td><b>Requestee_Email: </b></td><td>alex.carter#cars.co.uk</td></tr><tr><td><b>Office_Requesting: </b></td><td>Swindon</td></tr></table></body></html>
This shows that the email to go into the to field is in the 10th row of the table but I am not too sure how to go about selecting this from the body?
How would I go about reading the body, reformatting it and then selecting the requestee email and using it as the to field?
Thanks in advance!
This should help you get started (modifying your code), though you'll have to be more specific with regard to what formatting improvements you would like to see...:
Sub Confirmation()
myMessage = "You recently made a request on the IT website, the details of your request can be seen below:" & vbCr & vbCr & "Thank you, " & vbCr & "IT Support"
Dim sAddress As String ' Well need this to store the address
Dim itmOld As MailItem, itmNew As MailItem
Set itmOld = ActiveInspector.CurrentItem
Set itmNew = itmOld.Forward
sAddress = GetAddressFromMessage(itmOld) ' This is our new function
If Len(sAddress) > 0 Then
itmNew.To = sAddress ' If our new function found a value apply it to the To: field.
'!!! This should be checked as a valid address before continuing !!!
End If
itmNew.Body = myMessage & vbCr & vbCr & itmOld.Body
itmNew.Subject = "IT Web Request Confirmation"
itmNew.Display
Set itmOld = Nothing
Set itmNew = Nothing
End Sub
Private Function GetAddressFromMessage(msg As MailItem) As String
' Grabs the email from the standard HTML form described in the SO question.
Dim lStart As Long
Dim lStop As Long
Dim sItemBody As String
Const sSearchStart As String = "Requestee_Email: </b></td><td>" ' We will look for these tags to determine where the address can be found.
Const sSearchStop As String = "</td>"
sItemBody = msg.HTMLBody ' Read the body of the message as HTML to retain TAG info.
lStart = InStr(sItemBody, sSearchStart) + Len(sSearchStart)
If lStart > 0 Then ' Make sure we found the first TAG.
lStop = InStr(lStart, sItemBody, sSearchStop)
End If
GetAddressFromMessage = vbNullString
If lStop > 0 And lStart > 0 Then ' Make sure we really did find a valid field.
GetAddressFromMessage = Mid(sItemBody, lStart, lStop - lStart)
End If
End Function