VBA screenshots sheet section to paste in to the body of an email , copies the workbook and attaches it to an email, then emails

A

agentkramr

Board Regular
Joined
Dec 27, 2021
Messages
98
Platform
  1. Windows
Here is my code for the process but something weird is happening. All the cells by the end of the day have the same numbers straight across. These numbers come from an oracle database so they are updating constantly so there is no way they are the same all the time. it is only in the copy and the screen shot too as the original and xlsm the numbers are changing

Here is my code

VBA Code: 
Sub Test_Hourly()
Dim oApp As Object, oMail As Object, FileStr As String
Dim NewWb As Workbook, cnt As Integer
Dim FileName As String, MailSub As String, MailTxt As String
Dim tmpImageName As String
'************************************************* ********
'Set email details; Comment out if not required
Const MailTo = "my email"
Const MailCC = "some2@someone.com"
Const MailBCC = "some3@someone.com"
MailSub = "test"
MailTxt = "test"

'Turns off screen updating
Application.ScreenUpdating = False
Sheets("1 Hour Counts").Unprotect "Test"
'define a temp path for your image
tmpImageName = Environ$("temp") & "" & "TempChart.jpg"
'create image file
Call CreateJpg("1 Hour Counts", Sheets("1 Hour Counts").Range("A1:S30"))
'copy range to new wb/remove formulas
Set NewWb = Workbooks.Add
'copy all sheets
For cnt = 1 To ThisWorkbook.Sheets.Count
ThisWorkbook.Sheets(cnt).Copy NewWb.Sheets(cnt)
Next cnt
NewWb.Sheets("1 Hour Counts").Range("A1:S30").Copy
NewWb.Worksheets("1 Hour Counts").Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'NewWb.Worksheets("1 Hour Counts").Shapes("Rectangle: Rounded Corners 1").Delete
'NewWb.Worksheets("1 Hour Counts").Shapes("Rectangle: Rounded Corners 2").Delete
NewWb.Worksheets("1 Hour Counts").Activate
NewWb.Worksheets("1 Hour Counts").Range("A1").Select
Application.DisplayAlerts = False
NewWb.Worksheets("Sheet1").Delete
NewWb.SaveAs FileName:=Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & ".xlsx", _
                                                        FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
FileStr = NewWb.FullName
NewWb.Close
Sheets("1 Hour Counts").Protect "Test"

'Creates and shows the outlook mail item

Set oApp = CreateObject("Outlook.Application")

Set oMail = oApp.CreateItem(0)

With oMail

.To = MailTo

.Cc = MailCC

.Bcc = MailBCC

.Subject = MailSub

.HTMLBody = "<body><img src=" & "'" & tmpImageName & "'/></body>"

.Attachments.Add FileStr

.Display

.Send

End With

'Deletes the temporary file

'WB.ChangeFileAccess Mode:=xlReadOnly

Kill (Environ$("temp") & "" & "TempChart.jpg")

Kill FileStr


'Restores screen updating and release Outlook

Application.ScreenUpdating = True

Set oMail = Nothing

Set oApp = Nothing

'Save Workbook

'ThisWorkbook.Save

End Sub

Public Sub CreateJpg(SheetName As String, xRgAddrss As Range)
'creates temp JPG file of range (xRgAddrss) by creating temp chart
'uses current wb sheet (sheetname) to locate temp chart
Dim xRgPic As Range
Worksheets(SheetName).Activate
Set xRgPic = xRgAddrss
xRgPic.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, _
                                                          xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "" & "TempChart.jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
End Sub

Any help is greatly appreciated
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
Sort by date Sort by votes
Hi again agentkramr. I'm guessing that your clipboard after repetitive use is crapping out. U can trial adding this code to the top of a module...
Code: 
#If VBA7 Then
    Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
#Else
    Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function CloseClipboard Lib "user32" () As Long
    Public Declare Function EmptyClipboard Lib "user32" () As Long
#End If
Then place this before the End Sub in the CreateJpg sub....
Code: 
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
HTH. Dave
 
Upvote 0
try this
Code: 
Sub Test_Hourly()
Dim oApp As Object, oMail As Object, FileStr As String
Dim NewWb As Workbook, cnt As Integer
Dim FileName As String, MailSub As String, MailTxt As String
Dim tmpImageName As String
lr = Cells(Rows.Count, 1).End(xlUp).Row
'************************************************* ********
'Set email details; Comment out if not required
Const MailTo = "my email"
Const MailCC = "some2@someone.com"
Const MailBCC = "some3@someone.com"
MailSub = "test"
MailTxt = "test"
'Turns off screen updating
Application.ScreenUpdating = False
Sheets("1 Hour Counts").Unprotect "Test"
'define a temp path for your image
tmpImageName = Environ$("temp") & "" & "TempChart.jpg"
'create image file
Call CreateJpg("1 Hour Counts", Sheets("sheet1").Range("A1:S" & lr))
'copy range to new wb/remove formulas
Set NewWb = Workbooks.Add
'copy all sheets
For cnt = 1 To ThisWorkbook.Sheets.Count
ThisWorkbook.Sheets(cnt).Copy NewWb.Sheets(cnt)
Next cnt
NewWb.Sheets("sheet1").Range("A1:S" & lr).Copy
NewWb.Worksheets("1 Hour Counts").Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'NewWb.Worksheets("1 Hour Counts").Shapes("Rectangle: Rounded Corners 1").Delete
'NewWb.Worksheets("1 Hour Counts").Shapes("Rectangle: Rounded Corners 2").Delete
NewWb.Worksheets("1 Hour Counts").Activate
NewWb.Worksheets("1 Hour Counts").Range("A1").Select
Application.DisplayAlerts = False
NewWb.Worksheets("Sheet1").Delete
NewWb.SaveAs FileName:=Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & ".xlsx", _
                                                        FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
FileStr = NewWb.FullName
NewWb.Close
Sheets("1 Hour Counts").Protect "Test"

'Creates and shows the outlook mail item

Set oApp = CreateObject("Outlook.Application")

Set oMail = oApp.CreateItem(0)

With oMail

.To = MailTo

.Cc = MailCC

.Bcc = MailBCC

.Subject = MailSub

.HTMLBody = "<body><img src=" & "'" & tmpImageName & "'/></body>"

.Attachments.Add FileStr

.Display

.Send

End With

'Deletes the temporary file

'WB.ChangeFileAccess Mode:=xlReadOnly

Kill (Environ$("temp") & "" & "TempChart.jpg")

Kill FileStr


'Restores screen updating and release Outlook

Application.ScreenUpdating = True

Set oMail = Nothing

Set oApp = Nothing

'Save Workbook

'ThisWorkbook.Save

End Sub

Public Sub CreateJpg(SheetName As String, xRgAddrss As Range)
'creates temp JPG file of range (xRgAddrss) by creating temp chart
'uses current wb sheet (sheetname) to locate temp chart
Dim xRgPic As Range
Worksheets(SheetName).Activate
Set xRgPic = xRgAddrss
xRgPic.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, _
                                                          xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "" & "TempChart.jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
End Sub
 
Upvote 0
thank you both for your reply , both seem to be working very well i am going to let both run on separate workbooks for now, again thank you so much !
 
Upvote 0
NdNoviceHlp said:
Hi again agentkramr. I'm guessing that your clipboard after repetitive use is crapping out. U can trial adding this code to the top of a module...
Code: 
#If VBA7 Then
    Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
#Else
    Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function CloseClipboard Lib "user32" () As Long
    Public Declare Function EmptyClipboard Lib "user32" () As Long
#End If
Then place this before the End Sub in the CreateJpg sub....
Code: 
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
HTH. Dave
Click to expand...
This is still doing the same thing(as in all the numbers are the same across the board. It pulls information from the DB on hour intervals. i know the coding in the sheet for the db is correct as it finishes refreshing and all the numbers are correct and different), it still looks like it isnt waiting for the information to refresh before it takes the screen shot and attaches the email
 
Upvote 0
AC PORTA VIA said:
try this
Code: 
Sub Test_Hourly()
Dim oApp As Object, oMail As Object, FileStr As String
Dim NewWb As Workbook, cnt As Integer
Dim FileName As String, MailSub As String, MailTxt As String
Dim tmpImageName As String
lr = Cells(Rows.Count, 1).End(xlUp).Row
'************************************************* ********
'Set email details; Comment out if not required
Const MailTo = "my email"
Const MailCC = "some2@someone.com"
Const MailBCC = "some3@someone.com"
MailSub = "test"
MailTxt = "test"
'Turns off screen updating
Application.ScreenUpdating = False
Sheets("1 Hour Counts").Unprotect "Test"
'define a temp path for your image
tmpImageName = Environ$("temp") & "" & "TempChart.jpg"
'create image file
Call CreateJpg("1 Hour Counts", Sheets("sheet1").Range("A1:S" & lr))
'copy range to new wb/remove formulas
Set NewWb = Workbooks.Add
'copy all sheets
For cnt = 1 To ThisWorkbook.Sheets.Count
ThisWorkbook.Sheets(cnt).Copy NewWb.Sheets(cnt)
Next cnt
NewWb.Sheets("sheet1").Range("A1:S" & lr).Copy
NewWb.Worksheets("1 Hour Counts").Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'NewWb.Worksheets("1 Hour Counts").Shapes("Rectangle: Rounded Corners 1").Delete
'NewWb.Worksheets("1 Hour Counts").Shapes("Rectangle: Rounded Corners 2").Delete
NewWb.Worksheets("1 Hour Counts").Activate
NewWb.Worksheets("1 Hour Counts").Range("A1").Select
Application.DisplayAlerts = False
NewWb.Worksheets("Sheet1").Delete
NewWb.SaveAs FileName:=Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & ".xlsx", _
                                                        FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
FileStr = NewWb.FullName
NewWb.Close
Sheets("1 Hour Counts").Protect "Test"

'Creates and shows the outlook mail item

Set oApp = CreateObject("Outlook.Application")

Set oMail = oApp.CreateItem(0)

With oMail

.To = MailTo

.Cc = MailCC

.Bcc = MailBCC

.Subject = MailSub

.HTMLBody = "<body><img src=" & "'" & tmpImageName & "'/></body>"

.Attachments.Add FileStr

.Display

.Send

End With

'Deletes the temporary file

'WB.ChangeFileAccess Mode:=xlReadOnly

Kill (Environ$("temp") & "" & "TempChart.jpg")

Kill FileStr


'Restores screen updating and release Outlook

Application.ScreenUpdating = True

Set oMail = Nothing

Set oApp = Nothing

'Save Workbook

'ThisWorkbook.Save

End Sub

Public Sub CreateJpg(SheetName As String, xRgAddrss As Range)
'creates temp JPG file of range (xRgAddrss) by creating temp chart
'uses current wb sheet (sheetname) to locate temp chart
Dim xRgPic As Range
Worksheets(SheetName).Activate
Set xRgPic = xRgAddrss
xRgPic.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, _
                                                          xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "" & "TempChart.jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
End Sub
Click to expand...
VBA Code: 
NewWb.SaveAs FileName:=Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & ".xlsx", _
                                                        FileFormat:=xlOpenXMLWorkbook

i didnt read my logs i am getting a compile error on this line
 
Upvote 0
You can also trial these lines of code after the "Application.cutcopymode=False" in the test hourly sub....
Code: 
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
As for timing issues, I would suggest saving the original wb at the start of the code. I don't know what logs you're referring to? Code either runs correctly, runs and produces erroneous results or it errors and crashes. If it has errored on that line of code, I would suggest placing the following line of code above that line and see what it says...
Code: 
msgbox "WbPath " & Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & ".xlsx"
I trialed this code before previously providing it (except the e-mail part) and all went as you requested. Without actually having your updating database, I don't think I can be of any further assistance. Good luck. Dave
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
VBA to Email Workbook
Replies
1
Views
821
agentkramr
A
A
  • Solved
VBA to send workbook but take a screen shot of a section of the newest sheet and attach in body of email
Replies
2
Views
1K
agentkramr
A
R
  • Question Question
Adding Email Signature to current VBA Code
Replies
3
Views
478
John_w
J
A
  • Question Question
add to VBA to wait for background queries to finish before starting
Replies
7
Views
2K
BSALV
BSALV
A
  • Question Question
VBA Help Copy/Attach/Email
Replies
0
Views
606
agentkramr
A

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top