Excel adjuntar distintos ficheros a lotus

Esto que solicito no es una reparacion de una
macro, ni
una mejora, ni nada que se le parezca, en mi afan por aprender
he buscado y
extraido informacion de varios sitios y he enconseguido la
macro que adjunto,
pero que no termina de hacer lo que necesio.
Si lo ves conveniente puedes pasar de ella y mandarme otra que haga lo que
expongo y si no esta dentro de tus conocimientos te agradeceria que me indicases
de algun experto que me pueda ayudar, no obstante te adjunto otra vez la macro
ya que hace casi lo que necesito, le falta poder adjuntar los ficheros que yo le
ponga le ruta en las celdas de la culumna "D"
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 =...