Sub AA7()
Dim Tbl As Table
Dim Reply As Outlook.MailItem
Dim Original As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim first As String
Dim last As String
Dim vAddr As Variant
Dim sAddr As String
Dim mails() As Variant
Dim CCmail As String
Dim i, k As Long
Dim x As Long
If Application.ActiveExplorer.selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
Set Original = Application.ActiveExplorer.selection(1)
'Tbl.Columns(i).Delete
For Each olItem In Application.ActiveExplorer.selection
sText = olItem.body
first = InStr(1, sText, "CONFIRMATION MAIL")
last = InStr(1, sText, "Hello")
x = 0
x = last - first
MsgBox ("x = last - first so x = " & x)
vText = Split(sText, Chr(13))
For i = 1 To UBound(vText)
If InStr(1, vText(i), "@") Then
sAddr = vText(i)
'vAddr(i) = sAddr
Exit For
End If
Next i
If InStr(1, sAddr, "HYPERLINK") Then
vText = Split(sAddr, Chr(34))
For i = 1 To UBound(vText)
If InStr(1, vText(i), "@") Then
vAddr = _
vText(i)
For k = 1 To UBound(vText)
MsgBox ("vAddr value: " & vAddr)
'mails(k) = vAddr
Next k
'mails(i) = vText(i)
End If
'line 37
If InStr(1, vText(i), "@") Then
sText = Replace(vText(i), "mailto:", "")
End If
Exit For
Next i
End If
Set Reply = Original.Reply
Reply.Importance = olImportanceHigh
'Reply.Attachments.Add Original
Reply.Subject = "**PLEASE READ** " & Original.Subject
Reply.HTMLBody = Original.HTMLBody
'Code to add the original attachments to the reply mail
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In Original.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
Reply.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
'ANOTHER WAY TO TRY TO EXTRACT EMAIL ADDRESSES FROM THE BODY
Dim arr() As String
arr = Split(Original.body, vbCrLf)
Dim mailto As String
mailto = ""
Dim j As Integer
j = 0
Do Until j > 12
If InStr(StrConv(arr(j), vbLowerCase), "@") Then mailto = mailto + arr(j)
With Reply
.CC = CCmail
j = j + 1
End With
Loop
sAddr = Replace(vAddr, "mailto:", "")
Set olOutMail = olItem.Forward
With olOutMail
.To = vAddr
End With
With Reply
'Reply.To = mailto
'Reply.ReplyRecipients.Add mailto
'.Recipients.Add sAddr
.To = sText
'line 114
'MsgBox ("sText at line 115 is: " & sText)
.CC = CCmail
.SentOnBehalfOfName = "myemail@whatever.com"
End With
'Replay.CC = CCcopy
MailText = Reply.HTMLBody
Reply.HTMLBody = MailText
Reply.Display
'Reply.Send
Next olItem
CleanUp:
Set Replay = Nothing
Set Original = Nothing
Set olItem = Nothing
Set olOutMail = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = 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
End Select
Set objApp = Nothing
End Function
Sub CopyAttachments(objSourceItem, objTargetItem)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
strPath = fldTemp.Path & "\"
For Each objAtt In objSourceItem.Attachments
strFile = strPath & objAtt.FileName
objAtt.SaveAsFile strFile
objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
fso.DeleteFile strFile
Next
Set fldTemp = Nothing
Set fso = Nothing
End Sub