VBA Question

agentkramr · Jan 24, 2022

i have posted here before and received some help have tried some different approaches and still cant solve this. i know it is doable but for some reason just one portion isnt functioning correctly. i have a vbs that fires to open a spreadsheet and closes it when the VBA is done (this functions correctly)
the VBA creates an email attaches a screen shot to the body of an email attaches a xlsx version of the workbook to the email instead of the original version xlsm (this works) the only thing is the screen shot and attached workbook dont have the refreshed numbers its like it doesnt wait for the background queries to finish before it takes the screenshot and attaches a copy. It all connects to a Oracle database to collect some figures.
Any help is greatly appreciated

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



'Save Workbook

ThisWorkbook.Save

'************************************************* ********

'Set email details; Comment out if not required

Const MailTo = "test@test.com"

'Const MailCC = "[EMAIL]some2@someone.com[/EMAIL]"

'Const MailBCC = "[EMAIL]some3@someone.com[/EMAIL]"

MailSub = "Test"

MailTxt = ""



'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:S50"))

'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:S50").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



OpenClipboard (0&)

EmptyClipboard

CloseClipboard





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

agentkramr · Jan 25, 2022

Logit said:
You'll need to post your complete project for download and review.

it works with an old vba code that i was using but it would get an error like 30% of the time. i need it to be like 99% on.

agentkramr · Jan 25, 2022

Logit said:
You'll need to post your complete project for download and review.

apologies i just posted the sheet without tagging it as a reply. I really do appreciate your help

Logit · Jan 26, 2022

I don't have access to your Oracle DB so the workbook is not fully functional here.

I've been reading your code, following the logic line by line. I may not have fully understood how the logic is flowing but I wonder if a single line of
code should be commented out because it appears the macro is creating the chart you are seeking ... pasting it to the TEMP sheet ... then before that
TEMP sheet can be copied and pasted to the email ... the macro is deleting the very chart you are wanting.

Look at this :

VBA Code:

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


':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

'What happens if you comment out this line of code ?
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete

':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::



End Sub

agentkramr · Jan 26, 2022

i get an error Run-Time Error '1004'"
CopyPicture method of Range class failed about 70 % of the time when it runs

i am curious though.... could my vbs that i make it launch with be causing the issue ?

Code:

Dim objExcel
Dim objWorkBook
Set objExcel = CreateObject("EXCEL.APPLICATION")
Set objWorkBook = objExcel.Workbooks.Open("C:\Users\jamesb\Desktop\Automated Reports\Hourly\test Hourly Counts Auto")
On Error Resume Next
objExcel.DisplayAlerts=False
objExcel.Run("test_Hourly")
objExcel.DisplayAlerts=True
objWorkBook.Close True
Set objWorkBook = Nothing
Set objExcel = Nothing

could it maybe close it too fast or something ?

agentkramr · Jan 26, 2022

Logit said:
I don't have access to your Oracle DB so the workbook is not fully functional here.

I've been reading your code, following the logic line by line. I may not have fully understood how the logic is flowing but I wonder if a single line of
code should be commented out because it appears the macro is creating the chart you are seeking ... pasting it to the TEMP sheet ... then before that
TEMP sheet can be copied and pasted to the email ... the macro is deleting the very chart you are wanting.

Look at this :

VBA Code:

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 '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: 'What happens if you comment out this line of code ? Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete '::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: End Sub

when it does function the numbers are changing as they should

Logit · Jan 26, 2022

could it maybe close it too fast or something ?

I doubt it.

i get an error Run-Time Error '1004'"

What line of code is highlighted in yellow when you get that error ?

agentkramr · Jan 26, 2022

Logit said:
I doubt it.

What line of code is highlighted in yellow when you get that error ?

Logit · Jan 26, 2022

That error is prior to the last line of code. Something else is going on.

I wonder if your workbook is simply corrupted and either needs to be repaired or completely rebuilt from the start ?

Logit · Jan 26, 2022

10 ways to recover a corrupted Excel workbook

Download repair workbook : VBA_Repair.xls

Any attempts at repair should ONLY BE DONE ON A COPY OF YOUR WORKBOOK !! If the repair works as expected, then it can be applied to the original workbook.

agentkramr · Jan 26, 2022

Logit said:
10 ways to recover a corrupted Excel workbook

Download repair workbook : VBA_Repair.xls

Any attempts at repair should ONLY BE DONE ON A COPY OF YOUR WORKBOOK !! If the repair works as expected, then it can be applied to the original workbook.

I ran it, it seems like also after commenting out that line it is putting a screenshot on top of the original spreadsheet and just keeps stacking them on top of one another. Should i go back to my original code totally then run the VBA Repair?

VBA Question

agentkramr

Board Regular

agentkramr

Board Regular

Excel Facts

agentkramr

Board Regular

Logit

Well-known Member

agentkramr

Board Regular

agentkramr

Board Regular

Logit

Well-known Member

agentkramr

Board Regular

Attachments

Logit

Well-known Member

Logit

Well-known Member

agentkramr

Board Regular

Similar threads

Forum statistics

Share this page

VBA Question

Board Regular

Board Regular

Excel Facts

Board Regular

Well-known Member

Board Regular

Board Regular

Well-known Member

Board Regular

Attachments

Well-known Member

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