A
Alan Campbell
Hello,
I have the code below which produces an email based on an Excel
spreadsheet range. Everthing is working fine except the response to my
"V_Approved" selection. When a voucher is approved, I want the
original HTML based message included in the response. When I look at
the message in Outlook, prior to responding, the action item created
indicates the "include original message text" is activated.
Can anybody help explain why this is happening? Thanks in advance for
looking at This.
Alan
Sub Mail_Selection_Outlook_Body()
'Is not working in Office 97
Dim source As Range
Dim dest As Workbook
Dim myshape As Shape
Dim OutApp As Object
Dim OutMail As Object
Dim MyAction
'Dim strName As Object
'Set ObjAction = Item.Actions.Add
Set source = Nothing
On Error Resume Next
Set source =
Range("Print_Form").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If source Is Nothing Then
MsgBox "The selection is not a range or the sheet is protect"
& _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Copy
Set dest = ActiveWorkbook
For Each myshape In dest.Sheets(1).Shapes
myshape.Delete
Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Set outmail = outapp.item.add.
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = Range("Vouch_Code") & " Voucher Approval Request -
Acct " & _
Application.text(Range("Acct_1"), "####-###-####") & " - "
& _
Application.text(Range("Voucher_Amount"), "$###.##") & " -
" & Application.text(Right(Range("'Voucher Form.xls'!prepared_by"),
6), "00####")
.HTMLBody = RangetoHTML
'.Send 'or use
.Display
End With
Set MyAction = OutMail.Actions.Add
With MyAction
.CopyLike = olRespond
.Enabled = True
.Prefix = ""
.ReplyStyle = olIncludeOriginalText
.ResponseStyle = olPrompt
.ShowOn = olMenuAndToolbar
.Name = "V_Approved"
End With
Set MyAction = OutMail.Actions.Add
With MyAction
.CopyLike = olRespond
.Enabled = True
.Prefix = ""
.ReplyStyle = olOmitOriginalText
.ResponseStyle = olPrompt
.ShowOn = olMenuAndToolbar
.Name = "V_Rejected"
End With
dest.Close False
Set OutMail = Nothing
Set OutApp = Nothing
Set dest = Nothing
Application.ScreenUpdating = True
End Sub
Function RangetoHTML()
Dim fso As Object
Dim ts As Object
Dim TempFile As String
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
source:=Range("Print_Form").Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function
I have the code below which produces an email based on an Excel
spreadsheet range. Everthing is working fine except the response to my
"V_Approved" selection. When a voucher is approved, I want the
original HTML based message included in the response. When I look at
the message in Outlook, prior to responding, the action item created
indicates the "include original message text" is activated.
Can anybody help explain why this is happening? Thanks in advance for
looking at This.
Alan
Sub Mail_Selection_Outlook_Body()
'Is not working in Office 97
Dim source As Range
Dim dest As Workbook
Dim myshape As Shape
Dim OutApp As Object
Dim OutMail As Object
Dim MyAction
'Dim strName As Object
'Set ObjAction = Item.Actions.Add
Set source = Nothing
On Error Resume Next
Set source =
Range("Print_Form").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If source Is Nothing Then
MsgBox "The selection is not a range or the sheet is protect"
& _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Copy
Set dest = ActiveWorkbook
For Each myshape In dest.Sheets(1).Shapes
myshape.Delete
Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Set outmail = outapp.item.add.
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = Range("Vouch_Code") & " Voucher Approval Request -
Acct " & _
Application.text(Range("Acct_1"), "####-###-####") & " - "
& _
Application.text(Range("Voucher_Amount"), "$###.##") & " -
" & Application.text(Right(Range("'Voucher Form.xls'!prepared_by"),
6), "00####")
.HTMLBody = RangetoHTML
'.Send 'or use
.Display
End With
Set MyAction = OutMail.Actions.Add
With MyAction
.CopyLike = olRespond
.Enabled = True
.Prefix = ""
.ReplyStyle = olIncludeOriginalText
.ResponseStyle = olPrompt
.ShowOn = olMenuAndToolbar
.Name = "V_Approved"
End With
Set MyAction = OutMail.Actions.Add
With MyAction
.CopyLike = olRespond
.Enabled = True
.Prefix = ""
.ReplyStyle = olOmitOriginalText
.ResponseStyle = olPrompt
.ShowOn = olMenuAndToolbar
.Name = "V_Rejected"
End With
dest.Close False
Set OutMail = Nothing
Set OutApp = Nothing
Set dest = Nothing
Application.ScreenUpdating = True
End Sub
Function RangetoHTML()
Dim fso As Object
Dim ts As Object
Dim TempFile As String
TempFile = Environ$("temp") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
With ActiveWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
filename:=TempFile, _
Sheet:=ActiveSheet.Name, _
source:=Range("Print_Form").Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
Set ts = Nothing
Set fso = Nothing
Kill TempFile
End Function