I have the following logic to send an email through outlook from excel. using a userform. The problem is having the textbox activated upon selecting the checkbox. The texbox does not activate upon checking it. I also have tried with the visible property.
The problem is the checkbox is not activating the logic that the else statement.
Private Sub CommandButton9_Click()
On Error GoTo ERRORMSG
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
Set Doc = olMail.GetInspector.WordEditor
Set mainWB = ActiveWorkbook
If CheckBox1.Value = False Then
mainWB.Sheets("Mail").Range("m8").Value = ComboBox4.Value
mainWB.Sheets("Mail").Range("n8").Value = TextBox40.Value
mainWB.Sheets("Mail").Range("q8").Value = ComboBox5.Value
mainWB.Sheets("Mail").Range("r8").Value = ComboBox6.Value
mainWB.Sheets("Mail").Range("s8").Value = ComboBox7.Value
mainWB.Sheets("Mail").Range("t8").Value = TextBox44.Value
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "mainWB.Sheets("Mail").Range("G12").Value"
.cc = mainWB.Sheets("Mail").Range("L12").Value
.Subject = mainWB.Sheets("Mail").Range("O15").Value
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
'force html format
.HTMLBody = "<HTML><body><body></HTML>"
.display
'--- start with 6 CrLf's, so we can place each table
' above all but the last used...
oRng.InsertAfter vbCrLf & vbCrLf
'--- now reselect the entire document, collapse our cursor to the end
' and back up one character (so that the table inserts before the SIXTH CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -1
Range("K3:T10").Select
Selection.Copy
oRng.Paste
'--- finally move the cursor all the way to the end and paste the
' second table BELOW the SIXTH CrLf
Set oRng = wdDoc.Range
oRng.collapse 0
Range("K38:T46").Select
Selection.Copy
oRng.Paste
End With
Else
Label54.enable = True
TextBox46.enable = True
mainWB.Sheets("Mail").Range("m57").Value = ComboBox4.Value
mainWB.Sheets("Mail").Range("n57").Value = TextBox40.Value
mainWB.Sheets("Mail").Range("O57").Value = TextBox46.Value
mainWB.Sheets("Mail").Range("q57").Value = ComboBox5.Value
mainWB.Sheets("Mail").Range("r57").Value = ComboBox6.Value
mainWB.Sheets("Mail").Range("s57").Value = ComboBox7.Value
mainWB.Sheets("Mail").Range("t57").Value = TextBox44.Value
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "mainWB.Sheets("Mail").Range("G12").Value"
.cc = mainWB.Sheets("Mail").Range("L12").Value
.Subject = mainWB.Sheets("Mail").Range("O15").Value
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
'force html format
.HTMLBody = "<HTML><body><body></HTML>"
.display
'--- start with 6 CrLf's, so we can place each table
' above all but the last used...
oRng.InsertAfter vbCrLf & vbCrLf
'--- now reselect the entire document, collapse our cursor to the end
' and back up one character (so that the table inserts before the SIXTH CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -1
Range("K52:T59").Select
Selection.Copy
oRng.Paste
'--- finally move the cursor all the way to the end and paste the
' second table BELOW the SIXTH CrLf
Set oRng = wdDoc.Range
oRng.collapse 0
Range("K38:T46").Select
Selection.Copy
oRng.Paste
End With
End If
Exit Sub
ERRORMSG:
MsgBox "No email was sent", vbExclamation
End Sub
you must:
set both Label54 and TextBox46 Enabled property prior to executing any Userform event handling code
this you can achieve:
either with a Private Sub UserForm_Initialize() sub:
Private Sub UserForm_Initialize()
With Me
.Label54.Enabled = False
.TextBox46.Enabled = False
End With
End Sub
or in the Userform calling block of your "main" sub
Sub Main()
... code
With MyUserForm '<--| change "MyUserForm" to your actual userform name
.Label54.Enabled = False
.TextBox46.Enabled = False
... other possible code here to set some Userform members before showing it
.Show '<--| show your userform
End With
Unload MyUserForm
... more code
End SUb
set both Label54 and TextBox46 Enabled property in your CommandButton9_Click event handler accordingly to CheckBox1 value
like follows:
Option Explicit
Private Sub CommandButton9_Click()
Dim OutApp As Object
Dim mailSht As Worksheet
Dim rowOffset As Long
Set OutApp = GetApp("Outlook.Application")
If OutApp Is Nothing Then
MsgBox "Couldn't set 'Outlook.Application' object"
Exit Sub
End If
Set mailSht = ActiveWorkbook.Sheets("Mail")
rowOffset = IIf(CheckBox1, 56, 7) '<--| set a row offset (from row 1) in according to CheckBox value
Label54.Enabled = CheckBox1 '<--| enable Label54 control if CheckBox1 is checked
TextBox46.Enabled = CheckBox1 '<--| enable TextBox46 control if CheckBox1 is checked
With Me '<--| refer to this userform
'fill "Mail" sheet properly offsetted cells with ComboBoxes and TextBoxes values
FillRangeWithComboBoxValue .ComboBox4, mailSht.Range("m1").Offset(rowOffset)
mailSht.Range("n1").Offset(rowOffset).value = .TextBox40.value
FillRangeWithComboBoxValue .ComboBox5, mailSht.Range("q1").Offset(rowOffset)
FillRangeWithComboBoxValue .ComboBox6, mailSht.Range("r1").Offset(rowOffset)
FillRangeWithComboBoxValue .ComboBox7, mailSht.Range("s1").Offset(rowOffset)
mailSht.Range("t1").Offset(rowOffset).value = .TextBox44.value
End With
On Error GoTo ERRORMSG
With OutApp.CreateItem(0)
.To = mailSht.Range("G12").value
.CC = mailSht.Range("L12").value
.Subject = mailSht.Range("O15").value
'force html format
.HTMLBody = "<HTML><body><body></HTML>"
.display
With .GetInspector.WordEditor
'--- start with 6 CrLf's, so we can place each table
' above all but the last used...
.Range.InsertAfter vbCrLf & vbCrLf
'--- now reselect the entire document, collapse our cursor to the end
' and back up one character (so that the table inserts before the SIXTH CrLf)
With .Range
.collapse 0
.Move 1, -1
mailSht.Range("K3:T10").Copy
.Paste
End With
'--- finally move the cursor all the way to the end and paste the
' second table BELOW the SIXTH CrLf
With .Range
.collapse 0
mailSht.Range("K38:T46").Copy
.Paste
End With
End With
End With
Set OutApp = Nothing '<--| dispose the object variable
Exit Sub
ERRORMSG:
MsgBox "Error on email processing", vbExclamation
End Sub
Function GetApp(appName As String) As Object
On Error Resume Next
Set GetApp = GetObject(, appName)
If GetApp Is Nothing Then Set GetApp = CreateObject(appName)
End Function
Sub FillRangeWithComboBoxValue(cb As msforms.ComboBox, rng As Range)
If cb.ListIndex <> -1 Then rng.value = cb.value
End Sub
where you see I proposed some code shortening and modulizing tips to have it (hopefully) more readable and maintainable
Thanks Guys, it was a simple fix. I put the checkbox condition in the checkbox change event and it works like a gem.
Private Sub CheckBox1_Change()
Related
I looked through a few posts but it didn't help.
My code merges same emails into one email and also consolidates a table. Works if I were to send to all.
Sub SendEmail()
OptimizedMode True
Dim OutApp As Object
Dim OutMail As Object
Dim dict As Object 'keep the unique list of emails
Dim cell As Range
Dim cell2 As Range
Dim Rng As Range
Dim i As Long
Dim ws As Worksheet
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set dict = CreateObject("scripting.dictionary")
Set ws = ThisWorkbook.Sheets("Table") 'Current worksheet name
On Error GoTo cleanup
For Each cell In ws.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
'check if this email address has been used to generate an outlook email or not
If dict.exists(cell.Value) = False Then
dict.Add cell.Value, "" 'add the new email address
Set OutMail = OutApp.CreateItem(0)
Set Rng = ws.UsedRange.Rows(1)
'find all of the rows with the same email and add it to the range
For Each cell2 In ws.UsedRange.Columns(1).Cells
If cell2.Value = cell.Value Then
Set Rng = Application.Union(Rng, ws.UsedRange.Rows(cell2.Row))
End If
With ws.UsedRange
Set Rng = Intersect(Rng, .Columns(2).Resize(, .Columns.Count - 1))
End With
Next cell2
On Error Resume Next
With OutMail
.SentOnBehalfOfName = "email#email"
.GetInspector ' ## This inserts default signature
Signature = .HTMLBody ' ## Capture the signature HTML
.To = cell.Value
.CC = "email#test.com"
.Subject = "Reminder"
.HTMLBody = "test"
If UserForm1.OptionButton1.Value = True Then
.Send
Else
.Display
End If
End With
On Error GoTo 0
Set OutMail = Nothing
End If
End If
Next cell
cleanup:
Set OutApp = Nothing
AppActivate UserForm1.Caption
Dim OutPut As Integer
OutPut = MsgBox("Successfully Completed Task.", vbInformation, "Completed")
OptimizedMode False
End Sub
I want an option for "send all" or "send to selected" on the listbox.
Also how would I exit sub if it detects either blanks or "Not Found"?
Private Sub CommandButton3_Click()
If ButtonOneClick Then
GoTo continue
Else
MsgBox "Please Generate Table.", vbCritical
Exit Sub
End If
ButtonOneClick = False
continue:
Dim Wb As Workbook
Dim ws As Worksheet
Dim rng1 As Range
Set Wb = ThisWorkbook
Set ws = Wb.Sheets("Table")
'find not found or any blanks...
Set rng1 = ws.Range("A:A").Find("Not Found", ws.[a1], xlValues, xlWhole, , xlNext)
If Not rng1 Is Nothing Then
MsgBox "ERROR. Check E-mails in Table.", vbCritical
Else
Call SendEmail
CommandButton3.Enabled = False
End If
End Sub
How can I incorporate something like this?
For i = 0 To Me.ListBox1.ListCount - 1
With Me.ListBox1
If Me.opt_All.Value = True Then
Call SendEmail
Else
If .Selected(i) Then
call SendEmail
End If
End If
End With
Next i
Separate your script into 3 parts. First build the mailing list. Then for each address determine the range and send the email.
Replce you code after continue: with MEmail.CreateMailList and add a module called MEmail with this code
Option Explicit
Sub CreateMailList()
Dim MailList
Set MailList = CreateObject("Scripting.Dictionary")
' build email list
Dim i As Integer, rng As Range, addr
With UserForm1.ListBox1
' scan table building ranges
For i = 0 To .ListCount - 1
If .Selected(i) Or UserForm1.OptionButton3.Value = True Then
addr = Trim(.List(i, 0)) ' email address
If Len(addr) > 0 Then
If Not MailList.exists(addr) Then
Set rng = Sheets("Table").Cells(1, 2).Resize(1, .ColumnCount-1)
MailList.Add addr, rng
End If
Set rng = Sheets("Table").Cells(i + 2, 2).Resize(1, .ColumnCount-1)
Set MailList(addr) = Union(MailList(addr), rng)
End If
End If
Next i
End With
If MailList.Count = 0 Then
MsgBox "No rows selected", vbExclamation
Else
If MsgBox("Do you want to send " & MailList.Count & " emails", vbYesNo) = vbYes Then
SendEmails MailList
End If
End If
End Sub
Sub SendEmails(ByRef MailList)
'OptimizedMode True
Dim OutApp, addr
' send email
Set OutApp = CreateObject("Outlook.Application")
For Each addr In MailList
SendOneEmail OutApp, CStr(addr), MailList.item(addr)
Next
Set OutApp = Nothing
'AppActivate UserForm1.Caption
MsgBox "Successfully Completed", vbInformation, "Completed Emails Sent=" & MailList.Count
'OptimizedMode False
End Sub
Sub SendOneEmail(OutApp, EmailAddress As String, rng As Range)
Dim OutMail, Signature As String
Set OutMail = OutApp.CreateItem(0)
' email
With OutMail
.SentOnBehalfOfName = "email#email"
.GetInspector ' ## This inserts default signature
Signature = .HTMLBody ' ## Capture the signature HTML
.To = EmailAddress
.CC = "email#test.com"
.Subject = "Reminder"
.HTMLBody = "<BODY style=font-size:12pt;font-family:Calibri><font color=#000000>Hi " _
& WorksheetFunction.Proper(RemoveNumbers(Left((EmailAddress), InStr((EmailAddress), ".") - 1))) & ", " & _
"<br><br>" & "Please see your trip numbers and estimated cost below:" & _
vbNewLine & vbNewLine & RangetoHTML(rng) & Signature & "</font></BODY>"
If UserForm1.OptionButton1.Value = True Then
' .Send
Else
.Display
End If
End With
Set OutMail = Nothing
End Sub
I'm new to the forum. I have a little problem with a vba macro in excel. Probably it's not so difficult for you, but I'm totally new on vba. I have two columns: column "A" with a choice (es. "yes" or "no") and column "B" with a string. I want to send an email with the "B" string list with all the strings (line-by-line) that have "yes" value in "A".
Sub Alert()
ActiveSheet.UsedRange.Select
On Error Resume Next
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim list As Object
Dim element As Variant
Application.ScreenUpdating = False
Do While Trim(Cells(cell.Row, "A").Value) = ""
On Error GoTo alertmail
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value = "yes" Then
element = Cells(cell.Row, "B").Value
Set list = CreateObject("System.Collections.ArrayList")
list.Add element
End If
Next cell
Loop
alertmail:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "test#abc.com"
.Subject = "Alert"
.Body = "Your yes list is" & vbNewLine & PrintArray
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Exit Sub
Application.ScreenUpdating = True
End Sub
Until now, my best result was to send a set of different mail with only one "B" string for every "yes" "A" value (i.e. if I have 3 "yes" value I obtain 3 mails with the correct "B" string for each).
Try the following code:
Sub Alert()
ActiveSheet.UsedRange.Select
On Error Resume Next
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim list As String
Dim element As Variant
Application.ScreenUpdating = False
Do While Trim(Cells(cell.Row, "A").Value) = ""
On Error GoTo alertmail
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value = "yes" Then
element = Cells(cell.Row, "B").Value
list = list & vbNewLine & element
End If
Next cell
Loop
alertmail:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "to#xyz.com"
.Subject = "Alert"
.Body = "Your yes list is" & vbNewLine & list
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Exit Sub
Application.ScreenUpdating = True
End Sub
I have a VBA code where I set the path for the word file, so that I can use the word document as email body.
But instead I wanted to insert a cell reference in the code so that I don't have to change the code all the time.
Thank you in advance!!
Below is the code am using
Sub Email()
Dim oOutApp As Object
Dim oMailItem As Object
Dim oWordApp As Object
Dim oWordDoc As Object
Dim oMailWordDoc As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("details")
On Error GoTo CleanUp
Set oWordApp = CreateObject("Word.Application")
Set oWordDoc = oWordApp.documents.Open("...File path..")
oWordDoc.Content.copy
Set oOutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns.Range("B3:B10000").cells.SpecialCells(xlCellTypeConstants)
Set rng = sh.cells(cell.Row, 1).Range("I1:J1")
If cell.Value Like "*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set oMailItem = oOutApp.CreateItem(0)
With oMailItem
.To = cell.Value
.cc = cells(cell.Row, "C").Value 'sh.Columns.Range("C3").cells
.Subject = cells(cell.Row, "F").Value
.Body = ""
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
.Display
Next FileCell
Set oMailWordDoc = oOutApp.ActiveInspector.WordEditor
Set editor = .GetInspector.WordEditor
editor.Content.Paste
.send
End With
End If
Next cell
Set oMailWordDoc = oOutApp.ActiveInspector.WordEditor
CleanUp:
oWordApp.Quit
Set oMailWordDoc = Nothing
Set oMailItem = Nothing
Set oOutApp = Nothing
Set oWordDoc = Nothing
Set oWordApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
i'm not sure if i understand you rigth.
but i think what you are looking for is something like this:
strPath = Sheets("Sheet1").Range("A1").value
so you can write the Path in the cell A1 inside the First sheet and the VBA Code will use this Path for the Word Document.
here I am trying to send out a mail to multiple recipients from outlook vba.
the recipient mail address is taken from column A of excel sheet. Whne I run the below code the error "Run Time error 1004; Method 'cells of object'_Global' failed"
how to send the same mail to multiple recipients at the same time.
To:Abc#gmail.Com; bhy#gmail.com; rft#gmail.com CC:hjuy#gmail.com;
ijk#gmail.com Subject: test mail
Code:
Sub Sendmail()
Dim olItem As Outlook.MailItem
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSht As Excel.Worksheet
Dim sPath As String
Dim iRow As Long
iRow = 1
sPath = "XX"
' // Excel
Set xlApp = CreateObject("Excel.Application")
' // Workbook
Set xlBook = xlApp.Workbooks.Open(sPath)
' // Sheet
Set xlSht = xlBook.Sheets("Sheet1")
Do Until IsEmpty(Cells(iRow, 1))
Recip = Cells(iRow, 1).Value
' subject = Cells(iRow, 2).Value
' Atmt = Cells(iRow, 3).Value '
' // Create e-mail Item
Set olItem = Application.CreateItem(olMailItem)
With olItem
Set olRecip = .Recipients.Add(Recip)
.CC = xlSht.Range("B1")
.subject = "test"
.Display
.Send
End With
' // Close
xlBook.Close SaveChanges:=True
' // Quit
xlApp.Quit
'// CleanUp
iRow = iRow + 1
Loop
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSht = Nothing
Set olItem = Nothing
End Sub
This should od the job for you.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
I'm trying to send certain sections of an excel file into an Outlook mail body.
I need the formatting of the data, as I am working with data inside tables and with different cell fill colours and font colours, so it can't be stored in a string AFAIK.
I need carriage returns to separate the tables being pasted into outlook so that other text can be manually added to the email body in between the tables without distorting the table formatting.
The code below, shows what needs to be done but wont work as it returns a runtime error 13, type mismatch on the ".HTMLBody" line. I've spend a long time trying different ways to do this, but this is the way I need it to work I just don't know which data types to use and how to properly do it.
Keep in mind that in both examples of my code below I have cut out most of the data range pasting because it would be redundant code.
Sub sendToOutlook()
Dim OutApp As Object
Dim OutMail As Object
Dim bodyFieldA As Range
Dim bodyFieldB As Range
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Range("L18").Value
.CC = Range("L19").Value
.BCC = Range("L20").Value
.Subject = Range("L1") & " " & Range("N1").Text _
& " " & Range("O1") & " " & Range("R1").Text _
& " " & Range("S1")
Set bodyFieldA = Range("A26:I33")
Set bodyFieldB = Range("A34:I34")
.HTMLBody = bodyFieldA + vbCrLf + bodyFieldB + "<HTML><body><body></HTML>"
.display
End With
Application.CutCopyMode = False
Range("A1").Select
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
My old version only works if Outlook has already been given focus by the user once, otherwise the "sendkeys" which I use instead of carriage returns are sent to excel instead, ruining the worksheet data.
Also, if the ".TO" field is left blank the "sendkeys" are sent there instead of the email body.
I need to fix this problem, so the above code is my attempt at a solution for it, while the code below is my old code that does the job but with a lot of Band-Aid work and problems less experienced users who will be using the macro will not be able to deal with.
Sub sendToOutlook()
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Range("L18").Value
.CC = Range("L19").Value
.BCC = Range("L20").Value
.Subject = _
Range("L1") & " " & Range("N1").Text _
& " " & Range("O1") & " " & Range("R1").Text _
& " " & Range("S1")
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
'force html format
.HTMLBody = "<HTML><body><body></HTML>"
.display
oRng.collapse 1
Range("A26:I33").Select
Selection.Copy
oRng.Paste
SendKeys "{ENTER}", True
oRng.collapse 1
Range("A34:I34").Select
Selection.Copy
oRng.Paste
SendKeys "{ENTER}", True
End With
'deselect cell range
Application.CutCopyMode = False
Range("A1").Select
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub
From the second set of code above, which copy-pastes the tables into the Word-based email body, I came up with the following code. Basically, we're "priming" the document with a couple of CrLf's before pasting the tables.
Option Explicit
Sub sendToOutlook()
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Range("L18").Value
.CC = Range("L19").Value
.BCC = Range("L20").Value
.Subject = _
Range("L1") & " " & Range("N1").Text _
& " " & Range("O1") & " " & Range("R1").Text _
& " " & Range("S1")
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
'force html format
.HTMLBody = "<HTML><body><body></HTML>"
.display
'--- start with two CrLf's, so we can add the first table
' in between them...
oRng.InsertAfter vbCrLf & vbCrLf
'--- now reselect the entire document, collapse our cursor to the end
' and back up one character (so that the table inserts before the CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -1
Range("A26:I33").Select
Selection.Copy
oRng.Paste
'--- finally move the cursor all the way to the end and paste the
' second table
Set oRng = wdDoc.Range
oRng.collapse 0
Range("A34:I34").Select
Selection.Copy
oRng.Paste
'SendKeys "{ENTER}", True
End With
'deselect cell range
Application.CutCopyMode = False
Range("A1").Select
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub
The code below solves both of my issues. Thanks to PeterT who gave me a strategy to use.
Sub sendToOutlook()
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Range("L18").Value
.CC = Range("L19").Value
.BCC = Range("L20").Value
.Subject = _
Range("L1") & " " & Range("N1").Text _
& " " & Range("O1") & " " & Range("R1").Text _
& " " & Range("S1")
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
'force html format
.HTMLBody = "<HTML><body><body></HTML>"
.display
'--- start with 6 CrLf's, so we can place each table
' above all but the last used...
oRng.InsertAfter vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf
'--- now reselect the entire document, collapse our cursor to the end
' and back up six characters (so that the table inserts before the FIRST CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -6
Range("A1:I8").Select
Selection.Copy
oRng.Paste
'--- now reselect the entire document, collapse our cursor to the end
' and back up five characters (so that the table inserts before the SECOND CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -5
Range("A9:I9").Select
Selection.Copy
oRng.Paste
'--- now reselect the entire document, collapse our cursor to the end
' and back up four characters (so that the table inserts before the THIRD CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -4
Range("A11:I22").Select
Selection.Copy
oRng.Paste
'--- now reselect the entire document, collapse our cursor to the end
' and back up three characters (so that the table inserts before the FOURTH CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -3
Range("A24:I24").Select
Selection.Copy
oRng.Paste
'--- now reselect the entire document, collapse our cursor to the end
' and back up two characters (so that the table inserts before the FIFTH CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -2
Range("A26:I33").Select
Selection.Copy
oRng.Paste
'--- now reselect the entire document, collapse our cursor to the end
' and back up one character (so that the table inserts before the SIXTH CrLf)
Set oRng = wdDoc.Range
oRng.collapse 0
oRng.Move 1, -1
Range("A34:I34").Select
Selection.Copy
oRng.Paste
'--- finally move the cursor all the way to the end and paste the
' second table BELOW the SIXTH CrLf
Set oRng = wdDoc.Range
oRng.collapse 0
Range("A36:I47").Select
Selection.Copy
oRng.Paste
End With
'deselect cell range
Application.CutCopyMode = False
Range("A1").Select
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub