Excel adjuntar ficheros en lotus

Buenos días, tengo un documento excel ( 2003) que coge de cada fila, el asunto
los destinatarios y el texto del mensaje y manda un lotus adjuntando el
propio fichero excel.
Necesito que en vez de adjuntar el propio
fichero adjunte otro fichero distinto, del cual pongo la ruta en la
columna "D", por ejemplo D:\Alberto\Mis documentos\claves.xls
Tener
en cuenta que debe mandar un correo por fila en la que la fecha indicada
en la columna A sea anterior al dia de hoy
Adjunto macro que
funciona perfectamente, solo hay que cambiar la parte en la que adjunta
el propio fichero por la nueva parte en la que adjuntaria el fichero de
la ruta que le indico en la fila en la columna D
Option Explicit 'Con
envio fichero
''Aunque no lo indique, pondremos en la columna F la
palabra enviado cuando''
''hayamos mandado el correo para evitar
duplicidades.''
Sub enviarCorreosyFichero()
ActiveSheet.Unprotect
"Envios"
On Error GoTo 0
Dim i As Long
Dim n As Integer
Dim
fechaHoy As Date
fechaHoy = DateSerial(Year(Now()), Month(Now()),
Day(Now()))
n = 0
For i = 1 To
Sheets("envios").Cells.SpecialCells(xlCellTypeLastCell).Row
If
Sheets("envios").Cells(i, 2) <> "" And Sheets("envios").Cells(i,
2) <= fechaHoy Then enviarCorreoLinea2 i, n
Next i
If n = 0
Then
' MsgBox "No se ha enviado ningún correo"
Else
'MsgBox
Format$(n) & " Correos enviados"
End If
BuscaCeldaColor
ActiveSheet.Protect
"Envios", DrawingObjects:=True, Contents:=True, Scenarios:=True _
,
AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True,
AllowSorting:=True
Ocultar_Envio
End Sub
Sub
enviarCorreoLinea2(ByVal nLin As Long, ByRef n As Integer)
Dim ojbOLK
As Object
Dim objMsg As Object
Dim nErrores As Integer
Dim
snError As Boolean
Dim destinatarios As String
Dim aux As String
Dim
i As Integer
If UCase$(Sheets("envios").Cells(nLin, 6)) = "ENVIADO"
Then Exit Sub ''Ya está mandado''
Sheets("envios").Cells(nLin, 6) =
"Enviado" 'Modificado inicialmente mas abajo
''Tenemos que separar
las direcciones de correo que, en caso de haber más de una,''
''estarán
separadas por el carácter coma "," o punto y coma ";" (da igual)''
destinatarios
= Trim$(Sheets("envios").Cells(nLin, 5))
nErrores = 0
aux = ""
For
i = 1 To Len(destinatarios)
If Mid$(destinatarios, i, 1) = "," Or
Mid$(destinatarios, i, 1) = ";" Then
If Trim$(aux) <> "" Then
''Tenemos que mandar el correo''
''Para adjuntar fichero''
'ThisWorkbook.Save
SendNotesMail2
Sheets("envios").Cells(nLin, 3), ThisWorkbook.Path & "\" &
ThisWorkbook.Name, Trim$(aux), Sheets("envios").Cells(nLin, 4), False,
snError
If snError Then nErrores = nErrores + 1 Else n = n + 1
End
If
aux = ""
Else
aux = aux & Mid$(destinatarios, i, 1)
End
If
Next i
If Trim$(aux) <> "" Then ''Tenemos que mandar el
correo''
'
ThisWorkbook.Save
SendNotesMail2
Sheets("envios").Cells(nLin, 3), ThisWorkbook.Path & "\" &
ThisWorkbook.Name, Trim$(aux), Sheets("envios").Cells(nLin, 4), False,
snError
If snError Then nErrores = nErrores + 1 Else n = n + 1
End
If
'Sheets("envios").Cells(nLin, 6) = "Enviado"
If nErrores > 0
Then
Sheets("envios").Cells(nLin, 6).Font.ColorIndex = 3
Sheets("envios").Cells(nLin,
6).Font.Bold = True
End If
End Sub
Public Sub
SendNotesMail2(ByVal Subject As String, ByVal attachment As String,
ByVal recipient As String, ByVal bodytext As String, ByVal saveit As
Boolean, ByRef snError As Boolean)
''Configure los objetos necesarios
para la automatización en Lotus Notes''
Dim Maildb As Object ''La
base de datos de correo''
Dim UserName As String ''Los usuarios
actuales de toma nombre''
Dim MailDbName As String ''Los usuarios
actuales de toma nombre de la base de correo electrónico''
Dim
MailDoc As Object ''El documento electrónico en sí''
Dim AttachME As
Object ''La inserción de objetos richtextfile''
Dim Session As Object
''Las notas de la sesión''
Dim EmbedObj As Object ''El objeto
incrustado (Anexo)''
''Para que no nos de errores''
On Error
Resume Next
''Start a session to notes''
Set Session =
CreateObject("Notes.NotesSession")
''Obtener el nombre de
usuario,períodos de sesiones y luego calcular el nombre de archivo de
correo''
''Usted puede o no necesitar esta como para MailDBname con
algunos sistemas que''
''puede pasar una cadena vacía''
UserName =
Session.UserName
MailDbName = Left(UserName, 1) &
Right(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
''Abrir
la base de datos de correo electrónico en notes''
Set Maildb =
Session.GETDATABASE("", MailDbName)
If Not Maildb.IsOpen = True Then
Maildb.OPENMAIL
''Configure el documento por correo electrónico
nuevo''
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
MailDoc.sendto
= recipient
MailDoc.Subject = Subject
MailDoc.Body = bodytext
MailDoc.SAVEMESSAGEONSEND
= saveit
''Configure el objeto incrustado y adjuntarlo''
If
attachment <> "" Then
Set AttachME =
MailDoc.CreateRichTextItem("")
Set EmbedObj =
AttachME.EmbedObject(1454, "", attachment, "Attachment")
'MailDoc.CreateRichTextItem
("Attachment")
End If
''Enviar el documento''
MailDoc.PostedDate
= Now() 'Gets the mail to appear in the sent items folder
MailDoc.SEND
0, recipient
'============================================================
''Si
hay algún error lo comentamos''
If Err <> 0 Then
''para que
no salga error desactivamos Msgbox, sale si no esta abierto Lotus
Notes''
'MsgBox "Error al enviar el correo. El mensaje del sistema
es:" & _
vbCrLf & vbCrLf & Error$
snError = True
Else
If
UserName = "" Then
snError = True
Else
snError = False
End
If
End If
'===============================================================
''Dejamos
que el sistema de sus propios errores''
On Error GoTo 0
'Clean Up
Set
Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set
Session = Nothing
Set EmbedObj = Nothing
End Sub
Un saludo y
muchas gracias