Body uit meer dan 1 range

[jolly01]

Onderstaand de code van Ron de Bruin om een range uit een sheet om te zetten naar de body van een email.

Ron's voorbeeld toont 1 range voor de Body. Ik zou graag 2 ranges voor de body willen gebruiken. De eerste range in tabblad "Sjabloon" A1:A10 en de tweede Range in tabblad "Export" A1:F43 direct eronder in de body van de email.

Kan iemand Ron's code aanpassen zodat ik beide ranges onder elkaar in de body van de email krijg?

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    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

Sub Mail_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    Set rng = Nothing
    On Error Resume Next
    [COLOR="red"]Set rng = Sheets("Sjabloon").Range("A1:B10").SpecialCells(xlCellTypeVisible)
    Set rng = Sheets("Export").Range("A1:F43").SpecialCells(xlCellTypeVisible)[/COLOR]    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
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
        .To = "aaaaa@bbbbbb.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .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

 

[Roncancio]

' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim rng1 As Range
    Dim OutApp As Object
    Dim OutMail As Object
 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Sjabloon").Range("A1:B10").SpecialCells(xlCellTypeVisible)
    Set rng1 = Sheets("Export").Range("A1:F43").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    If rng Is Nothing Or rng1 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
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
        .To = "aaaaa@bbbbbb.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng) & vbNewLine & RangetoHTML(rng1)
        .Display   'or use .Send
    End With
    On Error GoTo 0
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing

Zo kan het wel.

Met vriendelijke groet,


Roncancio

 

[jolly01]

Hoi Roncancio,
Bedankt voor je input.

Ik heb jouw gehele code over die van mij geplakt.

De macro zet alleen de Range van "Sjabloon" in de body, die van "Export" echter niet. Ik heb geen beveiliging op "Export" staan.

Moet er ook code veranderd worden in Function RangetoHTML(rng As Range)?
Mijn eerst geplaatste code van Ron. Of doe ik iets anders niet goed?

 

[Roncancio]

Sub Mail_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim rng1 As Range
    Dim OutApp As Object
    Dim OutMail As Object
 
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Sjabloon").Range("A1:B10").SpecialCells(xlCellTypeVisible)
    Set rng1 = Sheets("Export").Range("A1:F43").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    If rng Is Nothing Or rng1 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
 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
        .To = "aaaaa@bbbbbb.com"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng) & vbNewLine & RangetoHTML(rng1)
        .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

Heb je de gehele code over je code geplakt?
Bij mij werkt het wel maar ik heb het bereik van Export in een aparte variabele (rng1) geplaatst.
Rng bevat alleen Het bereik van Sjabloon dus vandaar mijn vraag.
Bovenstaande code is de gehele code van Sub Mail_Range_Outlook_Body().
Aan de code voor de functie heb ik niets gewijzigd.

Met vriendelijke groet,


Roncancio

 

[jolly01]

Roncancio,

Ik heb de gehele worksheet toegevoegd.
Nogmaals jouw code in Sub Mail_Range_Outlook_Body() geplakt.

De macro neemt nog steeds alleen de range van "Sjabloon"

Kan je er misschien even naar kijken?

bvd

 

[Roncancio]

Hm.
Als ik de macro start, krijg ik het resultaat wat m.i. de bedoeling is.
(zie bijlage).

Ik heb dus niets aan de code veranderd.

Met vriendelijke groet,


Roncancio

 

[jolly01]

Bedankt voor de check. Zowel mijn office 2003 thuis en op mijn werkt toont alleen de range van "sjabloon"

Is het misschien een instelling in Excel die aangevinkt moet worden ofzo?

 

[Roncancio]

Bedankt voor de check. Zowel mijn office 2003 thuis en op mijn werkt toont alleen de range van "sjabloon"

Is het misschien een instelling in Excel die aangevinkt moet worden ofzo?

Nope.
Wat je kan doen in onderstaande regel veranderen van..

.HTMLBody = RangetoHTML(rng) & vbNewLine & RangetoHTML(rng1)

...in ...

.HTMLBody = RangetoHTML(rng1)

(Dit is uitsluitend om te kijken of Export nu wel geselecteerd wordt.)
...en vervolgens in...

.HTMLBody = RangetoHTML(rng1) & vbNewLine & RangetoHTML(rng)

(Nu om te kijken of Export en vervolgens Sjabloon geselecteerd wordt.)

Met vriendelijke groet,


Roncancio