Seleccionar el rango usado y enviar por Lotus Notes 9 como Imagen

Yo tengo lotus note 8.5, este codigo que pondre selecciona una hoja previamente guardada y la envia, lo unico es que hay que tener la sesion de lotus abierta, el resto el pregunta, el correo, asunto y el cuerpo del mensaje. Busca una forma de convertirla a imagen y cambias la parte donde se adjunta el archivo, ya que yo lo tengo para que muestre solo xslx xslm (archivos de excel). Espero te ayude

    Dim UserName As String
    Dim MailDbName As String
    Dim Recipient As String
    Dim ccRecipient As String
    Dim ans As String
    Dim Attachment1 As String
    Dim Maildb As Object
    Dim MailDoc As Object
    Dim AttachME As Object
    Dim Session As Object
    Dim EmbedObj1 As Object
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
      ' Abro y localizo la sesion actual del usario de LOTUS NOTES
 'para que el proceso funcione el usuario debio iniciar sesion con lotus note previamente
        Set Session = CreateObject("Notes.NotesSession")
            UserName = Session.UserName
        MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
        Set Maildb = Session.GetDatabase("", MailDbName)
        If Maildb.IsOpen = True Then
        Else
            Maildb.OPENMAIL
        End If
      ' Create New Mail and Address Title Handlers
        Set MailDoc = Maildb.CREATEDOCUMENT
        MailDoc.Form = "Memo"
        '  Select range of e-mail addresses
        Recipient = InputBox("Por favor inserte la direccion E-mail" _
                    , "Insertar Direccion E-mail")
        MailDoc.SendTo = Recipient
        ans = MsgBox("Le gustaria enviar una copia (cc) a alguien de este mensaje?" _
            , vbQuestion & vbYesNo, "Enviar Copia")
            If ans = vbYes Then
                ccRecipient = InputBox("Por favor inserte las direcciones recipientes adicionales" _
                    , "Insertar Direcciones E-mail")
                MailDoc.CopyTo = ccRecipient
            End If
        MailDoc.Subject = InputBox("Asunto" _
                    , "Insertar Asunto")
            MailDoc.Body = _
        "Nomina. Reporte su recibimiento  ."
    '  Select Workbook to Attach to E-Mail
        MailDoc.SaveMessageOnSend = True
            Attachment1 = Application.GetOpenFilename(Title:="Buscar Envio", _
                            filefilter:="Excel files (*.xlsx), *.xlsx")
            'ActiveWorkbook.Name '"C:\\YourFile.xls" '    Required File Name
        If Attachment1 <> "" Then
            'On Error Resume Next
                Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment1")
                Set EmbedObj1 = AttachME.embedobject(1454, "Attachment1", Attachment1, "") 'Required File Name 'AttachME.embedobject(1454, "", "Attachment1", Attachment1) 'Required File Name
            'On Error Resume Next
        End If
        MailDoc.PostedDate = Now()
            On Error GoTo errorhandler1
        MailDoc.SEND 0, Recipient
        Set Maildb = Nothing
            Set MailDoc = Nothing
                Set AttachME = Nothing
            Set Session = Nothing
        Set EmbedObj1 = Nothing
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
errorhandler1:
        Set Maildb = Nothing
            Set MailDoc = Nothing
                Set AttachME = Nothing
            Set Session = Nothing
        Set EmbedObj1 = Nothing