Macro to attach numerous pdf files and email via lotus notes

[STEVEOB]

Hi,

I was wandering if anyone out there can help.
I have a folder (Z\statements\pdf's\) where i will have numerous pdf's stored.
The file names of these pdf's will be an email address.
So a file name could be: joebloggs@test.com.pdf , haroldbloggs@test.com.pdf etc...

What i need to do is to be able to extract the file name excluding the .pdf extension and attach this name as the email address and the actual pdf attachment in one email.
So i would have joebloggs@test.com as the email address and within the email i would have the pdf file as well.
Can a macro be created to do this?

I know how to create a macro and email the attachment but only when the email address is hard coded in the macro itself.


Thanks

Steve

[Charlize]

Don't promise a thing, but try this one (couldn't test this because I haven't got Lotus Notes). Step through it with F8 to locate possible problems that could arise.
Dim lErr As Double
Sub Mail_Pdf_with_Lotus()
Dim MyPath As String, MyName As String
MyPath = "C:\Data\pdf to mail\" ' Set the path.
MyName = Dir(MyPath) ' Retrieve the first entry.
Do While MyName <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If MyName <> "." And MyName <> ".." Then
' Use bitwise comparison to make sure MyName is a directory.
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
' We don't do a thing if it's a subdirectory
Else
' Send an email
SendNotesMail "Info for your account : " & Mid(MyName, 1, Len(MyName) - 4), _
MyPath & MyName, Mid(MyName, 1, Len(MyName) - 4), _
"Info for your account : " & Mid(MyName, 1, Len(MyName) - 4), True, lErr
End If
End If
'Go to next file
MyName = Dir ' Get next entry.
Loop
End Sub
Public Sub SendNotesMail(Subject As String, Attachment As String, _
ByVal Recipient As String, _
BodyText As String, _
SaveIt As Boolean, _
ByRef lErr As Double)
'lErr is used when using the Sub in a batch process,
'to handle instances where an error appears

'Example of use:
'SendNotesMail "The Subject", "C:\My Documents\TestFile.txt", _
"john@doe.com, jane@doe.com", _
"This is the body text, can be longer", True, lErr

'Set up the objects required for Automation into lotus notes
Dim Maildb As Object 'The mail database
Dim UserName As String 'The current users notes name
Dim MailDoc As Object 'The mail document itself
Dim AttachME As Object 'The attachment richtextfile object
Dim Session As Object 'The notes session
Dim EmbedObj As Object 'The embedded object (Attachment)
Dim ArRecipients() As String 'Array of recipients
Dim i As Long 'Counter
'Create an array of recipients (Separated by commas)
Recipient = Recipient & ","
While InStr(1, Recipient, ",", 1) > 0
i = i + 1
ReDim Preserve ArRecipients(1 To i) As String
ArRecipients(i) = _
Left(Recipient, InStr(1, Recipient, ",", 1) - 1)
Recipient = _
Mid(Recipient, InStr(1, Recipient, ",", 1) + 1, Len(Recipient))
Wend
'Start a session to notes
Set Session = CreateObject("Notes.NotesSession")
On Error GoTo err_h
'Open the mail database in notes
Set Maildb = Session.GETDATABASE("", "mail\username.nsf")
If Maildb.IsOpen = False Then
Maildb.OPENMAIL
End If
'Set up the new mail document
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
MailDoc.sendto = ArRecipients
MailDoc.Subject = UCase(Subject)
MailDoc.Body = UCase(BodyText)
'This is supposed to be the property, but works
'on some systems only
'without an apparent reason of failure
MailDoc.SAVEMESSAGEONSEND = SaveIt
'Set up the embedded object and attachment and attach it
If Attachment <> "" Then
Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment")
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment, "Attachment")
MailDoc.CREATERICHTEXTITEM ("Attachment")
End If
'Send the document
MailDoc.PostedDate = Now() 'Gets the mail to appear in the sent items folder
MailDoc.Send 0
MailDoc.Save True, True, False
'Clean Up
err_h:
lErr = Err.Number
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing
End Sub

[STEVEOB]

Thanks Charlize.
There is a problem though in that it does not create the emails.
I tried closing down notes and running the macro.
It opens up notes o.k. however does not create the emails.
Tried playing around with the maildoc send and change "memo" to "new memo" still nothing.

Driving me nuts!

[Charlize]

After some digging into my archive boxes, I found a copy of Lotus Notes R5 (A little old, I know ...). Setting it up for my private stand alone pop mail account and smtp server of mine internet provider. Seems to me it works fine. Mail item is created with attachment and placed in sent items. The only thing I'm not certain of, is the following : should I, after sending all the items, manually send all items with the replicator or is this done automatically.

Attached the file I used (removed the errorchecking variable in sub sendnotes).

Charlize

[STEVEOB]

Thanks again.
But still no luck on my side.
Must be my lotus notes version i am on 6.5.2
If i insert:
Activeworkbook.sendmail ArRecipients
before section:
'Set up the new mail document
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "NewMemo"
MailDoc.sendto = ArRecipients
MailDoc.Subject = UCase(Subject)
MailDoc.Body = UCase(BodyText)

this at least opens up two new mail messages ( as i have two pdfs) in notes but only attaches the current workbook (macro) in the email and not the pdf's.

Can you think of a way around this?

Thanks

[Charlize]

What about this one. Make a pdf with your email adress to test because you will not have a sent item. This one uses the cdo method. Hope this will work ?
Sub Mail_PDF_with_CDO()
Dim iMsg As Object
Dim iConf As Object
Dim MyPath As String, MyName As String

'Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

'If you get an error with the sending argument you have to remove the ' of
'Dim Flds As Variant and the coding between the ***
'************
'iConf.Load -1 ' CDO Source Defaults
'Set Flds = iConf.Fields
'With Flds
' .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = _
' "exchange network server name"
' .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
' .Update
'End With
'************
MyPath = "C:\Data\pdf to mail\" ' Set the path.
MyName = Dir(MyPath) ' Retrieve the first entry.

Do While MyName <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If MyName <> "." And MyName <> ".." Then
' Use bitwise comparison to make sure MyName is a directory.
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
' We don't do a thing if it's a subdirectory
Else
' Send an email
With iMsg
Set .Configuration = iConf
.To = Mid(MyName, 1, Len(MyName) - 4)
.From = """Charlize"" <myadress@postbox.com (myadress@postbox.com)>"
.Subject = "Info for your account : " & Mid(MyName, 1, Len(MyName) - 4)
'Don't remove TextBody. The attachments can not be opened when received.
'Bug in CDO
.TextBody = ""
.addattachment MyPath & MyName
.Send
End With
End If
End If
'If you want to delete the file you send remove ' of the next line
'Kill MyPath & MyName
'Go to next file to process
MyName = Dir ' Get next entry.
Loop
Set iMsg = Nothing
Set iConf = Nothing
End Sub

ps.: take a look at the site http://www.rondebruin.nl/cdo.htm for further info. Very usefull stuff there.

Charlize

[STEVEOB]

Thanks.
I believe i have it now. Just amended the array a little bit.
I attach the code.
Many thanks for you help with this, been invaluable.
Owe you one.



Option Explicit
Dim lErr As Double
Sub Mail_Pdf_with_Lotus()
Dim MyPath As String
Dim MyName As String
Dim sSubject As String
Dim sAttachment As String
Dim sRecipient As String
Dim sBodyText As String

MyPath = "J:\path\name\" ' Set the path.
MyName = Dir(MyPath) ' Retrieve the first entry.
Do While MyName <> "" ' Start the loop.
' Ignore the current directory and the encompassing directory.
If MyName <> "." And MyName <> ".." Then

' Use bitwise comparison to make sure MyName is a directory.
If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
' We don't do a thing if it's a subdirectory
Else
' Send an email
sSubject = "Info for your account : " & Mid(MyName, 1, Len(MyName) - 4)
sAttachment = MyPath & MyName
sRecipient = Mid(MyName, 1, Len(MyName) - 4)
sBodyText = "Dear Sir...."

SendNotesMail sSubject, sAttachment, sRecipient, sBodyText, True
End If

End If

'Go to next file
MyName = Dir

Loop
MsgBox "Mails are sent ...", vbInformation
End Sub
Public Sub SendNotesMail(Subject As String, Attachment As String, Recipient As String, BodyText As String, SaveIt As Boolean)
'Set up the objects required for Automation into lotus notes
Dim Maildb As Object 'The mail database
Dim UserName As String 'The current users notes name
Dim MailDbName As String 'THe current users notes mail database name
Dim MailDoc As Object 'The mail document itself
Dim AttachME As Object 'The attachment richtextfile object
Dim Session As Object 'The notes session
Dim EmbedObj As Object 'The embedded object (Attachment)

'Start a session to notes
Set Session = CreateObject("Notes.NotesSession")

'Get the sessions username and then calculate the mail file name
'You may or may not need this as for MailDBname with some systems you
'can pass an empty string
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"

'Open the mail database in notes
Set Maildb = Session.GETDATABASE("", MailDbName)

If Maildb.IsOpen = True Then
'Already open for mail
Else
Maildb.OPENMAIL
End If

'Set up the new mail document
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
MailDoc.sendto = Recipient
MailDoc.CopyTo = ""
MailDoc.BlindCopyTo = ""
MailDoc.Subject = Subject
MailDoc.Body = BodyText
MailDoc.SAVEMESSAGEONSEND = SaveIt

'Set up the embedded object and attachment and attach it
If Attachment <> "" Then
Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment")
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment, "Attachment")
End If

'Send the document
MailDoc.PostedDate = Now() 'Gets the mail to appear in the sent items folder
MailDoc.SEND 0, Recipient

'Clean Up
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing

'************************************************************************** ****
'NB heres how to send to multiple recipients -
'set MailDoc.sendto to an array of variants each of which will receive the message
'Dim recip(25) as variant
'recip(0) = "emailaddress1"
'recip(1) = "emailaddress2" e.t.c
'MailDoc.sendto = recip
'************************************************************************** ****
End Sub