**Please Help** Email Excel From Access

**graviz** · 05-05-2010, 02:08 PM

I'm trying to figure out how to paste a selection of cells into the body of the e-mail and can't figure out how to do it in Access. Below is the code I use to do it from Excel and it works perfectly however I can't get it to work in Access vba. I've tried working with different code posted but have had no luck. Here is the specific info:

The Excel sheet is located: "C:\autoreports\cancel_template.xls"
The sheet name is "Report Status"
The Range I would like to copy and insert in the e-mail is "A1:D7"

Can someone assist me with modifying my code so I could do this? Let me know if you need more specifics. Thanks!!

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a range if you want
Set rng = Sheets("Sheet1").Range("A1:D7").SpecialCells(xlCel lTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
StrBody = "This is line 1" & " " & _
"This is line 2" & " " & _
"This is line 3" & " "
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "atest32@hotmail.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = StrBody & RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Here's my attempt at trying this:

Option Compare Database
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String

Dim MySheetPath As String
Dim Xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
MySheetPath = "C:\autoreports\cancel_template.xls"
Set Xl = CreateObject("Excel.Application")
Set XlBook = GetObject(MySheetPath)
XlBook.Windows(1).Visible = True
Set XlSheet = XlBook.Worksheets("Report Status")

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a range if you want
Set rng = XlSheet.Range("A1:D7").SpecialCells(xlCellTypeVisi ble)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

'With Application.
' .EnableEvents = False
' .ScreenUpdating = False
'End With
'StrBody = "This is line 1" & " " & _
' "This is line 2" & " " & _
' "This is line 3" & " "
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "atest32@hotmail.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
'.HTMLBody = StrBody & RangetoHTML(rng)
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
' With Application
' .EnableEvents = True
' .ScreenUpdating = True
' End With
Set Xl = Nothing
XlBook.Save
XlBook.Close
Set XlBook = Nothing
Set XlSheet = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Excel.Workbook
Dim Xl As Excel.Application
Dim XlSheet As Excel.Worksheet

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Xl.Application.CutCopyMode = False

On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

**PianoMan64** · 05-06-2010, 01:41 PM

Originally Posted by graviz

I'm trying to figure out how to paste a selection of cells into the body of the e-mail and can't figure out how to do it in Access. Below is the code I use to do it from Excel and it works perfectly however I can't get it to work in Access vba. I've tried working with different code posted but have had no luck. Here is the specific info:

The Excel sheet is located: "C:\autoreports\cancel_template.xls"
The sheet name is "Report Status"
The Range I would like to copy and insert in the e-mail is "A1

7"

Can someone assist me with modifying my code so I could do this? Let me know if you need more specifics. Thanks!!

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a range if you want
Set rng = Sheets("Sheet1").Range("A1

7").SpecialCells(xlCel lTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
StrBody = "This is line 1" & " " & _
"This is line 2" & " " & _
"This is line 3" & " "
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "atest32@hotmail.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = StrBody & RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x

ublishsource=", _
"align=left x

ublishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Here's my attempt at trying this:

Option Compare Database
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String

Dim MySheetPath As String
Dim Xl As Excel.Application
Dim XlBook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
MySheetPath = "C:\autoreports\cancel_template.xls"
Set Xl = CreateObject("Excel.Application")
Set XlBook = GetObject(MySheetPath)
XlBook.Windows(1).Visible = True
Set XlSheet = XlBook.Worksheets("Report Status")

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a range if you want
Set rng = XlSheet.Range("A1

7").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

'With Application.
' .EnableEvents = False
' .ScreenUpdating = False
'End With
'StrBody = "This is line 1" & " " & _
' "This is line 2" & " " & _
' "This is line 3" & " "
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "atest32@hotmail.com"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
'.HTMLBody = StrBody & RangetoHTML(rng)
.HTMLBody = RangetoHTML(rng)
.Send 'or use .Display
End With
On Error GoTo 0
' With Application
' .EnableEvents = True
' .ScreenUpdating = True
' End With
Set Xl = Nothing
XlBook.Save
XlBook.Close
Set XlBook = Nothing
Set XlSheet = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Excel.Workbook
Dim Xl As Excel.Application
Dim XlSheet As Excel.Worksheet

TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Xl.Application.CutCopyMode = False

On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x

ublishsource=", _
"align=left x

ublishsource=")

'Close TempWB
TempWB.Close savechanges:=False

'Delete the htm file we used in this function
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

Ok, There are a large degree of changes:

The main ones are what I've hilighted. You're assuming one thing, that you are in outlook. You aren't. You have to set the application objects first before anything, otherwise when you refer to Applicaton Object, it is going to assume whatever application your in. i.e. MS Access and not Outlook, like how your application refers to that.

You need to go through your code, and anywhere were it is referencing the application object, you need to make sure that the object variable is using the correct reference to Outlook instead of MS Access. This should solve your issue.

I hope that helps,

Code:

'Please make sure that you add the following references to your application:
'Microsoft Scripting Runtime
'Microsoft Outlook XX.0 Object Library
'Microsoft Excel XX.0 Object Library
 
 
Option Compare Database
Sub Mail_Selection_Range_Outlook_Body()
     Dim OutApp As Outlook.Application
   Dim rng as OutApp.Range
     Dim OutMail As OutApp.CreatItem(olMailItem)
     Dim StrBody As String
 
     Dim MySheetPath As String
     Dim Xl As Excel.Application
     Dim XlBook As Excel.Workbook
     Dim XlSheet As Excel.Worksheet
     MySheetPath = "C:\autoreports\cancel_template.xls"
     Set Xl = New Excel.Application
     Set XlBook = GetObject(MySheetPath)
     XlBook.Windows(1).Visible = True
     Set XlSheet = XlBook.Worksheets("Report Status")
 
     Set rng = Nothing
     On Error Resume Next
     'Only the visible cells in the selection
     'Set rng = Selection.SpecialCells(xlCellTypeVisible)
     'You can also use a range if you want
     Set rng = XlSheet.Range("A1:D7").SpecialCells(xlCellTypeVisible)
     On Error GoTo 0
     If rng Is Nothing Then
          MsgBox "The selection is not a range or the sheet is protected" & _
          vbNewLine & "please correct and try again.", vbOKOnly
          Exit Sub
     End If
 
     'With Application.
     ' .EnableEvents = False
     ' .ScreenUpdating = False
     'End With
     'StrBody = "This is line 1" & "<br>" & _
     ' "This is line 2" & "<br>" & _
     ' "This is line 3" & "<br><br><br>"
     Set OutApp = New Outlook.Application
     Set OutMail = OutApp.CreateItem(0)
     On Error Resume Next
     With OutMail
          .To = "atest32@hotmail.com"
          .CC = ""
          .BCC = ""
          .Subject = "This is the Subject line"
          '.HTMLBody = StrBody & RangetoHTML(rng)
          .HTMLBody = RangetoHTML(rng)
          .Send 'or use .Display
     End With
     On Error GoTo 0
     ' With Application
     ' .EnableEvents = True
     ' .ScreenUpdating = True
     ' End With
     Set Xl = Nothing
     XlBook.Save
     XlBook.Close
     Set XlBook = Nothing
     Set XlSheet = Nothing
     Set OutMail = Nothing
     Set OutApp = Nothing
End Sub
 
Function RangetoHTML(rng As Range)
     Dim fso As Object
     Dim ts As Object
     Dim TempFile As String
     Dim TempWB As Excel.Workbook
     Dim Xl As Excel.Application
     Dim XlSheet As Excel.Worksheet
 
     TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
 
     'Copy the range and create a new workbook to past the data in
     rng.Copy
     Set TempWB = Workbooks.Add(1)
     With TempWB.Sheets(1)
          .Cells(1).PasteSpecial Paste:=8
          .Cells(1).PasteSpecial xlPasteValues, , False, False
          .Cells(1).PasteSpecial xlPasteFormats, , False, False
          .Cells(1).Select
          Xl.Application.CutCopyMode = False
 
         On Error Resume Next
         .DrawingObjects.Visible = True
         .DrawingObjects.Delete
         On Error GoTo 0
     End With
 
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
    "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

If this resovles your issues, please make sure to mark it a resolved.

Joe P.

**graviz** · 05-06-2010, 03:37 PM

Originally Posted by PianoMan64

Ok, There are a large degree of changes:

The main ones are what I've hilighted. You're assuming one thing, that you are in outlook. You aren't. You have to set the application objects first before anything, otherwise when you refer to Applicaton Object, it is going to assume whatever application your in. i.e. MS Access and not Outlook, like how your application refers to that.

You need to go through your code, and anywhere were it is referencing the application object, you need to make sure that the object variable is using the correct reference to Outlook instead of MS Access. This should solve your issue.

I hope that helps,

Code:

'Please make sure that you add the following references to your application:
'Microsoft Scripting Runtime
'Microsoft Outlook XX.0 Object Library
'Microsoft Excel XX.0 Object Library
 
 
Option Compare Database
Sub Mail_Selection_Range_Outlook_Body()
     Dim OutApp As Outlook.Application
  Dim rng as OutApp.Range
     Dim OutMail As OutApp.CreatItem(olMailItem)
     Dim StrBody As String
 
     Dim MySheetPath As String
     Dim Xl As Excel.Application
     Dim XlBook As Excel.Workbook
     Dim XlSheet As Excel.Worksheet
     MySheetPath = "C:\autoreports\cancel_template.xls"
     Set Xl = New Excel.Application
     Set XlBook = GetObject(MySheetPath)
     XlBook.Windows(1).Visible = True
     Set XlSheet = XlBook.Worksheets("Report Status")
 
     Set rng = Nothing
     On Error Resume Next
     'Only the visible cells in the selection
     'Set rng = Selection.SpecialCells(xlCellTypeVisible)
     'You can also use a range if you want
     Set rng = XlSheet.Range("A1:D7").SpecialCells(xlCellTypeVisible)
     On Error GoTo 0
     If rng Is Nothing Then
          MsgBox "The selection is not a range or the sheet is protected" & _
          vbNewLine & "please correct and try again.", vbOKOnly
          Exit Sub
     End If
 
     'With Application.
     ' .EnableEvents = False
     ' .ScreenUpdating = False
     'End With
     'StrBody = "This is line 1" & "<br>" & _
     ' "This is line 2" & "<br>" & _
     ' "This is line 3" & "<br><br><br>"
     Set OutApp = New Outlook.Application
     Set OutMail = OutApp.CreateItem(0)
     On Error Resume Next
     With OutMail
          .To = "atest32@hotmail.com"
          .CC = ""
          .BCC = ""
          .Subject = "This is the Subject line"
          '.HTMLBody = StrBody & RangetoHTML(rng)
          .HTMLBody = RangetoHTML(rng)
          .Send 'or use .Display
     End With
     On Error GoTo 0
     ' With Application
     ' .EnableEvents = True
     ' .ScreenUpdating = True
     ' End With
     Set Xl = Nothing
     XlBook.Save
     XlBook.Close
     Set XlBook = Nothing
     Set XlSheet = Nothing
     Set OutMail = Nothing
     Set OutApp = Nothing
End Sub
 
Function RangetoHTML(rng As Range)
     Dim fso As Object
     Dim ts As Object
     Dim TempFile As String
     Dim TempWB As Excel.Workbook
     Dim Xl As Excel.Application
     Dim XlSheet As Excel.Worksheet
 
     TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
 
     'Copy the range and create a new workbook to past the data in
     rng.Copy
     Set TempWB = Workbooks.Add(1)
     With TempWB.Sheets(1)
          .Cells(1).PasteSpecial Paste:=8
          .Cells(1).PasteSpecial xlPasteValues, , False, False
          .Cells(1).PasteSpecial xlPasteFormats, , False, False
          .Cells(1).Select
          Xl.Application.CutCopyMode = False
 
         On Error Resume Next
         .DrawingObjects.Visible = True
         .DrawingObjects.Delete
         On Error GoTo 0
     End With
 
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
    "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

If this resovles your issues, please make sure to mark it a resolved.

Joe P.

I'm recieving an error "Compile Error: User defined type not defined" and highlighted:

"Dim rng as OutApp.Range"

**c_smithwick** · 05-06-2010, 03:54 PM

Some mistakes I've noticed. I commented out your original lines and replaced them. This is untested "air code", but should work for you.

Code:

Sub Mail_Selection_Range_Outlook_Body()
   
  'Dim rng         As Range
  Dim rng         As Excel.Range
  
  Dim OutApp      As Object
  Dim OutMail     As Object
  Dim StrBody     As String
  Dim MySheetPath As String
  Dim xl          As Excel.Application
  Dim XlBook      As Excel.Workbook
  Dim XlSheet     As Excel.Worksheet
   
  MySheetPath = "C:\autoreports\cancel_template.xls"
  Set xl = CreateObject("Excel.Application")
  
  'Set XlBook = GetObject(MySheetPath)
  Set XlBook = xl.Workbooks.Open(MySheetPath)
  
  XlBook.Windows(1).Visible = True
  Set XlSheet = XlBook.Worksheets("Report Status")
  
  Set rng = Nothing
  On Error Resume Next
  Set rng = XlSheet.Range("A17").SpecialCells(xlCellTypeVisible)
  On Error GoTo 0
   
  If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected" & _
    vbNewLine & "please correct and try again.", vbOKOnly
    Exit Sub
  End If
   
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  On Error Resume Next
   
  With OutMail
    .To = "atest32@hotmail.com"
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangetoHTML(rng)
    .Send 'or use .Display
  End With
   
  On Error GoTo 0
  Set xl = Nothing
  XlBook.Save
  XlBook.Close
  Set XlBook = Nothing
  Set XlSheet = Nothing
  Set OutMail = Nothing
  Set OutApp = Nothing
   
End Sub
Function RangetoHTML(xl As Excel.Application, rng As Excel.Range)
'Function RangetoHTML(rng As Range)
   
  Dim fso      As Object
  Dim ts       As Object
  Dim TempFile As String
  Dim TempWB   As Excel.Workbook
  'Dim XlSheet  As Excel.Worksheet - not used
   
  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  'TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  rng.Copy
  Set TempWB = xl.Workbooks.Add(1)
  'Set TempWB = Workbooks.Add(1)
   
  With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    xl.Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
  End With
   
  With TempWB.PublishObjects.Add(SourceType:=xlSourceRange, _
    FileName:=TempFile, _
    Sheet:=TempWB.Sheets(1).Name, _
    Source:=TempWB.Sheets(1).UsedRange.Address, _
    HtmlType:=xlHtmlStatic)
    .Publish (True)
  End With
   
  'Read all data from the htm file into RangetoHTML
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.ReadAll
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
  "align=left xublishsource=")
  'Close TempWB
  TempWB.Close savechanges:=False
  'Delete the htm file we used in this function
  Kill TempFile
  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
  
End Function

**graviz** · 05-07-2010, 07:02 AM

Originally Posted by c_smithwick

Some mistakes I've noticed. I commented out your original lines and replaced them. This is untested "air code", but should work for you.

Code:

Sub Mail_Selection_Range_Outlook_Body()
 
  'Dim rng         As Range
  Dim rng         As Excel.Range
 
  Dim OutApp      As Object
  Dim OutMail     As Object
  Dim StrBody     As String
  Dim MySheetPath As String
  Dim xl          As Excel.Application
  Dim XlBook      As Excel.Workbook
  Dim XlSheet     As Excel.Worksheet
 
  MySheetPath = "C:\autoreports\cancel_template.xls"
  Set xl = CreateObject("Excel.Application")
 
  'Set XlBook = GetObject(MySheetPath)
  Set XlBook = xl.Workbooks.Open(MySheetPath)
 
  XlBook.Windows(1).Visible = True
  Set XlSheet = XlBook.Worksheets("Report Status")
 
  Set rng = Nothing
  On Error Resume Next
  Set rng = XlSheet.Range("A17").SpecialCells(xlCellTypeVisible)
  On Error GoTo 0
 
  If rng Is Nothing Then
    MsgBox "The selection is not a range or the sheet is protected" & _
    vbNewLine & "please correct and try again.", vbOKOnly
    Exit Sub
  End If
 
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  On Error Resume Next
 
  With OutMail
    .To = "atest32@hotmail.com"
    .CC = ""
    .BCC = ""
    .Subject = "This is the Subject line"
    .HTMLBody = RangetoHTML(rng)
    .Send 'or use .Display
  End With
 
  On Error GoTo 0
  Set xl = Nothing
  XlBook.Save
  XlBook.Close
  Set XlBook = Nothing
  Set XlSheet = Nothing
  Set OutMail = Nothing
  Set OutApp = Nothing
 
End Sub
Function RangetoHTML(xl As Excel.Application, rng As Excel.Range)
'Function RangetoHTML(rng As Range)
 
  Dim fso      As Object
  Dim ts       As Object
  Dim TempFile As String
  Dim TempWB   As Excel.Workbook
  'Dim XlSheet  As Excel.Worksheet - not used
 
  TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  'TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  rng.Copy
  Set TempWB = xl.Workbooks.Add(1)
  'Set TempWB = Workbooks.Add(1)
 
  With TempWB.Sheets(1)
    .Cells(1).PasteSpecial Paste:=8
    .Cells(1).PasteSpecial xlPasteValues, , False, False
    .Cells(1).PasteSpecial xlPasteFormats, , False, False
    .Cells(1).Select
    xl.Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
  End With
 
  With TempWB.PublishObjects.Add(SourceType:=xlSourceRange, _
    FileName:=TempFile, _
    Sheet:=TempWB.Sheets(1).Name, _
    Source:=TempWB.Sheets(1).UsedRange.Address, _
    HtmlType:=xlHtmlStatic)
    .Publish (True)
  End With
 
  'Read all data from the htm file into RangetoHTML
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  RangetoHTML = ts.ReadAll
  ts.Close
  RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
  "align=left xublishsource=")
  'Close TempWB
  TempWB.Close savechanges:=False
  'Delete the htm file we used in this function
  Kill TempFile
  Set ts = Nothing
  Set fso = Nothing
  Set TempWB = Nothing
 
End Function

The debug made it a lot further through the code however now I'm recieving: "Argument Not Optional" on:

.HTMLBody = RangetoHTML(rng)

I went ahead and switched the Function declairations back to what it was:

'Function RangetoHTML(xl As Excel.Application, rng As Excel.Range)
Function RangetoHTML(rng As Range)

and it ran without errors but it again didn't email the picture.

**c_smithwick** · 05-07-2010, 05:12 PM

That's because you are missing an argument. If you will look at the new function declaration that I wrote, you will see that it is necessary to also pass in your Excel Application object as an argument

Code:

.HTMLBody = RangetoHTML(xl, rng)

**graviz** · 05-10-2010, 01:43 PM

Originally Posted by c_smithwick

That's because you are missing an argument. If you will look at the new function declaration that I wrote, you will see that it is necessary to also pass in your Excel Application object as an argument

Code:

.HTMLBody = RangetoHTML(xl, rng)

Thank you very much! That was the issue. Do you know of any good sites or tuts that focus on emailing using html? I do my best with trying to just look at code and play with it, but I'm still very new at this.

Thanks again!

Please Help Email Excel From Access

Thread Tools

Please Help Email Excel From Access

Correction to Code

Similar Threads

Access Or Excel - Beside Does Access has something in line with Web Query(Excel)

Access email button messing up numbers

email attachment from Access

SENDING EMAIL MESSAGES DIRECTLY FROM ACCESS

Email created from Access is in the wrong format

Posting Permissions