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

Logit · Jan 26, 2022

Definitely.

agentkramr · Jan 27, 2022

Logit said:
Definitely.

i went back to the old code ran the vba tool , it is still doing the same thing. i am honestly at a loss i have been trying to troubleshoot this thing for weeks. all the formulas work because when i open the sheet and let the queries run on their own they fill in what they should with proper numbers

Logit · Jan 27, 2022

Here is a small project that pastes the active sheet into the email body. Maybe you can use it to replace your existing project ? Granted it will require you
to specify the range to be copied ... and you will need to add in your other code for a complete project.

VBA Code:

Option Explicit
Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String

Set rng = Nothing

' Only send the visible cells in the selection.
Set rng = Sheets("Daily Percentage").Range("A1:G35" & lEndRow).SpecialCells(xlCellTypeVisible)

If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail

    .To = "me@yahoo.com"
    .CC = ""
    .BCC = ""
    .Subject = "Please review the latest Combined Closed Schedule Update"

    .HTMLBody = "<p>Here is the latest Combine Close Schedule figure updates for your review : " & "<br><br>" & _
                RangetoHTML(rng) & "<br><br><br>" & _
                "Sincerely, " & "<br><br>" & _
                "Tom Jones </p>"
    
    ' In place of the following statement, you can use ".Display" to display the e-mail message.
    '.Send
    .Display
    
End With

On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    
    Set TempWB = Workbooks.Add(1)
    
    Application.ScreenUpdating = False
    
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
                          
    'Close TempWB
    TempWB.Close savechanges:=False
    
    'Delete the htm file we used in this function
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    
    Application.ScreenUpdating = True
    
End Function

Download workbook : WORKS Send Sheet In Body.xlsm

agentkramr · Jan 28, 2022

Logit said:

Here is a small project that pastes the active sheet into the email body. Maybe you can use it to replace your existing project ? Granted it will require you
to specify the range to be copied ... and you will need to add in your other code for a complete project.

VBA Code:

Option Explicit
Sub Mail_Selection_Range_Outlook_Body()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String

Set rng = Nothing

' Only send the visible cells in the selection.
Set rng = Sheets("Daily Percentage").Range("A1:G35" & lEndRow).SpecialCells(xlCellTypeVisible)

If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail

    .To = "me@yahoo.com"
    .CC = ""
    .BCC = ""
    .Subject = "Please review the latest Combined Closed Schedule Update"

    .HTMLBody = "<p>Here is the latest Combine Close Schedule figure updates for your review : " & "<br><br>" & _
                RangetoHTML(rng) & "<br><br><br>" & _
                "Sincerely, " & "<br><br>" & _
                "Tom Jones </p>"
   
    ' In place of the following statement, you can use ".Display" to display the e-mail message.
    '.Send
    .Display
   
End With

On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
   
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
    'Copy the range and create a new workbook to past the data in
    rng.Copy
   
    Set TempWB = Workbooks.Add(1)
   
    Application.ScreenUpdating = False
   
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
   
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
   
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
   
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
                         
    'Close TempWB
    TempWB.Close savechanges:=False
   
    'Delete the htm file we used in this function
    Kill TempFile
   
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
   
    Application.ScreenUpdating = True
   
End Function

Download workbook : WORKS Send Sheet In Body.xlsm

Quick qestion, i had a thought that maybe somehow the vba isnt waiting for the background queries to end before doing its thing. Do you know how i could implement that in to my original script ?

VBA Question

agentkramr

Board Regular

Logit

Well-known Member

Excel Facts

agentkramr

Board Regular

Logit

Well-known Member

agentkramr

Board Regular

Similar threads

Forum statistics

Share this page

VBA Question

agentkramr

Board Regular

Logit

Well-known Member

Excel Facts

agentkramr

Board Regular

Logit

Well-known Member

agentkramr

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