Macro to input a Range of Cells & Their Formatting Into a Message?

[jtwusmc]

I am using the Macro below to generate emails for me via Lotus Notes. It is working perfectly. There is only 1 function I need to add and this is having the macro copy a range of cells into the message also.

I will need all the formatting (colors, row size, dates, times... Just like I copy and pasted the cells into Lotus manually). The range of cells is B8:Z27 and it will have to string restarting every 23 rows (i.e. the second range is B32:Z51).

Thank you for your help ahead of time!

Sub SendNotesMail()
Dim Email As String, Subj As String, Msg As String
Dim r As Integer, x As Double
Dim Maildb As Object, UserName As String, MailDbName As String, DomDbName As String
Dim stFileName As String
Dim MailDoc As Object, Session As Object
 
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = "mail\" & Mid$(UserName, 4, InStr(1, UserName, " ") - 4) & Mid$(UserName, _
    InStr(1, UserName, " ") + 1, InStr(1, UserName, "/") - InStr(1, UserName, " ") - 1) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
    Else: Maildb.OPENMAIL
End If
    For r = 6 To Range("AF65536").End(xlUp).Row
Set MailDoc = Maildb.CreateDocument
MailDoc.Form = "Memo"
Email = Range("af" & r)
Subj = Range("aj" & r)
 Msg = ""
        Msg = Msg & Range("ak" & r) & "," & vbCrLf & vbCrLf
        Msg = Msg & Range("ai" & r) & "." & vbCrLf & vbCrLf
        Msg = Msg & "Thank you," & vbCrLf
        Msg = Msg & "AMW"
MailDoc.sendto = Email
'MailDoc.CopyTo = Whomever
'MailDoc.BlindCopyTo = Whomever
MailDoc.Subject = Subj
MailDoc.Body = Msg
MailDoc.SaveMessageOnSend = True
Set workspace = CreateObject("Notes.NotesUIWorkspace")
Call workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
r = r + 23
Next r
 MsgBox ("The e-mails have successfully been distributed."), vbInformation
Set Maildb = Nothing:    Set MailDoc = Nothing:    Set Session = Nothing
Exit Sub
Error_Handling:
Set Maildb = Nothing:    Set MailDoc = Nothing:    Set Session = Nothing
End Sub

 

[jtwusmc]

Any ideas on getting this to copy a range of cells into the email?

 

[VoG]

This might help you http://www.rondebruin.nl/notes6.htm

 

[jtwusmc]

This might help you http://www.rondebruin.nl/notes6.htm

I wasn't able to decipher what they were doing in relation to my code. I did a search however and found something that I think is close...

 Msg = Msg & Range("ak" & r) & "," & vbCrLf & vbCrLf
        Msg = Msg & Range("ai" & r) & "." & vbCrLf & vbCrLf
        [COLOR=red]Msg = Msg & Range("b8:w27").Select
            Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
        Msg = Msg & ActiveSheet.Paste

[/COLOR]

Can't quite get this code to work, but it looks like it is close. Suggestions?