Emailing Named Ranges Using VBA

[bloodmilksky]

Hi Guys,

I was just wondering if anyone can help me.

I have a sheet that has alot of named ranges and all of them have the customers AC number at the top of the first column and the email address in the 2nd column (a1:b1,C11,E1:F1....and so on) they all vary in size for example A1:B20 C1:10 but all of the ranges names are the same as the AC Number

I was just wondering if anyone knows how to use VBA to run through Sheet2 and email of each of these named ranges to the email address at the top of the range.

I have asked this question previously but the answer that I was offered keeps erroring with:

Run-Time Error '-2147467259(80004005)':

Method 'MailEnvelope' of object '_worksheet' failed

and highlights this line in the code "With ActiveSheet.MailEnvelope"

Any help would be greatly appreciated.

many thanks

Jamie

Sub Email_Ranges()
    Dim rG As Range
    Dim RangeToSend As Range
    Dim CustomerMail As String
 
    Set rG = ActiveWorkbook.ActiveSheet.[b1]
 
    ActiveWorkbook.EnvelopeVisible = True
 
    Do While rG.Value <> vbNullString
        CustomerMail = rG.Value
        Set RangeToSend = rG.Offset(, -1).Resize(30, 2)
 
        'With RangeToSend.Parent.MailEnvelope
 
        ''Uncomment below if you get an error
        rG.Parent.Activate
        RangeToSend.Select
        With Selection.Parent.MailEnvelope
 
            .Introduction = "Good Morning"
            With .Item
                .To = CustomerMail
                .Subject = "Just testing, sorry for filling your inbox ^_^ "
                .display    'to test
                .Send      'to send
            End With
        End With
        Debug.Print CustomerMail & " receives " & RangeToSend.Address
        Set rG = rG.Offset(, 2)
    Loop
 
    ActiveWorkbook.EnvelopeVisible = False
End Sub
Sub Email_Ranges()
    Dim rG As Range
    Dim RangeToSend As Range
    Dim CustomerMail As String
 
    Set rG = ActiveWorkbook.ActiveSheet.[b1]
 
    ActiveWorkbook.EnvelopeVisible = True
 
    Do While rG.Value <> vbNullString
        CustomerMail = rG.Value
        Set RangeToSend = rG.Offset(, -1).Resize(30, 2)
 
        'With RangeToSend.Parent.MailEnvelope
 
        ''Uncomment below if you get an error
        rG.Parent.Activate
        RangeToSend.Select
        With Selection.Parent.MailEnvelope
 
            .Introduction = "Good Morning"
            With .Item
                .To = CustomerMail
                .Subject = "Just testing, sorry for filling your inbox ^_^ "
                .display    'to test
                .Send      'to send
            End With
        End With
        Debug.Print CustomerMail & " receives " & RangeToSend.Address
        Set rG = rG.Offset(, 2)
    Loop
 
    ActiveWorkbook.EnvelopeVisible = False
End Sub

[Kenneth Hobs]

Why not just use Outllook? http://www.rondebruin.nl/win/s1/outlook/bmail3.htm

As Ron points out, there are times where MailEvenlope with fail. Ron also shows how to email the range as html.

Of course you could always make the range into a pdf file and attach it.

[bloodmilksky]

is there a way that you could automate that translation of a range into a PDF File.

And thank you for coming back to me really appreciate your help.

[Kenneth Hobs]

Sub Test_PublishToPDF()
  Dim s As String, ss As String
  s = Range("F5").Value2 & Range("F4").Value2 & ".pdf"
  'ss= PublishToPDF(s, ActiveSheet) 'Use set print range
  
  Dim r As Range
  Set r = Columns("A:A").Find("TOTAL LIABILITIES & EQUITY")
  If r Is Nothing Then Exit Sub
  ss = PublishToPDF(s, Range("A1:B" & r.Row)) 'Use a dynamic range
  'ss = PublishToPDF(s, Range("A1:B" & r.Row), True) 'Use a dynamic range, prompt for filename
  Shell "cmd /c " & ss, vbNormalFocus
End Sub


Function PublishToPDF(fName As String, o As Object, _
  Optional tfGetFilename As Boolean = False) As String
  Dim rc As Variant
  rc = fName
  If tfGetFilename Then
    rc = Application.GetSaveAsFilename(fName, "PDF (*.pdf), *.pdf", 1, "Publish to PDF")
    If rc = "" Then Exit Function
  End If
  
  o.ExportAsFixedFormat Type:=xlTypePDF, fileName:=rc _
  , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
  :=False, OpenAfterPublish:=False
  
  PublishToPDF = rc
End Function

[bloodmilksky]

would this run through the ranges trhat I have currently set up on my workbook and create these PDF's or would I need to do it range by range?

[Kenneth Hobs]

You can use a loop to iterate range Areas. I will show you how when I can later today.

[Kenneth Hobs]

This worked for me. Run from activesheet with range A1 to ...
Place code in a Module. Add Word object in Visual Basic Editor (VBE) menus Tools > References. Play Main().

Sub Main()
    Dim r As Range, i As Long, c As Range
  Dim fp As String, fn(1 To 1) As Variant
  
  'File Path to save pdf's to.
  fp = ThisWorkbook.Path & "\"
  If Len(Dir(fp, vbDirectory)) = 0 Then
    MsgBox fp & " does not exist.", vbCritical, "Macro Ending"
    Exit Sub
  End If
  
  'Set range on current sheet and if odd columns, end.
  Set r = Range("A1", Range("A1").End(xlToRight))
  If (r.Cells.Count Mod 2) <> 0 Then
    MsgBox "The top row's column count must be an even number.", _
      vbCritical, "Macro Ending"
    Exit Sub
  End If
  
  'Interate r and make pdf, and send emails with pdf
  For i = 1 To r.Cells.Count Step 2
    Set c = Range(r(i).Value)
    If c Is Nothing Then GoTo NextI
    fn(1) = fp & r(i).Value & ".pdf"
    c.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fn, _
      Quality:=xlQualityStandard, IncludeDocProperties:=True, _
      IgnorePrintAreas:=False, OpenAfterPublish:=False
    OMail r(i + 1).Value, r(i).Value & " Report", _
      "Your report is attached.", fn
NextI:
  Next i
End Sub






'More Excel to Outlook Examples: http://www.rondebruin.nl/win/s1/outlook/bmail4.htm
'Add reference: Microsoft Outlook xx.x Library, where xx.x is 14.0, 15.0, 16.0, etc.
Sub OMail(sTo As String, sSubject As String, sBody As String, _
  Optional vAttachments, Optional bSend As Boolean = True)
  
  Dim olApp As Outlook.Application, olMail As Outlook.MailItem, i As Integer
  Set olApp = New Outlook.Application


  Set olMail = olApp.CreateItem(olMailItem)
  With olMail
    .To = sTo
    .Subject = sSubject
    .Body = sBody
    
    If Not IsEmpty(vAttachments) Then
      For i = LBound(vAttachments) To UBound(vAttachments)
        If Len(Dir(vAttachments(i))) <> 0 Then .Attachments.Add vAttachments(i)
      Next i
    End If
    
    If bSend Then
      .Send
      Else
      .Display
    End If
  End With
  
  Set olMail = Nothing
  Set olApp = Nothing
End Sub