The code you posted is a jumble of bits and pieces that you apparently have not even tried to start connecting. Many of your Subs and Functions have no End Sub or End Function. It's hard to imagine any of it working at all, at least not the way you posted it.

What you want is possible, but not with Outlook VBA code, unless you want to walk around to every machine and copy the code into the Outlook VBA environment for every user and thus give them a new toolbar button that they'd have to remember to use to reply just to these messages (which doesn't seem likely).

Have you thought about building the approval process into macros in the Excel spreadsheet itself? You could use custom properties to stamp the spreadsheet with each successive approver and create a new message, attaching the spreadsheet, to forward it on to the next person in the approval chain.

--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003
http://www.turtleflock.com/olconfig/index.htm
and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers
http://www.outlookcode.com/jumpstart.aspx

wrote in message oups.com...
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 = "

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