VBA problem

Lagrande · Sep 24, 2020

Hello,

I have an Excel file with 2 worksheets. On each worksheet I have installed a button with macros to send the image of the sheet by email. The problem is that on one sheet it is the image of the other that is sent and yet I took the trouble to modify the code as well as the title for the assignment of the button to the correct sheet.

Here is my code for the 1st sheet

In red this is what I changed on the other code for the other sheet. What do I need to change or add?

Thanks

Rich (BB code):

Sub Mail_small_Text_And_JPG_Range_Outlook_PDCA ()
'Ron de Bruin, 25-10-2019
'This macro use the function named: CopyRangeToJPG
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim MakeJPG As String

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

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

strbody = "This is what I'm planning today." & "<br> <br>" & _
"Have a nice day! <br>"

'Create JPG file of the range
'Only enter the Sheet name and the range address
MakeJPG = CopyRangeToJPG ("PDCA", "A1: K23")

If MakeJPG = "" Then
MsgBox "Something go wrong, we can't create the mail"
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If

On Error Resume Next
With OutMail
.To = "xxx.xxxx@xxxx.com"
.CC = "xxx.xxxxxx@xxxx.com; xxxx.xxxx@xxxx.com;"
.BCC = ""
.Subject = "PDCA of the day"
.Attachments.Add MakeJPG, 1, 0
'Note: Change the width and height as needed
.HTMLBody = "<html> <p>" & strbody & "</p> <img src =" "cid: NamePicture.jpg" "width = 750 height = 800> </html>"
.Display 'or use .Send
End With
On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Function CopyRangeToJPG (NameWorksheet As String, RangeAddress As String) As String
'Ron de Bruin, 25-10-2019
Dim PictureRange As Range

With ActiveWorkbook
On Error Resume Next
.Worksheets (NameWorksheet) .Activate
Set PictureRange = .Worksheets (NameWorksheet) .Range (RangeAddress)

If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If

PictureRange.CopyPicture
With .Worksheets (NameWorksheet) .ChartObjects.Add (PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export About $ ("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets (NameWorksheet) .ChartObjects (.Worksheets (NameWorksheet) .ChartObjects.Count) .Delete
End With

CopyRangeToJPG = About $ ("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function

Logit · Sep 24, 2020

.
If you are accepting of this solution, it is from my toolbox :

VBA Code:

Option Explicit

'This macro copies the used range (as specified) of the indicated sheet name
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")  '<<-- edit sheet name as required
    ws1.Range("A3:K23").Copy
    Mail_Selection_Range_Outlook_Body
End Sub

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String

Dim xPath As String
Dim xWs  As String

xPath = Application.ActiveWorkbook.Path

Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("Sheet1").Range("A3:K23")  '<<----- edit range as required

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

'Turn off screen updating to prevent flickering / flashing
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

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

With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Summary Data"

    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    
    ' In place of the following statement, you can use ".Send" to
    ' Send the e-mail message.
    .Display
End With

On Error GoTo 0

'Turn on screen updating
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

''<<<>>> There is no need to edit anything in this Function.

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)
    
    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
    
End Function

Lagrande · Sep 24, 2020

It's almost perfect...i need the image as a picture...is this possible?

Logit · Sep 24, 2020

Ok ... try this one :

VBA Code:

Option Explicit

Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
    
    Dim plage As Object
    
    ThisWorkbook.Activate
    Worksheets(Namesheet).Activate
    
    Set plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)
    plage.CopyPicture
    
    With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(plage.Left, plage.Top, plage.Width, plage.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    
    Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete
    Set plage = Nothing

End Sub

Sub sendMail()
        
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Dim TempFilePath As String 'location of temp image
    Dim imgRNG As String 'area for image
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As Variant
    
    imgRNG = "A1:K23" 'change this for range

    'Create a new Microsoft Outlook session
    Set OutApp = CreateObject("outlook.application")
            
    'create a new message
    Set OutMail = OutApp.CreateItem(0)
            
    With OutMail
    
        .Subject = "Insert Subject here"
        
        'following bit is to setup the image
        Call createJpg("Sheet1", imgRNG, "MailAttach") 'Worksheet name <---------------------  <---------------------
        TempFilePath = Environ$("temp") & "\"
        .Attachments.Add TempFilePath & "MailAttach.jpg", 0, 0
            
        'Then we add an html <img src=''> link to this image
        '<br> = line break
        '
        strbody = "<span LANG=EN>" & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
        & "Hello,<br><br>Insert message here, use for next line" & _
        "<br><B>Image:</B><br><br><img src='cid:MailAttach.jpg'<br>"
        
        .Display 'display email to grab signature
        .htmlbody = strbody & "<br>" & .htmlbody ' pass body of text then line break then insert signature
        
        .To = "contact1@email.com; contact2@email.com"
        .Cc = "contact3@email.com"
        '.Send 'if you want to autosend enable this
        
    End With
        
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

End Sub

Lagrande · Sep 24, 2020

Run time error '9 with the 4th line

VBA Code:

Worksheets(Namesheet).Activate

Logit · Sep 24, 2020

I don't understand the error. The macro functions as required here.

Logit · Sep 24, 2020

Here is a download link : Email Pic Range.xlsm

VBA problem

Lagrande

New Member

Excel Facts

Logit

Well-known Member

Lagrande

New Member

Logit

Well-known Member

Lagrande

New Member

Logit

Well-known Member

Logit

Well-known Member

Similar threads

Forum statistics

Share this page

VBA problem

Lagrande

New Member

Excel Facts

Logit

Well-known Member

Lagrande

New Member

Logit

Well-known Member

Lagrande

New Member

Logit

Well-known Member

Logit

Well-known Member

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