I create a picture of a range and paste it into Outlook. The code works but I added a checkbox that is located in the range that I do NOT want to paste into Outlook.
I used ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False. It works sometimes and other times it doesn't. When I step through the code I get the same inconsistent results.
Public Sub ScreenShotResults4_with_Current()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set rng = Sheets("Summary").Range("B9:N37")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'Sheets("Summary").Branch_ChkBox.Visible = False
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
'strbody = "See production data for most recent 3 months. "
With Email
.To = Worksheets("Summary").Range("B21").Value
.Subject = "12 Month LO Production Lookback for " & Worksheets("Summary").Range("B21").Value & " (" & Worksheets("Summary").Range("B23").Value & "- " & Worksheets("Summary").Range("B35").Value & ")"
'.HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & strbody & RangetoHTML(rng) & Signature
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
'if need setup inlineshapes hight & width
With wdDoc.Content
'--- paste the range image first, because it overwrites
' everything in the document
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
.PasteAndFormat Type:=wdChartPicture
.InlineShapes(1).Height = 350
'--- now add our greeting at the start of the email
.InsertBefore "See 12 month production data and current pipeline. " & vbCr & vbCr
'--- finally add our sign off after the image
.InsertAfter vbCr & _
"Thank you" & vbCr & vbCr
End With
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = True
End Sub
I was able to resolve by putting the same part of the code buy at the top right under the declarations
ActiveSheet.CheckBoxes("Branch_ChkBox").Visible = False
Related
I have two pieces of code that work independently.
I would like to add a button to my sheet to do both. In other words to create the email with the screenshot generated by ScreenShotResults4() and attach the pdf generated by PrintPIP_To_PDF().
I tried combining but got syntax errors. I cobble code together with the help of sites like this.
Public Sub ScreenShotResults4()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set rng = Sheets("Summary").Range("B21:N37")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
'strbody = "See production data for most recent 3 months. "
With Email
.To = Worksheets("Summary").Range("B21").Value
.Subject = "12 Month LO Production Lookback for " & Worksheets("Summary").Range("B21").Value & " (" & Worksheets("Summary").Range("B23").Value & "- " & Worksheets("Summary").Range("B35").Value & ")"
'.HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & strbody & RangetoHTML(rng) & Signature
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
'if need setup inlineshapes hight & width
With wdDoc.Content
'--- paste the range image first, because it overwrites
' everything in the document
.PasteAndFormat Type:=wdChartPicture
'--- now add our greeting at the start of the email
.InsertBefore "See 12 month production data. " & vbCr & vbCr
'--- finally add our sign off after the image
.InsertAfter vbCr & _
"Thank you" & vbCr & vbCr
End With
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
End Sub
Sub PrintPIP_To_PDF()
Application.EnableEvents = True
ActiveSheet.Unprotect Password:="Mortgage1"
Dim PrintRng As Range
Dim pdfile As String
'Setting range to be printed
Set PrintRng = Worksheets("PIP").Range("B3:M27")
'Range("B25:C25").Font.Color = RGB(255, 255, 255)
sPath = Environ("USERPROFILE") & "\Desktop\"
pdfile = Application.GetSaveAsFilename _
(InitialFileName:=sPath & "PIP" & " " & Worksheets("Summary").Range("B21").Value, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
Filename = pdfile
If Filename = False Then
Exit Sub
Else
PrintRng.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=pdfile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Call MsgBox(pdfile & " file has been saved!")
ActiveSheet.Protect Password:="Mortgage1"
End If
End Sub
pls try this.
after displaying draft email .Display
use .Attachment.Add "C:\Test.pdf"
also if u wish to, u can save a copy of draft email (before sending) using
.SaveAs "C:\OutLookDrafts\Draft1.msg"
I have the following code that sends a screenshot picture of a range> I would like to add text to the email but have not been able to figure out how.
Any help would be greatly appreciated.
'''
Public Sub ScreenShotResults2()
Dim rng As Range
Dim olApp As Object
Dim Email As Object
Dim Sht As Excel.Worksheet
Dim wdDoc As Word.Document
Set rng = Sheets("Summary").Range("B20:I34")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
'strbody = "See production data for most recent 3 months. "
With Email
.To = Worksheets("Summary").Range("B22").Value
.Subject = "4 Month LO Production Lookback for " & Worksheets("Summary").Range("B22").Value
'.HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & strbody & RangetoHTML(rng) & Signature
.Display
wdDoc.Range.PasteAndFormat Type:=wdChartPicture
'if need setup inlineshapes hight & width
With wdDoc
.InlineShapes(1).Height = 250
End With
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
End Sub
There are several ways to add the text. Here is one:
'if need setup inlineshapes hight & width
With wdDoc
.InlineShapes(1).Height = 250
.Paragraphs.Add
.Paragraphs.Add
.Content.InsertAfter "Please look at the range image!"
End With
EDIT: here is an expanded example to add text before and after the image (without using RangeToHTML)
Option Explicit
Public Sub ScreenShotResults2()
Dim rng As Range
Set rng = Sheets("Summary").Range("B20:I34")
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Dim olApp As Outlook.Application
Dim Email As Outlook.MailItem
Dim wdDoc As Word.Document
Set olApp = CreateObject("Outlook.Application")
Set Email = olApp.CreateItem(0)
Set wdDoc = Email.GetInspector.WordEditor
With Email
.To = Worksheets("Summary").Range("B22").Value
.Subject = "4 Month LO Production Lookback for " & _
Worksheets("Summary").Range("B22").Value
.Display
End With
With wdDoc.Content
'--- paste the range image first, because it overwrites
' everything in the document
.PasteAndFormat Type:=wdChartPicture
'--- now add our greeting at the start of the email
.InsertBefore "Dear Goober," & vbCr & vbCr & _
"See production data for most recent 3 months. " & _
vbCr & vbCr
'--- finally add our sign off after the image
.InsertAfter vbCr & vbCr & _
"This is my final comment." & vbCr & vbCr & _
"Sincerely," & vbCr & _
"Me!"
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set Email = Nothing
Set olApp = Nothing
End Sub
I've used an example to create code to send emails from Excel (with Outlook), using a "Button" (red in my file).
The code works. There is a pre-selected range of rows [B1:K20], that can be manually modified thanks to the Application.InputBox function.
Sub MAIL()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBodyIn, StrBodyEnd As String
StrBodyIn = "Bonjour," & "<br>" & _
" " & "<br>" & _
"Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & _
"Cordialement" & "<br>" & _
" " & "<br>" & _
Range("M2") & "<br>"
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "ATTENZIONE!!!" & _
vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#gmail.com"
.CC = ""
.BCC = ""
.Subject = "SITUATION"
.HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(rng) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I want to add a condition.
The selected range of rows should be copied to the body of the email if the "X" symbol is written in the column "A".
In my example, rows n° 1, 2 and n° 5 should be copied.
The two tasks here are separate so I would code them as such. Here would be my approach. Separate your sub into two logical procedures.
Determine the body range
Send the email with the range
Determine the body range
Link your button to this macro. The macro will take an input and convert it into a single column range (Column B). We will then loop through the selected range and look at Column A to determine if there is an x or not. If an x is present, we will resize the range back to it's original size and add it to a collection of cells (Final).
Once the loop is complete, the macro will then do one of the following:
If the range is empty, it will prompt your message box and end the sub (your email macro is never initiated)
If the range is not empty, we will call your EMAIL macro and pass the range along to it.
Sub EmailRange()
Dim Initial As Range, Final As Range, nCell As Range
On Error Resume Next
Set Initial = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0
For Each nCell In Initial.Resize(Initial.Rows.Count, 1)
If nCell.Offset(, -1) = "X" Then
If Not Final Is Nothing Then
Set Final = Union(Final, nCell.Resize(1, Initial.Columns.Count))
Else
Set Final = nCell.Resize(1, Initial.Columns.Count)
End If
End If
Next nCell
If Not Final Is Nothing Then
MAIL Final
Else
MsgBox "ATTENZIONE!!!" & vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
End If
End Sub
Send the email with the range
Notice that the macro now has an input (On first line). If the sub is called, you no longer need to validate anything since this was all done in the original sub!
Sub MAIL(Final as Range)
Dim OutApp As Object, OutMail As Object
Dim StrBodyIn As String, StrBodyEnd As String
StrBodyIn = "Bonjour," & "<br>" & " " & "<br>" & "Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & "Cordialement" & "<br>" & " " & "<br>" & Range("M2") & "<br>"
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#gmail.com"
.CC = ""
.BCC = ""
.Subject = "SITUATION"
.HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(Final) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I continue my work starting from the 1st question here:
Excel VBA - Outlook Email - Body created with rows having a particular value
Now i have another problem.
I want to repeat the below MACROs on all the SHEETS of my file.
In particular, how can I repeat this function on different SHEETS by only clicking in 1 button present in all the sheets?
All the sheets have the same structure.
I mean, the table resulting in the email must be implemented by adding the datas in all the sheets.
The data should be copied starting from the 1st sheet, for ex. TEST(1) to the last sheet, TEST(9).
The email generated after this process must be ONLY one.
Determine the body range
Sub EmailRange()
Dim Initial As Range, Final As Range, nCell As Range
On Error Resume Next
Set Initial = Sheets("TEST").Application.InputBox("Range", xTitleId, "B1:K20", Type:=8)
On Error GoTo 0
For Each nCell In Initial.Resize(Initial.Rows.Count, 1)
If nCell.Offset(, -1) = "X" Then
If Not Final Is Nothing Then
Set Final = Union(Final, nCell.Resize(1, Initial.Columns.Count))
Else
Set Final = nCell.Resize(1, Initial.Columns.Count)
End If
End If
Next nCell
If Not Final Is Nothing Then
MAIL Final
Else
MsgBox "ATTENZIONE!!!" & vbNewLine & "Seleziona un range di celle valido.", vbOKOnly
End If
End Sub
Send the email with the range
Sub MAIL(Final as Range)
Dim OutApp As Object, OutMail As Object
Dim StrBodyIn As String, StrBodyEnd As String
StrBodyIn = "Bonjour," & "<br>" & " " & "<br>" & "Buongiorno," & "<br>"
StrBodyEnd = " " & "<br>" & "Cordialement" & "<br>" & " " & "<br>" & Range("M2") & "<br>"
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "email#gmail.com"
.CC = ""
.BCC = ""
.Subject = "SITUATION"
.HTMLBody = "<p style='font-family:calibri;font-size:16'>" & StrBodyIn & RangetoHTML(Final) & "<p style='font-family:calibri;font-size:16'>" & StrBodyEnd
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I've tried with something like this, but it does not work:
For I = 1 To Worksheets.Count
Sheets(I).Select
***[...]CODE OF "Determine the body range"***
Next I
Sheets("TEST(I)").Select
I generate reports to send to different branches. I run a macro that creates protected reports (*.xlsm). These reports have a space for comments for the Branch Managers, with a "send Comments" button that run this macro below.
I suggested the following references to add if the macro does not work.
The Branch Managers have different versions of MS Office (Excel, Outlook, etc.) on their laptops. When they try to Run, it shows errors, such as: "Error in Loadind DLL"; Error2, etc.
What should be done on the Branch Managers side to run this Macro?
Sub CommentsEmail()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim mymail As Outlook.mailItem
Dim objSel As Word.Selection
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Shell ("Outlook")
Set olApp = New Outlook.Application
Set mymail = olApp.CreateItem(olMailItem)
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
template.Activate
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'OutMail.Display
Dim wordDoc As Word.Document
Set wordDoc = OutMail.GetInspector.WordEditor
Set objSel = wordDoc.Windows(1).Selection
'construct the body of the email here
With objSel
'first text
.InsertAfter "Dear All," & vbCrLf
.Move wdParagraph, 1
'second text
.InsertAfter vbCrLf & "See below the Comments for Flash Indicator - " & branch & vbCrLf & vbCrLf
.Move wdParagraph, 1
'copy a range and paste a picture
commentsrange.Copy ''again, you need to modify your target range
.PasteAndFormat wdChartPicture
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Let us know of any questions." & vbCrLf & vbCrLf
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Kind Regards," & vbCrLf
End With
OutMail.To = OutMail.To & ";" & Sendto
With OutMail
.Subject = "Comments on Flash Indicator Results - " & branch
.Attachments.Add (ActiveWorkbook.FullName)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Is this still early binding? If yes, I am totally lost.
Sub CommentsEmail2()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OlaApp As Object
Dim OleMail As Object
Dim TempFilePath As String
Dim xHTMLBody As String
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
template.Activate
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OleMail = olApp.CreateItem(0)
Call createJpg(ActiveSheet.comments, commentsrange, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>Best Regards!</font></span>"
With OleMail
.Subject = "test"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.Attachments.Add (ActiveWorkbook.FullName)
.To = " "
.Cc = " "
.Display
End With
Set OleMail = Nothing
Set OlaApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Sub createJpg(SheetName As String, commentsrange As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(comments).Activate
Set xRgPic = ThisWorkbook.Worksheets(comments).Range(Cells(7, 1), Cells(52, 4))
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(comments).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(comments).ChartObjects(Worksheets(comments).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub