agentkramr
Board Regular
- Joined
- Dec 27, 2021
- Messages
- 98
- Platform
- Windows
So my VBA takes a screen shot of a selection of cells, attaches the workbook in XLSX format , and then emails it.
I have this same VBA in 5 other workbooks i use a VBS
to kick the automated task of running them one after another. No matter which one i put as the beginning one it fails at
with
it will only do this for whichever one runs first, so if i swap them it is the same results. if i run each one seperately from excel they work fine, if i run them seperately from a vbs then run fine, if i run them together with the vbs it works fine, the problem ONLY happens during the the windows scheduled task that i have created that starts the vbs for me
i have chased this issue for about a week now. i have tried putting in wait timers in the vba and the vbs, i have tried the vba in different ways it ALWAYS comes down to this error
VBA Code:
Sub Test1_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 = "[EMAIL]some2@someone.com[/EMAIL]"
'Const MailBCC = "[EMAIL]some3@someone.com[/EMAIL]"
MailSub = "Test Hourly Counts"
MailTxt = ""
ThisWorkbook.Save
Workbooks("Test Hourly Counts Auto").RefreshAll
'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:T50"))
'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:T50").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
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
End SubI have this same VBA in 5 other workbooks i use a VBS
Code:
Dim objExcel
Dim objWorkBook
Set objExcel = CreateObject("EXCEL.APPLICATION")
Set objWorkBook = objExcel.Workbooks.Open("C:\Users\automatedreports\Desktop\Automated Reports\Hourly\Test 1")
On Error Resume Next
objExcel.DisplayAlerts=False
objExcel.Run("Test1_Hourly")
objExcel.DisplayAlerts=True
objWorkBook.Close True
Set objWorkBook = objExcel.Workbooks.Open("C:\Users\automatedreports\Desktop\Automated Reports\Hourly\Test 2")
On Error Resume Next
objExcel.DisplayAlerts=False
objExcel.Run("Test2_Hourly")
objExcel.DisplayAlerts=True
objWorkBook.Close False
objExcel.Quit
Set objWorkBook = Nothing
Set objExcel = Nothing
VBA Code:
xRgPic.CopyPicture Appearance:=xlScreen, Format:=xlPictureVBA Error 1004 - CopyPicture method of Range class failed
it will only do this for whichever one runs first, so if i swap them it is the same results. if i run each one seperately from excel they work fine, if i run them seperately from a vbs then run fine, if i run them together with the vbs it works fine, the problem ONLY happens during the the windows scheduled task that i have created that starts the vbs for me
i have chased this issue for about a week now. i have tried putting in wait timers in the vba and the vbs, i have tried the vba in different ways it ALWAYS comes down to this error
