VBA Question cant seem to resolve error

A

agentkramr

Board Regular
Joined
Dec 27, 2021
Messages
98
Platform
  1. Windows
what i have going on is that i have a code that copys cells from a sheet, drops them in to a workbook then attaches that to an email places a screenshot of the cells in the body. Then it sends the email, deletes the temp file saves and closes.

the code works about 70% of the time it gets an error about 30% of the time.

I have a windows scheduled task that makes it launch and i have 6 of different sheets with he same code that launch at the same time.

Sub Test_Hourly()

'Variable declaration

Dim oApp As Object, _

oMail As Object, _

WB As Workbook, _

ChartName As String, _

imgPath As String, _

FileName As String, MailSub As String, MailTxt 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

'define a temp path for your image

tmpImageName = VBA.Environ$("temp") & "\tempo.jpg"

'Makes a copy of the active sheet and save it to

'a temporary file

ActiveSheet.Copy

Set WB = ActiveWorkbook

FileName = "Test.xls"

On Error Resume Next

Kill "C:\" & FileName

On Error GoTo 0

Set RangeToSend = Worksheets("Test").Range("A1:S30")

RangeToSend.CopyPicture Appearance:=xlScreen, Format:=xlPicture

Set sht = Sheets.Add

sht.Shapes.AddChart

sht.Shapes.Item(1).Select

Set objChart = ActiveChart

With objChart

.ChartArea.Height = RangeToSend.Height

.ChartArea.Width = RangeToSend.Width

.ChartArea.Fill.Visible = msoFalse

.ChartArea.Border.LineStyle = xlLineStyleNone

.Paste

.Export FileName:=tmpImageName, FilterName:="JPG"

End With

'Now delete that temporary sheet

Application.DisplayAlerts = False

sht.Delete

Application.DisplayAlerts = True

'Copy and Paste Values to get rid of formulas

Sheets("1 Hour Counts").Unprotect "Test"

Sheets("1 Hour Counts").Range("A1:S30").Copy

Sheets("1 Hour Counts").Range("A1:S30").PasteSpecial xlPasteValues

ActiveSheet.Shapes("Rectangle: Rounded Corners 1").Delete

ActiveSheet.Shapes("Rectangle: Rounded Corners 2").Delete

WB.SaveAs FileName:="C:\Users\my user\Desktop\Automated Reports\Temp\test", FileFormat:=xlOpenXMLWorkbook

'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 WB.FullName

.Display

.Send

End With

'Deletes the temporary file

WB.ChangeFileAccess Mode:=xlReadOnly

Kill WB.FullName

WB.Close SaveChanges:=False

'Restores screen updating and release Outlook

Application.ScreenUpdating = True

Set oMail = Nothing

Set oApp = Nothing

'Save Workbook

ThisWorkbook.Save

End Sub

the error i about 30% of the time that makes my scheduled tasks stop firing is a Visual Basic Error

Run-time error '1004':

CopyPicture method of Range class failed

I have put a wait timer in there (which i removed for pasting purposes) that caused it to fail less but it still fails.

any help is greatly appreciated
 
Sort by date Sort by votes

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Ok. So, copy the whole sheet to a new workbook and then remove the formulas. You may need to remove the rectangles as per your original code. That should keep the sheet formatted. As far as the JPG, this code is doing the same as your original code. The range seems like it would make a rather large picture. Give it a trial. Dave
Code: 
Option Explicit
Sub Test_Hourly()
Dim oApp As Object, oMail As Object, FileStr As String
Dim NewWb As Workbook, ObjWorksheet As Worksheet
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 sheet to new wb
Set NewWb = Workbooks.Add
ThisWorkbook.Sheets("1 Hour Counts").Copy NewWb.Sheets(1)
'remove formulas
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").Range("A1").Select
Application.DisplayAlerts = False
'tidy up
NewWb.Worksheets("Sheet1").Delete
NewWb.SaveAs FileName:="C:\Users\my user\Desktop\Automated Reports\Temp\test.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

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

Kill FileStr


'Restores screen updating and release Outlook

Application.ScreenUpdating = True

Set oMail = Nothing

Set oApp = Nothing

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
picture is working great ! attachment is working as well but quick question, is there a way that i can have it attach the WHOLE workbook to the email and Keep the same file name as the original ?
 
Upvote 0
Not sure that I understand WHOLE wb? Do you mean all of the sheets of the original wb? U can't have 2 files with the same name... 2 files with same name and different format is possible. Trial...
Code: 
NewWb.SaveAs Filename:=Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & ".xlsx", _
                                                        FileFormat:=xlOpenXMLWorkbook
Dave
 
Upvote 0
NdNoviceHlp said:
Not sure that I understand WHOLE wb? Do you mean all of the sheets of the original wb? U can't have 2 files with the same name... 2 files with same name and different format is possible. Trial...
Code: 
NewWb.SaveAs Filename:=Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 5) & ".xlsx", _
                                                        FileFormat:=xlOpenXMLWorkbook
Dave
Click to expand...
yea i have other sheets in the workbook and the original file is an .xlsm
 
Upvote 0
Copy all sheets...
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
Dave
 
Upvote 0
Solution
NdNoviceHlp said:
Copy all sheets...
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
Dave
Click to expand...
getting an error on this compile error sub or function not defined
 
Upvote 0
I didn't repost the "CreateJpg" sub... it's still needed. Other wise you're going to have to indicate on what line of code the error is occurring. Tested OK for me. Dave
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
VBA to Email Workbook
Replies
1
Views
834
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
J
  • Solved
Emailing active WS as Excel attachment failing
Replies
5
Views
582
NoSparks
N
P
  • Solved
Email macro compile error
Replies
3
Views
602
duggie33
D
A
  • Question Question
add to VBA to wait for background queries to finish before starting
Replies
7
Views
2K
BSALV
BSALV

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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