VBA Code: Lotus Notes Email Preparation From Excel Worksheet

Flani

New Member
Joined
Jul 11, 2012
Messages
17
Hi All,


I managed to get a code that will automate my email preparation. The code gets recipients, subject and the body of the mail from the active worksheet and it works perfectly for the recipients and subject, not so much for the body.


Say the mail body is c1, c2, c3, c4, c5, c6, c7 and c8


C1 is a blank cell.


C2= Hi All,
(C1 here for space)
C3= Please open the file in:
(C1 here for space)
C4= is the filepath plus a formula that updates the date of the file. The font should be in blue
(C1 here for space)
C5: is another body of the mail that should be italicized and in color red
(C1 here for space)
A screenshot "mypic" should be added in this line.
(C1 here for space)
C6=another part of the mail that should be in bold letters and color red
(C1 here for space)
C7=another part of the body of the mail



The code only finishes up to C5 and adds the attachment but without the additional formatting. The other part of the body cannot be captured bythe code anymore after the attachment has been pasted. Can you help me with a code please. Thanks
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
So here's the actual code. Instead of C1, C2,etc., it's actually E17, E18, E19,etc. A1 is for blank spaces. I still need to paste the the screenshot in the middle of the mail and i need to to format the texts.

Sub Email_BAC()


Application.ScreenUpdating = False
Range("a1").Select

Set bsrecWb = ActiveWorkbook
Calculate


'Created from several codes found on mrexcel.com
'Modified Original code by Nate Oliver (thank you)
'Thanks to help by mrexcel.com username "schielrn"
'Thanks to help by mrexcel.com username "Norie"
'Modified by Robert Balentine who knows not much about this stuff
'Date created 02-27-08
'This macro does the following:
' A. Confirmed working on Excel 2003
' B. Opens Lotus Notes 6.5 or 7
' C. Opens a new memo message
' D. Copies data from the excel spreadsheet, email addresses, subject, and body
' E. Pastes this data as TEXT into the email
' F. If a user has auto signature already configured in lotus notes, this is preserved (either html or text)

Dim Notes As Object
Dim db As Object
Dim WorkSpace As Object
Dim UIdoc As Object
Dim UserName As String
Dim MailDbName As String
Set Notes = CreateObject("Notes.NotesSession")
UserName = Notes.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set db = Notes.GetDataBase(vbNullString, MailDbName)
Set WorkSpace = CreateObject("Notes.NotesUIWorkspace")
Call WorkSpace.ComposeDocument(, , "Memo")
Set UIdoc = WorkSpace.CurrentDocument


'If cells are null, such as email address, cc, etc, then ignore and dont paste into email
On Error Resume Next

'Copy the email address from cell C19 into the TO: field in Lotus Notes
'Note: Addresses in this cell should be separated by a semicolon.
'Please change your current sheet's name from Sheet1 to your sheet's name


bsrecWb.Activate

Recipient = Sheets("Email").Range("B16").Value
Call UIdoc.FieldSetText("EnterSendTo", Recipient)

'Copy the email address from cellC C20 into the CC: field in Lotus Notes
'Note: Addresses in this cell should be separated by a semicolon
ccRecipient = Sheets("Email").Range("C16").Value
Call UIdoc.FieldSetText("EnterCopyTo", ccRecipient)

'Copy the email address from cell C21 into the BCC: field in Lotus Notes
'Note: Addresses in this cell should be separated by a semicolon
'bccRecipient = Sheets("Email").Range("A1").Value
'Call UIdoc.FieldSetText("EnterBlindCopyTo", bccRecipient)

'Copy the subject from cell C22 into the SUBJECT: field in Lotus Notes
Subject1 = Sheets("Email").Range("D16").Value
Call UIdoc.FieldSetText("Subject", Subject1)

'Copy the cells in the range (one column going down) into the BODY in Lotus Notes.
'You must set the last cell C47 to one cell below the range you wish to copy.

'screenshot
MyPic.Copy
'screenshot

Call UIdoc.GotoField("Body")
body1 = Sheets("Email").Range("E16").Value
body1 = body1 & vbCrLf & Sheets("Email").Range("A1").Value ' Space
body1 = body1 & vbCrLf & Sheets("Email").Range("E17").Value
body1 = body1 & vbCrLf & Sheets("Email").Range("A1").Value ' Space
body1 = body1 & vbCrLf & Sheets("Email").Range("E18").Value
body1 = body1 & vbCrLf & Sheets("Email").Range("A1").Value ' Space
body1 = body1 & vbCrLf & Sheets("Email").Range("A1").Value ' Space

Call UIdoc.InsertText(body1)


'Insert some carriage returns at the end of the email
Call UIdoc.InsertText(vbCrLf & vbCrLf)
Application.CutCopyMode = False





Set UIdoc = Nothing: Set WorkSpace = Nothing
Set db = Nothing: Set Notes = Nothing


MsgBox "Congratulations! Email created"

End Sub
 
Upvote 0
See if you can adapt this code to your specific requirements. It does everything you asked for, including different font styles and colours, an embedded image, file attachment and automatic signature, if defined in your Notes User preferences. You just need to edit the code in 2 sections where indicated to retrieve values from the relevant Excel cells. You shouldn't need to change any other parts of the code.

In Tools - References in the VB editor, you must tick the reference to Lotus Domino Objects for this code to compile successfully.
Code:
Public Sub Send_Notes_Email()

'Requires reference to Lotus Domino Objects (domobj.tlb) for constants such as EMBED_ATTACHMENT and FONT_HELV, etc.
'Code based on answer by Bill-Hanson:
'http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/Lotus_SmartSuite/Lotus_Notes/Q_22733557.html#a19616928

    Dim NSession As Object
    Dim NUIWorkspace As Object
    Dim NMailDb As Object
    Dim NDocumentTemp As Object
    Dim NUIDocumentTemp As Object
    Dim NUIDocument As Object
    Dim NRTItemBody As Object
    Dim NRTStyle As Object, NRTStyleDefault As Object
    Dim NRTItemAttachment As Object, embeddedAttachment As Object
    Dim Subject As String
    Dim SendTo As String, CopyTo As String, BlindCopyTo As String
    Dim fileAttachment As String
    Dim embedCells As Range
    Dim FSO As Object
    Dim tempFolder As String, tempCellsJPG As String
    Dim Copy_and_Paste As Boolean
    
    '--------- EDIT USER-DEFINED SETTINGS IN THIS SECTION ---------
    
    'The Excel cells to be included in the email body as an image
    
    Set embedCells = ActiveSheet.Range("A1:C8")
        
    'The file to be attached to the email, if it exists
    
    fileAttachment = "C:\folder1\folder2\file.txt"
    
    SendTo = "email1@email.com,email2@email.com"
    CopyTo = "email2@email.com"
    BlindCopyTo = ""
    Subject = "Email subject"
    
    '--------- END OF USER-DEFINED SETTINGS ---------
    
    'Copy_and_Paste flag
    'True = copy and paste Excel cells into email body using the clipboard
    'False = save Excel cells as a temporary .jpg file and import into email body
    
    Copy_and_Paste = True
        
    Set FSO = CreateObject("Scripting.FileSystemObject")
    tempFolder = FSO.GetSpecialFolder(2)
    
    'File name for temporary .jpg file containing Excel cells
   
    tempCellsJPG = tempFolder & "\" & Replace(FSO.GetTempName(), ".tmp", ".jpg")
    
    Set NSession = CreateObject("Notes.NotesSession")   'OLE (late binding only) because we access Notes UI classes
    Set NUIWorkspace = CreateObject("Notes.NotesUIWorkspace")
    Set NMailDb = NSession.GetDatabase("", "")
    NMailDb.OpenMail
   
    'Create the default rich text style
    
    Set NRTStyleDefault = NSession.CreateRichTextStyle
    With NRTStyleDefault
        .NotesColor = COLOR_BLACK
        .FontSize = 10
        .NotesFont = FONT_HELV
        .Bold = False
        .Italic = False
    End With
    
    Set NRTStyle = NSession.CreateRichTextStyle
   
    'Create a temporary NotesDocument
    
    Set NDocumentTemp = NMailDb.CreateDocument
    With NDocumentTemp
        .Form = "Memo"
        
        'Add a rich text item to contain the email body text and file attachment
        
        Set NRTItemBody = .CreateRichTextItem("Body")
        With NRTItemBody
            
            '--------- ADD/EDIT CODE IN THIS SECTION FOR THE EMAIL BODY TEXT ---------
            
            'Compose the email body text
            
            .AppendText "1st paragraph - default font."
            .AddNewLine 2

            With NRTStyle
                .NotesFont = FONT_ROMAN
                .FontSize = 14
                .NotesColor = COLOR_BLUE
                .Bold = True
            End With
            .AppendStyle NRTStyle
            .AppendText "2nd paragraph - Times New Roman Blue 14 Bold"
            .AddNewLine 2
        
            'Add placeholder text which will be replaced by the Excel cells
        
            .AppendText "{PLACEHOLDER}"
            .AddNewLine 2
            
            With NRTStyle
                .NotesFont = FONT_HELV
                .FontSize = 10
                .NotesColor = COLOR_RED
                .Italic = True
            End With
            .AppendStyle NRTStyle
            .AppendText "3rd paragraph - Helvetica Red 10 italic."
            
            'Same paragraph, default style
            
            .AppendStyle NRTStyleDefault
            .AppendText "  Excel cells are shown above."
            
            If fileAttachment <> "" Then
                .AddNewLine 2
                .AppendText fileAttachment & " attached"
                .AddNewLine 1
                .EmbedObject EMBED_ATTACHMENT, "", fileAttachment
                .AddNewLine 1
            End If
            
            '--------- END OF EMAIL BODY TEXT SECTION --------
            
        End With
        
        .Save False, False
    End With
   
    'Display the temporary document in the UI
    
    Set NUIDocumentTemp = NUIWorkspace.EditDocument(True, NDocumentTemp)
   
    'Copy the rich text to the clipboard, close the window, and delete the temp doc
    
    With NUIDocumentTemp
        .gotofield "Body"
        .SelectAll
        .Copy
        'The next 2 lines are not needed
        '.Document.SaveOptions = "0" 'prevent prompt
        '.Document.MailOptions = "0" 'prevent prompt
        .Close                      'therefore temp UI doc not saved
    End With
    NDocumentTemp.Remove True

    'Compose the real email document
    
    Set NUIDocument = NUIWorkspace.ComposeDocument(NMailDb.Server, NMailDb.filePath, "Memo")
    'Set NUIDocument = NUIWorkspace.ComposeDocument(, , "Memo")      'use local computer and current database
    With NUIDocument
        .FieldSetText "EnterSendTo", SendTo
        .FieldSetText "EnterCopyTo", CopyTo
        .FieldSetText "BlindCopyTo", BlindCopyTo
        .FieldSetText "Subject", Subject

        'The memo now has everything except the rich text from the temporary UI document and the Excel cells image.
        'The automatic signature (if defined in User Preferences) should be at the bottom of the memo.  Now, we just
        'paste the rich text and Excel cells into the body
        
        .gotofield "Body"
        .Paste
   
        'Replace the placeholder text with the Excel cells image
        
        .gotofield "Body"
        .FindString "{PLACEHOLDER}"
        '.DESELECTALL                   'Uncomment to leave the placeholder text in place (cells are inserted immediately before it)
        
        If Copy_and_Paste Then
            embedCells.CopyPicture xlBitmap
            .Paste
            Application.CutCopyMode = False
        Else
            Save_Object_As_JPG embedCells, tempCellsJPG
            .Import "JPEG Image", tempCellsJPG
            Kill tempCellsJPG
        End If

        'Set NotesDocument options to save and send the email without prompts when the Close method is called
        
        .Document.SaveOptions = "1"
        .Document.MailOptions = "1"
        
        .Close
    End With
    
End Sub


'Based on http://www.jpsoftwaretech.com/export-excel-range-to-a-picture-file/

Private Sub Save_Object_As_JPG(saveObject As Object, JPGfileName As String)

    'Save a picture of an object as a JPG/JPEG file
    
    'Arguments
    'saveObject     - any object in the CopyPicture method's 'Applies To' list, for example a Range or Shape
    'JPGfileName    - the file name (including folder path if required) to save the picture as
    
    Dim temporaryChart As ChartObject
     
    Application.ScreenUpdating = False
    
    saveObject.CopyPicture xlScreen, xlPicture
    
    Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
    With temporaryChart
        .Border.LineStyle = xlLineStyleNone      'No border
        .Chart.Paste
        .Chart.Export JPGfileName
        .Delete
    End With
    
    Application.ScreenUpdating = True
    
    Set temporaryChart = Nothing
    
End Sub
 
Upvote 0
The attached jpeg file seems to be stuck at the bottom of the mail. Is there a way to place it mid part of the mail?
 
Upvote 0
is there a way that I can send an email from the stationery (tools)? my daily email includes a command button
 
Upvote 0
Hi Excel Experts.

I need your help. I am trying to create an Excell file that will automatically send reference cell (exam score) to specific recepients, informing them of their score. I am really not an expert with codes so I was wondering if someone can teach this dummy here. hehe

So that say after exam scores are up, I will just enter their individual score in this sheet probably run a macro and it will send an email (using Lotus notes) to say 200 recepients notifying them of their scores.

This might be very easy to do. but please help. I am working on automating sending individual scores using excell. Thank you very much in advance and more power.
 
Upvote 0
Hi

@ John_w

At ".GOTOFIELD "Body" " in this part
Code:
With NUIDocumentTemp        
        .GOTOFIELD "Body"
        .SelectAll
        .Copy
        .Close                     
    End With
Error msg:
"Object variable with block not set"
My code stops, since NUIDocumentTemp has not been Set/created?
It will finish(create another temp-mail) If I manually make the macro run
Code:
Set NUIDocumentTemp = NUIWorkspace.EDITDOCUMENT(True, NDocumentTemp)
again.

is there a way around this? And what is the cause? =(
 
Last edited:
Upvote 0
Arithos, it might be a timing issue with the Notes UI. Therefore try adding a wait before the EditDocument line:
Code:
    Application.Wait DateAdd("s", 2, Now)
The code works perfectly for me on Lotus Notes 6.5.5. I haven't tried it on other versions.
 
Upvote 0
Arithos, it might be a timing issue with the Notes UI. Therefore try adding a wait before the EditDocument line:
Code:
    Application.Wait DateAdd("s", 2, Now)
The code works perfectly for me on Lotus Notes 6.5.5. I haven't tried it on other versions.

Thank you!

Since it's my first time using VBA to access other applications in this way I'll forgive myself for this obvius mistake (on my part).
I added your code two different places in my code. However, if I dont have just used Lotus Notes (In my case It has to be open on my other screen) I still get the same error in the same place, or when I try to run this line:

Code:
Set NUIDocument = NUIWorkspace.COMPOSEDOCUMENT(NMailDb.Server, NMailDb.FilePath, "Memo")

So I added the code:

Code:
Application.Wait DateAdd("s", 2, Now)

Above theese points of errors, and added some Errror handling to help my "users". Is there a way around this aswell? Add more wait time, have I added your code at the wrong places? (added it above the "Error-spots")

ps: I can verify that your code works on Lotus 8.5.x aswell :)
 
Upvote 0
This is my code in its entirety.

This is code from a Userform

I have marked the problem areas in RED so that its easy to identify, some of the code is redundant, and I know this.

Code:
Private Sub UserForm_Initialize()


Mottakerliste.Clear


With Mottakerliste
    .AddItem "bXXXX@sXXXXne.no"
    .AddItem "seXXXXnt@oXXXd.no"
    .AddItem "stXXXX9@haXXXXnken.no"
End With


End Sub






Private Sub Cancel_Click()


Unload Me


End Sub
Private Sub Send_Click()


 Dim NSession As Object
    Dim NUIWorkspace As Object
    Dim NMailDb As Object
    Dim NDocumentTemp As Object
    Dim NUIDocumentTemp As Object
    Dim NUIDocument As Object
    Dim NRTItemBody As Object
    Dim NRTStyle As Object, NRTStyleDefault As Object
    Dim NRTItemAttachment As Object, embeddedAttachment As Object
    Dim Subject As String
    Dim SendTo As String, CopyTo As String, BlindCopyTo As String
    Dim fileAttachment As String
    Dim embedCells As Range
    Dim FSO As Object
    Dim tempFolder As String, tempCellsJPG As String
    Dim Copy_and_Paste As Boolean


    Dim kopi1 As String
    Dim kopi2 As String
    Dim kopi3 As String
    Dim kopi4 As String
    
    Dim mmottaker As String, kopitaker As String
    
    MsgBox "For at dette skal gå i orden må jeg be om at du åpner mailen din, og har den oppe på den andre skjermen. Så trykker du OK"
    
    
    If Mottakerliste.Value = "bacXXXXXX@sXXXne.no" Then
        fileAttachment = "G:\HKCN-I Settlement\Kunder\Skagen\Failed trades\2014 Failed Trades\" & Format(Date, "mm mmmm") & "\" & Format(Date, "yyyymmdd") & " Failed trades" & ".xlsx"
    End If
    If Mottakerliste.Value = "seXXXent@odXXXnd.no" Then
        fileAttachment = "G:\HKCN-I Settlement\Kunder\ODIN\Failed trades\2014\" & Format(Date, "mm mmmm") & "\" & "Failed trades " & Format(Date, "ddmmyyyy") & ".xlsx"
    End If
    If Mottakerliste.Value = "sXXXX@haXXXXken.no" Then
        fileAttachment = "G:\HKCN-I Settlement\Kunder\Skagen\Failed trades\2014 Failed Trades\" & Format(Date, "mm mmmm") & "\" & Format(Date, "yyyymmdd") & " Failed trades" & ".xlsx"
    End If
    
    If checksturla = True Then kopi1 = "XXX@hanXXXXbaXXXen.no"
    If checkmathilde = True Then kopi2 = "mXXX1@hXXXXXanken.no"
    If checkanne = True Then kopi3 = "aXXXX7@hanXXXXXnken.no"
    
    If checksturla = False Then kopi1 = ""
    If checkmathilde = False Then kopi2 = ""
    If checkanne = False Then kopi3 = ""
    
    If customcopy.Value = "" Then
    kopi4 = ""
    Else
    kopi4 = customcopy.Value
    End If
    
    
    
    kopitaker = kopi1 & "," & kopi2 & "," & kopi3 & "," & kopi4
    BlindCopyTo = ""
    Subject = "Falte Handler"
    
    
    


    
    '--------- EDIT USER-DEFINED SETTINGS IN THIS SECTION ---------
    
    'The Excel cells to be included in the email body as an image
    
    'Set embedCells = ActiveSheet.Range("A1:C8")
       
    'The file to be attached to the email, if it exists
    
    
    
  
    
    SendTo = Mottakerliste.Value
    CopyTo = kopitaker
    BlindCopyTo = ""
    Subject = "Ny Macro for mail test!"
    Unload Me
    '--------- END OF USER-DEFINED SETTINGS ---------
    
    'Copy_and_Paste flag
    'True = copy and paste Excel cells into email body using the clipboard
    'False = save Excel cells as a temporary .jpg file and import into email body
    
    'Copy_and_Paste = True
        
    Set FSO = CreateObject("Scripting.FileSystemObject")
    tempFolder = FSO.GetSpecialFolder(2)
    
    'File name for temporary .jpg file containing Excel cells
   
    'tempCellsJPG = tempFolder & "\" & Replace(FSO.GetTempName(), ".tmp", ".jpg")
    
    Set NSession = CreateObject("Notes.NotesSession")   'OLE (late binding only) because we access Notes UI classes
    Set NUIWorkspace = CreateObject("Notes.NotesUIWorkspace")
    Set NMailDb = NSession.GetDatabase("", "")
    NMailDb.OPENMAIL
   
    'Create the default rich text style
    
    Set NRTStyleDefault = NSession.CreateRichTextStyle
    With NRTStyleDefault
        .NotesColor = COLOR_BLACK
        .FontSize = 10
        .NotesFont = FONT_HELV
        .Bold = False
        .Italic = False
    End With
    
    Set NRTStyle = NSession.CreateRichTextStyle
   
    'Create a temporary NotesDocument
    
    Set NDocumentTemp = NMailDb.CreateDocument
    With NDocumentTemp
        .Form = "Memo"
        
        'Add a rich text item to contain the email body text and file attachment
        
        Set NRTItemBody = .CreateRichTextItem("Body")
        With NRTItemBody
            
            '--------- ADD/EDIT CODE IN THIS SECTION FOR THE EMAIL BODY TEXT ---------
            
            'Compose the email body text
            
            .AppendText "Hei"
            .AddNewLine 2


            With NRTStyle
                .NotesFont = FONT_ROMAN
                .FontSize = 14
                .NotesColor = COLOR_BLUE
                .Bold = True
            End With
            .AppendStyle NRTStyle
            .AppendText ""
            .AddNewLine 2
        
            'Add placeholder text which will be replaced by the Excel cells
        
            .AppendText ""
            .AddNewLine 2
            
            With NRTStyle
                .NotesFont = FONT_HELV
                .FontSize = 10
                .NotesColor = COLOR_RED
                .Italic = True
            End With
            .AppendStyle NRTStyle
            .AppendText ""
            
            'Same paragraph, default style
            
            .AppendStyle NRTStyleDefault
            .AppendText " Vedlagt følger oversikt over handler som ikke er gjort opp:"
            
            If fileAttachment <> "" Then
                .AddNewLine 2
                .AppendText ""
                .AddNewLine 1
                .EmbedObject EMBED_ATTACHMENT, "", fileAttachment
                .AddNewLine 1
            End If
            
            '--------- END OF EMAIL BODY TEXT SECTION --------
            
        End With
        
        .Save False, False
    End With
   
    'Display the temporary document in the UI
    Application.Wait DateAdd("s", 2, Now)
    On Error GoTo NotesUIfeil
    [COLOR=#ff0000]Set NUIDocumentTemp = NUIWorkspace.EDITDOCUMENT(True, NDocumentTemp)[/COLOR]
   
    'Copy the rich text to the clipboard, close the window, and delete the temp doc
    
    With NUIDocumentTemp
      [COLOR=#ff0000]  .GOTOFIELD "Body"[/COLOR]
        .SelectAll
        .Copy
        'The next 2 lines are not needed
        '.Document.SaveOptions = "0" 'prevent prompt
        '.Document.MailOptions = "0" 'prevent prompt
        .Close                      'therefore temp UI doc not saved
    End With
    NDocumentTemp.Remove True


    'Compose the real email document
    Application.Wait DateAdd("s", 2, Now)
    [COLOR=#ff0000]Set NUIDocument = NUIWorkspace.COMPOSEDOCUMENT(NMailDb.Server, NMailDb.FilePath, "Memo")[/COLOR]
    'Set NUIDocument = NUIWorkspace.ComposeDocument(, , "Memo")      'use local computer and current database
    With NUIDocument
      [COLOR=#ff0000]  .FIELDSETTEXT "EnterSendTo", SendTo[/COLOR]
        .FIELDSETTEXT "EnterCopyTo", CopyTo
        .FIELDSETTEXT "BlindCopyTo", BlindCopyTo
        .FIELDSETTEXT "Subject", Subject


        'The memo now has everything except the rich text from the temporary UI document and the Excel cells image.
        'The automatic signature (if defined in User Preferences) should be at the bottom of the memo.  Now, we just
        'paste the rich text and Excel cells into the body
        
        .GOTOFIELD "Body"
        .Paste
   
        'Replace the placeholder text with the Excel cells image
        
        .GOTOFIELD "Body"
        .FINDSTRING ""
        '.DESELECTALL                   'Uncomment to leave the placeholder text in place (cells are inserted immediately before it)
        
        If Copy_and_Paste Then
            embedCells.CopyPicture xlBitmap
            .Paste
            Application.CutCopyMode = False
        End If
On Error GoTo 0
        'Set NotesDocument options to save and send the email without prompts when the Close method is called
        
        
        
        .Document.SaveOptions = "1"
        .Document.MailOptions = "1"
        
        .Close
        
    End With
    
    MsgBox "Da skal alt ha gått i orden, og mailen er sendt. Er du usikker se i Sent Mail"
    
    Exit Sub
    
    
NotesUIfeil:
    MsgBox "Det ser ut til at Excel jobber for fort for Notes, Spør Sturla hva som kan ha skjedd!"
    
    Exit Sub
    
  
    
End Sub




'Based on http://www.jpsoftwaretech.com/export-excel-range-to-a-picture-file/


Private Sub Save_Object_As_JPG(saveObject As Object, JPGfileName As String)


    'Save a picture of an object as a JPG/JPEG file
    
    'Arguments
    'saveObject     - any object in the CopyPicture method's 'Applies To' list, for example a Range or Shape
    'JPGfileName    - the file name (including folder path if required) to save the picture as
    
    Dim temporaryChart As ChartObject
     
    Application.ScreenUpdating = False
    
    saveObject.CopyPicture xlScreen, xlPicture
    
    Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
    With temporaryChart
        .Border.LineStyle = xlLineStyleNone      'No border
        .Chart.Paste
        .Chart.Export JPGfileName
        .Delete
    End With
    
    Application.ScreenUpdating = True
    
    Set temporaryChart = Nothing
    
End Sub










End Sub
 
Upvote 0

Forum statistics

Threads
1,213,487
Messages
6,113,938
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top