VBA Question cant seem to resolve error

agentkramr · Dec 27, 2021

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

NdNoviceHlp · Dec 27, 2021

Hi agentkramr and Welcome to the Board! I would start by placing "Option Explicit" at the top of your code module and then declaring all of your variables. If that doesn't resolve issues, replace all the "Active" with specific references. I have no idea why U are copying the active sheet before using copypicture? Here's a link that might help (note the copypicture syntax)... Viewing a different excel workbook in a userform
HTH. Dave
ps. please use code tags

agentkramr · Dec 27, 2021

Could you give me an example of of replacing a my "active" with specific references , i am new to VBA so i might be doing things a bit backwards. i have the sheet being copied to a new workbook then it takes a screensnap of the cells to place in the body of the email. i dont know if things are supposed to be in a specirfic order. I know i have been working on this for about a week and need to clear it up to move on to other projects. So any help is always greatly appreciated

NdNoviceHlp · Dec 27, 2021

Not sure I understand why U need to copy the sheet to a new wb and then take a screenshot of a range in the copied sheet? Why not just take a picture of the original range? When U get sporadic errors it seems XL gets lost when using active sheet or active chart etc. It's better to use Sheets("Sheet1"). Range etc. Also, U never declared your range variable which lets XL choose whatever it wants as a variant variable . That's why the previous mention of using Option Explicit. Anyways, the sub at the link seems like it would do what U want if U input the right parameters. Dave

agentkramr · Dec 28, 2021

i make a copy to attach a copy that isnt using an oracle connection so they dont the confusion of the original not connecting to oracle then the screen shot is to attach it to the body so they can see what they need to see without having to open the sheet as some users want the sheet and other just want the info inside it. Again i am new to VBA so if you have code corrections i am more than open to them. so when i said can you show me an example it is because i dont know. Again this is my first rodeo on this. i am trying to get better

NdNoviceHlp · Dec 28, 2021

You can give this a trial. Please save your wb to a back up file before testing. HTH. 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 range to new wb/remove formulas
Sheets("1 Hour Counts").Range("A1:S30").Copy
Set NewWb = Workbooks.Add
Set ObjWorksheet = NewWb.Worksheets(1)
With ObjWorksheet
.Name = "1 Hour Counts"
End With
NewWb.Worksheets("1 Hour Counts").Range("A1").PasteSpecial xlPasteValues
NewWb.Worksheets("1 Hour Counts").Shapes("Rectangle: Rounded Corners 1").Delete
NewWb.Worksheets("1 Hour Counts").Shapes("Rectangle: Rounded Corners 2").Delete
NewWb.SaveAs FileName:="C:\Users\my user\Desktop\Automated Reports\Temp\test.xlsx", FileFormat:=xlOpenXMLWorkbook
'NewWb.SaveAs FileName:="C:\Users\my user\Desktop\Automated Reports\Temp\test", FileFormat:=xlOpenXMLWorkbook
Application.CutCopyMode = False
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
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

agentkramr · Dec 28, 2021

gives an Run time error '-2147024894(80070057)
the item with the specified name wasnt found.

i hit debug

it goes to NewWB.Worksheets("1 Hour Counts").Shapes(Rectangle: Rounded Corners1").Delete

agentkramr · Dec 28, 2021

on the created item it is also losing all of my formatting and everything

NdNoviceHlp · Dec 28, 2021

You can just remove those 2 lines of code re. rectangle.delete. What created item is losing it's format... the JPG or the wb? Dave

agentkramr · Dec 28, 2021

the workbook and the JPG, i have stuff that is colored and cells stretched to a different width this gives me my info but minus all the formatting i have other than that the generation and email works

VBA Question cant seem to resolve error

agentkramr

Board Regular

Excel Facts

NdNoviceHlp

Well-known Member

agentkramr

Board Regular

NdNoviceHlp

Well-known Member

agentkramr

Board Regular

NdNoviceHlp

Well-known Member

agentkramr

Board Regular

agentkramr

Board Regular

NdNoviceHlp

Well-known Member

agentkramr

Board Regular

Similar threads

Forum statistics

Share this page

VBA Question cant seem to resolve error

Board Regular

Excel Facts

Well-known Member

Board Regular

Well-known Member

Board Regular

Well-known Member

Board Regular

Board Regular

Well-known Member

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock