Create Macro for hyperlink(email) in message body

Status
Not open for further replies.

Alfredo Duran

New Member
Outlook version
Outlook 2010 64 bit
Email Account
Office 365 Exchange
I would like some help with a macro. I receive an email from dig alerts everyday and I have a rule that sends them to my task folder. When I open the email, I would like to create a macro so when I click on the hyperlink that is included in the message body, runs the macro and sends it to a template that will put the hyperlink on the To box, the subject will say "USA Dig Alert Notification" and the Body will have "NO CONFLICT" and the original message below that. I will upload some files to see what I mean. Any help is really appreciated. Thank You.
 

Attachments

Alfredo Duran

New Member
Outlook version
Outlook 2010 64 bit
Email Account
Office 365 Exchange
Ok maybe this would be much easier. How do I reply to a link in an email to open a template I have created already?
 

Michael Bauer

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
Getting the mouse click on the link would be difficult. Instead parse the body of the email for the link and if found, call the Reply function for that email. For parsing the Body either use the Instr function if you know what words to look for, or use regular expressions. The latter isn't easy for most beginners, search this forum for samples, for sure Diane has some for you.
 

Alfredo Duran

New Member
Outlook version
Outlook 2010 64 bit
Email Account
Office 365 Exchange
Thanks Michael. I was able to piece together a code that did partially what I wanted. It put the email from the original email body into a reply email in the To: field and copied the original email into the new reply email.Now I just need help with changing the subject to say "USA Dig Alert" and I want to include "No conflict" also in the body along with the original email. I will include the code to see if someone can suggest how to go about it.
 

Alfredo Duran

New Member
Outlook version
Outlook 2010 64 bit
Email Account
Office 365 Exchange
Sub ReplyTest()
Dim objItem As Object
Dim intLocAddress As Integer
Dim intLocCRLF As Integer
Dim strAddress As String
Dim objReply As MailItem

Set objItem = GetCurrentItem()
If objItem.Class = olMail Then
' find the requestor address
strAddress = ParseTextLinePair(objItem.Body, "Requestor Email:")

' create the reply, add the address and display
Set objReply = objItem.Reply
objReply.To = strAddress
objReply.Display

End If

Set objReply = Nothing
Set objItem = Nothing
End Sub

Function ParseTextLinePair(strSource As String, strLabel As String)
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String

' locate the label in the source text
intLocLabel = InStr(strSource, strLabel)
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
strText = Mid(strSource, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText)
End Function

Function GetCurrentItem() As Object
Dim objApp As Outlook.Application

Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.currentItem
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select

Set objApp = Nothing
End Function
 

Michael Bauer

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
To add something at the beginning of the Body property, write this
Code:
objReply.Body = "new stuf" & vbcrlf & objReply.Body
As to the Subject property, guess how you would set that one.
 

Alfredo Duran

New Member
Outlook version
Outlook 2010 64 bit
Email Account
Office 365 Exchange
Ok I got it to work Michael. Now how change I change the font color on the objReply.Body = "NO CONFLICT WITH SEWER MAINTENANCE FORCE MAIN" to a red font. Thanks for the help!

Sub ReplyTest()
Dim objItem As Object
Dim intLocAddress As Integer
Dim intLocCRLF As Integer
Dim strAddress As String
Dim objReply As MailItem

'this gets the subject from original email
Set objItem = GetCurrentItem()
If objItem.Class = olMail Then
' find the requestor address
strAddress = ParseTextLinePair(objItem.Body, "Email: ")
'strAddress = email in original body of Dig Alert
' create the reply, add the address and display
'Set objReply puts RE: xxxxx into subject field objItem.Reply
Set objReply = objItem.Reply
'puts email address from orig. email into new email To: field
objReply.To = strAddress
'removes the Re: in the subject
objReply.subject = "USA Dig Alert"
objReply.subject = Replace(objReply.subject, "Re:", "", , , vbTextCompare)
strStyle = "'font-family:" & Chr(34) & "Calibri" & Chr(34) & ";color:red'"
objReply.Body = "NO CONFLICT WITH SEWER MAINTENANCE FORCE MAIN." & vbNewLine & vbNewLine & vbNewLine & objItem.Body
objReply.Display

End If

Set objReply = Nothing
Set objItem = Nothing
End Sub

Function GetCurrentItem() As Object
Dim objApp As Outlook.Application

Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.CurrentItem 'Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select

Set objApp = Nothing
End Function

Function ParseTextLinePair(strSource As String, strLabel As String)
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String

' locate the label in the source text
intLocLabel = InStr(strSource, strLabel) 'strLabel adds email in body to To: Field
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
strText = Mid(strSource, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText)
End Function
 

Michael Bauer

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
In that case you need to use html instead of plain text. Replace .Body by .HTMLBody, and add strStyle as a css style attribut to the text.
 

Alfredo Duran

New Member
Outlook version
Outlook 2010 64 bit
Email Account
Office 365 Exchange
Thanks Michael. Figured it out and it has been working with no glitches. Now I have another problem. I share my task folder with other co-workers. They use this macro to reply to my emails that are shared on the task folder. Work will not allow me to delegate access to them so they can send on my behalf, so can I add something to the macro to change the From: field to them instead of from me? Here is the current macro I have.

Sub Reply()
Dim objItem As Object
Dim intLocAddress As Integer
Dim intLocCRLF As Integer
Dim strAddress As String
Dim objReply As MailItem

'this gets the subject from original email
Set objItem = GetCurrentItem()
If objItem.Class = olMail Then
' find the requestor address
strAddress = ParseTextLinePair(objItem.Body, "Email: ")
'strAddress = email in original body of Dig Alert
' create the reply, add the address and display
'Set objReply puts RE: xxxxx into subject field objItem.Reply
Set objReply = objItem.Reply
'puts email address from orig. email into new email To: field
objReply.To = strAddress
'removes the Re: in the subject
objReply.subject = "USA Dig Alert"
objReply.subject = Replace(objReply.subject, "Re:", "", , , vbTextCompare)
objReply.Body = "NO CONFLICT WITH SEWER MAINTENANCE FORCE MAIN." & vbNewLine & vbNewLine & vbNewLine & objItem.Body
objReply.Display

End If

Set objReply = Nothing
Set objItem = Nothing
End Sub

Function GetCurrentItem() As Object
Dim objApp As Outlook.Application

Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.CurrentItem 'Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
Case Else
' anything else will result in an error, which is
' why we have the error handler above
End Select

Set objApp = Nothing
End Function

Function ParseTextLinePair(strSource As String, strLabel As String)
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String

' locate the label in the source text
intLocLabel = InStr(strSource, strLabel) 'strLabel adds email in body to To: Field
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
strText = Mid(strSource, _
intLocLabel, _
intLocCRLF - intLocLabel)
Else
intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText)
End Function
 

Michael Bauer

Senior Member
Outlook version
Outlook 2010 32 bit
Email Account
Exchange Server
If you're connected to an Exchange server, you can use the SentOnBehalfOfName property.
 
Status
Not open for further replies.
Top