• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

(excel range to new mail) Loop and read range and copy those ranges into new email

Like if i want to name a list of cells that have the email addresses in them already and if I want to name the range to be copied and pasted instead of using the row and column identifiers.

So in this portion I'd like for it to refer to a list of email addresses. On the line with the .To = "" I'd like for it to refer to a list of emails.

Code: 
With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        For i = i To 1 Step -1 'reverse order
            .Attachments.Add Environ("temp") & "\img" & i & ".jpg" ', olByValue, 0
          .HTMLBody = .HTMLBody & "<br><img src='cid:img" & i & ".jpg'><br><br>"
        Next
        .HTMLBody = .HTMLBody & "<br><br>Regards"
        .Subject = "This is the Subject line"
        .Display  'or use .Display
  End With

And then instead of having the list of ranges like this I'd like to be able to tell it to go a named range and copy and paste it.

upload_2017-8-23_11-46-9.png
 
The below code works perfectly for the normal table how this can be edited for paste as image. Looking for a quick response

Deepak said:
Check this..

I haven't tested!!


Code: 
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim myrng As Range
    Dim r As Range

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
'  Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    With Sheets("Home")
        Set myrng = .Range("F2").CurrentRegion.Resize(Application.CountA(.Columns("F")) - 1, 1).Offset(1)
    End With

For Each r In myrng
    Set rng = Sheets(r.Value).Range(r.Offset(, 1))
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
'    On Error GoTo 0

'    If rng Is Nothing Then
'        MsgBox "The selection is not a range or the sheet is protected" & _
'              vbNewLine & "please correct and try again.", vbOKOnly
'        Exit Sub
'    End If

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

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

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .Send  'or use .Display
    End With
    On Error GoTo 0
' do the some pause
Application.Wait Now + Time("00:00:01")
Next

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    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
Click to expand...
 
Hello everybody

i need some help please in VBA Code

I want to automize a VBA code to send mail adding range of cells in the mail body as picture or attaching them as picture also

my sheet name is SLA and the range of cells is from A2:Z20

Thanks for support
 
Mohamed.Zedan
As a new member, You have ... today read Forum Rules from

Site Rules - New Users - Please Read

Hi all, Welcome to the Chandoo.org Forums. Posting Rules & Etiquette The Chandoo.org Forums is a collaborative and happy place to learn and expand your Excel knowledge. The Chandoo.org Forums consist of several Sub-Forums based on the type of question/area of Excel you are interested in...
chandoo.org
You would reread those.
Isn't there written Start a new post every time you ask a question, even if the theme is similar. ... ?
... as well as ...
There are more basic things, which You would notice too
- You'll remember those while You'll reread those.
 
Hi Deepak,

Thanks for this brilliant macro, I;ve tweaked the code according to my need, but i'm facing an issue with this macro. Issue is that receivers of mail generated through this macro is not able to see the images, they are having this error "The linked image cannot be displayed. The file may have moved, renamed, or deleted. Verify that the link points to the correct file and location."

Below is the code:

>>> use code - tags <<<
Code: 
Function AlreadyOpen(sFname As String) As Boolean
    Dim wkb As Workbook
    On Error Resume Next
    Set wkb = Workbooks(sFname)
    If Err.Number = 0 Then
        AlreadyOpen = True
    Else
        AlreadyOpen = False
    End If
End Function
----------------------------------------------------------------------------------------------------------------------------------------
Sub NWM_DILAA_ToOutlook()
Dim oLookApp As Outlook.Application
Dim oLookFdr As Outlook.Folder
Dim oLookNsp As Outlook.Namespace
Dim oLookItm As Outlook.MailItem
Dim NVPath As String
Dim newdate As String
Dim mailSubj As String
Dim rng As Range
Dim wdrange As Object
Dim wdoc As Object
Dim wbk As Workbook
Dim ccypath As String
Dim mailTo_List As String
Dim mailCC_List As String
Dim arrSh(2) As String
Dim namesheet As String
arrSh(0) = "New NWM Summary"
arrSh(1) = "Grid"
arrSh(2) = "Summary"
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
ThisWorkbook.Activate
NWMSolosPath = ThisWorkbook.Sheets("Reference").Range("NWMSolospath")
newdate = Format(ActiveSheet.Range("COB_DATE"), "yyyymmdd")
ccypath = NWMSolosPath & "\" & newdate & " NW Markets Solo DILAA" & "\" & "CCy Profile"
mailTo_List = Sheets("Reference").Range("NWMToList").Value
mailCC_List = Sheets("Reference").Range("NWMCCList").Value
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
If AlreadyOpen(newdate & " " & " NW Markets Solo DILAA.xlsm") = False Then
    Application.AutomationSecurity = msoAutomationSecurityLow
    Set wbk = Workbooks.Open(Filename:=NWMSolosPath & "\" & newdate & " NW Markets Solo DILAA" & "\" & newdate & " NW Markets Solo DILAA.xlsm", UpdateLinks:=0, ReadOnly:=True)
    Else
    Set wbk = Workbooks(newdate & " " & " NW Markets Solo DILAA.xlsm")
    Application.AutomationSecurity = msoAutomationSecurityByUI
End If
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
   If AlreadyOpen("CCy Profile.xlsx") = False Then
       wbk.Sheets(Array("CCY Profile")).Copy
           ActiveSheet.Cells.Copy
           Cells.PasteSpecial paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
           :=False, Transpose:=False
           Application.CutCopyMode = False
           Format (Range("B4:E76").Select), ("#,##0")
           Range("A1").Select
           Application.DisplayAlerts = False
           ActiveWorkbook.SaveAs Filename:=ccypath & ".xlsx"
           Application.DisplayAlerts = True
       Set wb2 = ActiveWorkbook
     Else
        Set wb2 = Workbooks("CCy Profile.xlsx")
End If
'---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
With ThisWorkbook.Sheets("Reference")
   For i = 1 To 4
      Filerange = .Cells(6, i + 3).Value
      
        If i = 4 Then j = 2 Else j = i - 1
         Call createJpg(arrSh(j), Range(Filerange).Address, "img" & i, wbk)
  Next i
    
End With
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
      With OutMail
        .To = mailTo_List
        .CC = mailCC_List
        .Subject = "SOC Metrics for Daily Call"
        .Attachments.Add wb2.FullName  'attach currency file
        .Display
'--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
         For i = 1 To 4 'Step -1 'reverse order'With OutMail
          .Attachments.Add Environ("temp") & "\img" & i & ".jpg" ', olByValue, 0
          .HTMLBody = .HTMLBody & "<br><img src='cid:img" & i & ".jpg'><br><br>"
          Next i 'End With
           .HTMLBody = .HTMLBody & "<br><br>Regards" & "<br><br>"
      End With 'Outmail End with
    
wbk.Close False
wb2.Close False
End Sub

Private Sub createJpg(namesheet As String, nameRange As String, nameFile As String, wbk As Workbook)
    wbk.Worksheets(namesheet).Activate
    Set Plage = wbk.Worksheets(namesheet).Range(nameRange)
    Plage.CopyPicture
    With wbk.Worksheets(namesheet).ChartObjects.Add(Plage.Left, Plage.Top, Plage.Width, Plage.Height)
        .Activate
        .Chart.paste
        .Chart.Export Environ("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    wbk.Worksheets(namesheet).ChartObjects(Worksheets(namesheet).ChartObjects.Count).Delete
Set Plage = Nothing
End Sub
 
Last edited by a moderator:
You must log in or register to reply here.
Back
Top