R
rrmando
Hello everyone. First time on here. We are using an automated excel
file that emails itself as an attachment for approvals. Sometimes up to
4 approvals are required. The approver replies to the email and it
continues down the line.
The excel spreadsheet currently copies and pastes itself in the body of
the email because the attachment does not remain with the replies, so
the approver can always refer to the document in the body of the email.
We cannot forward. Is there some VBA code I can use to retain the
attachment with the replies?
I found the code below, but cannot get it to work. I am a rookie with
VBA, so I am either doing something wrong or this code would not work
for what weare trying to do. Any help/suggestions will be greatly
appreciated. Thankyou all in advance.
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
Set itm = GetCurrentItem()
Set Reply = itm.ReplyAll
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
This is the current code I have in the Excel file. I was trying to get
the code above to work with this:
Dim EmailTo As String
Dim oApp As Object
Dim oItem As Object
Dim recipients As String
recipients = "(e-mail address removed)"
EmailTo = recipients
Set oApp = CreateObject("Outlook.Application", "localhost")
Set oItem = oApp.CreateItem(0)
With oItem
...To = EmailTo
...Subject = NewName
...Attachments.Add ActiveWorkbook.FullName
...Body = "Please approve this purchase requisition by replying directly
to
this email. If you have question about this Req, please email or call
the re
quester separately. Do not reply to this message if you do not approve
it. T
hanks"
...HTMLBody = SheetToHTML(ActiveSheet)
...Importance = 1
...Send
End With
Set oItem = Nothing
Set oApp = Nothing
End Sub
Public Function SheetToHTML(SH As Worksheet)
'Function from Dick Kusleika his site
'http://www.dicks-clicks.com/excel/sheettohtml.htm
'Changed by Ron de Bruin 04-Nov-2003
Dim TempFile As String
Dim Nwb As Workbook
Dim myshape As Shape
Dim fso As Object
Dim ts As Object
SH.Copy
Set Nwb = ActiveWorkbook
For Each myshape In Nwb.Sheets(1).Shapes
myshape.Delete
Next
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Set Nwb = Nothing
Kill TempFile
file that emails itself as an attachment for approvals. Sometimes up to
4 approvals are required. The approver replies to the email and it
continues down the line.
The excel spreadsheet currently copies and pastes itself in the body of
the email because the attachment does not remain with the replies, so
the approver can always refer to the document in the body of the email.
We cannot forward. Is there some VBA code I can use to retain the
attachment with the replies?
I found the code below, but cannot get it to work. I am a rookie with
VBA, so I am either doing something wrong or this code would not work
for what weare trying to do. Any help/suggestions will be greatly
appreciated. Thankyou all in advance.
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
Set itm = GetCurrentItem()
Set Reply = itm.ReplyAll
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
This is the current code I have in the Excel file. I was trying to get
the code above to work with this:
Dim EmailTo As String
Dim oApp As Object
Dim oItem As Object
Dim recipients As String
recipients = "(e-mail address removed)"
EmailTo = recipients
Set oApp = CreateObject("Outlook.Application", "localhost")
Set oItem = oApp.CreateItem(0)
With oItem
...To = EmailTo
...Subject = NewName
...Attachments.Add ActiveWorkbook.FullName
...Body = "Please approve this purchase requisition by replying directly
to
this email. If you have question about this Req, please email or call
the re
quester separately. Do not reply to this message if you do not approve
it. T
hanks"
...HTMLBody = SheetToHTML(ActiveSheet)
...Importance = 1
...Send
End With
Set oItem = Nothing
Set oApp = Nothing
End Sub
Public Function SheetToHTML(SH As Worksheet)
'Function from Dick Kusleika his site
'http://www.dicks-clicks.com/excel/sheettohtml.htm
'Changed by Ron de Bruin 04-Nov-2003
Dim TempFile As String
Dim Nwb As Workbook
Dim myshape As Shape
Dim fso As Object
Dim ts As Object
SH.Copy
Set Nwb = ActiveWorkbook
For Each myshape In Nwb.Sheets(1).Shapes
myshape.Delete
Next
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Set Nwb = Nothing
Kill TempFile