agentkramr
Board Regular
- Joined
- Dec 27, 2021
- Messages
- 95
- Platform
- 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
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
