Delete CDO page heading and following matter when printing an emaildocument; to print the document only
 

I have used a modified form of Ron de Bruin's macro for sending Excel
generated email via CDO. I would like to be able to print the CDO
generated document without printing the heading (To: From: Subject:
etc.) or any tags that may follow. Does anyone have a suggestion?
Thanks.

Michael


If Worksheets("DataBase").Range("R348").Value = 1 And
Worksheets("Record").Range("C21").Value 0 Then
Dim iMsg As Object
Dim iConf As Object
Dim ws As Worksheet
Dim Sourcewb As Workbook
Dim Flds As Variant
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/
sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/
smtpserver") = Worksheets("DataBase").Range("H338")
.Item("http://schemas.microsoft.com/cdo/configuration/
smtpserverport") = 25
.Update
End With
Set Sourcewb = ThisWorkbook
For Each ws In Sourcewb.Worksheets
If ws.Range("AF49").Value Like "?*@?*.?*" And
Worksheets("Record").Range("V6").Value = 1 Then 'CUSTOMER'S
CONFIRMATION
ws.Unprotect "Mimi&Papa1948"
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("AF49").Value
.From = Worksheets("Record").Range("AC52")
.Subject = "The " &
Worksheets("Record").Range("C5") & " Project Customer's E-
mail Confirmation"
.HTMLBody =
RangetoHTML(ws.UsedRange.SpecialCells(xlCellTypeVi sible))
.Send
End With
Set iMsg = Nothing
ws.Protect "Mimi&Papa1948"
End If
If ws.Range("AF49").Value Like "?*@?*.?*" And
Worksheets("Record").Range("V6").Value 1 Then 'SUB'S CONFIRMATION
ws.Unprotect "Mimi&Papa1948"
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("AF49").Value
.From = Worksheets("Record").Range("AC52")
.Subject = "The " &
Worksheets("Record").Range("C5") & " Project Information
Worksheet E-mail Confirmation"
.HTMLBody =
RangetoHTML(ws.UsedRange.SpecialCells(xlCellTypeVi sible))
.Send
End With
Set iMsg = Nothing
ws.Protect "Mimi&Papa1948"
End If
If ws.Range("AF50").Value Like "?*@?*.?*" And
Worksheets("Record").Range("V6").Value = 1 Then 'CUSTOMER'S EMAIL
ws.Unprotect "Mimi&Papa1948"
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("AF50").Value
.From = Worksheets("Record").Range("AC52")
.Subject = "The " &
Worksheets("Record").Range("C5") & " Project"
.HTMLBody =
RangetoHTML(ws.UsedRange.SpecialCells(xlCellTypeVi sible))
.Send
End With
Set iMsg = Nothing
ws.Protect "Mimi&Papa1948"
End If
If ws.Range("AF50").Value Like "?*@?*.?*" And
Worksheets("Record").Range("V6").Value 1 Then 'SUB'S EMAIL
ws.Unprotect "Mimi&Papa1948"
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = ws.Range("AF50").Value
.From = Worksheets("Record").Range("AC52")
.Subject = "The " &
Worksheets("Record").Range("C5") & " Project Information Worksheet"
.HTMLBody =
RangetoHTML(ws.UsedRange.SpecialCells(xlCellTypeVi sible))
.Send
End With
Set iMsg = Nothing
ws.Protect "Mimi&Papa1948"
End If
Next ws
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End If