Here is the code that I use. I had to change a few things before I could post it, so please report back any problems.
Put the Declare Function statement at the top of the module, after the Option Explicit (if used) and before any other routines.
The code will prompt you to enter the e-mail addresses of the recipients, separated by a comma, although that can be changed to looping through a list on a worksheet, for example.
I have this set up to send to up to 14-15 recipients (including groups). I originally had the code read the mailing list into an array, but the "mail to" wouldn't read the whole array correctly, so I forced it into an If-Then-Else structure.
Note, this code saves the workbook with a concatenation of three cells on the sheet (active sheet I believe, as my program copies one sheet from a file to a new workbook). Please change that to suit your requirements (where I set strfilename to the value of 3 cells in the sheet).
Finally, the workbook also mails to the user's login name. If you are not on a network, then be careful there, although I don't know any people who have Lotus Notes on their home computer.
------------------------------
Private Declare Function apiGetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nsize As Long) As Long
Private Sub mail_report()
Dim strfilename As String
Dim mail_list As String, x As Integer
Dim Position() As Integer
Dim NameList() As String
Dim strNameCt As Integer
' be sure to reference the Lotus Domino Objects, domobj.tlb
Dim objNotesSession As Object
Dim objNotesDatabase As Object
Dim objNotesDocument As Object
Dim objAttachment As Object
Dim objRichText As Object
Dim FullPath As String
Dim FileName As String
Dim Msg As String
Const EMBED_ATTACHMENT = 1454
Set objNotesSession = CreateObject("Notes.Notessession")
Set objNotesDatabase = objNotesSession.GetDatabase("", "")
Call objNotesDatabase.OpenMail 'default mail database
If objNotesDatabase.IsOpen = False Then
MsgBox "Cannot connect to Lotus Notes."
Exit Sub
End If
Set objNotesDocument = objNotesDatabase.CreateDocument
Call objNotesDocument.ReplaceItemValue("Form", "Memo")
mail_list = Application.InputBox("Enter the e-mail address of your" & vbCr & "recipient(s)." & vbCr & vbCr & "For multiple recipients, please separate" & vbCr & "the e-mail addresses with a comma.", "Send file")
If IsEmpty(mail_list) Then Exit Sub
If mail_list = "" Then Exit Sub
If mail_list = "False" Then Exit Sub
Msg = Application.InputBox("Enter a brief message (not required)" & vbCr & "to be added to the message text.", "Add a cheerful greeting!")
If Msg = "False" Then Msg = ""
strNameCt = Len(mail_list) - Len(WorksheetFunction.Substitute(mail_list, ",", "")) + 1
Application.ScreenUpdating = False
ChDrive "C"
ChDir "C:Excel"
If strNameCt = 1 Then GoTo Send_The_File
ReDim Position(1 To strNameCt - 1)
For x = 1 To strNameCt - 1
If x = 1 Then
Position(x) = WorksheetFunction.Search(",", mail_list, 1)
Else
Position(x) = WorksheetFunction.Search(",", mail_list, Position(x - 1) + 1)
End If
Next x
ReDim NameList(1 To strNameCt)
For x = 1 To strNameCt
If x = 1 Then
NameList(x) = Left(mail_list, Position(x) - 1)
ElseIf x = strNameCt Then
NameList(x) = Right(mail_list, Len(mail_list) - Position(x - 1) - 1)
Else
NameList(x) = Mid(mail_list, Position(x - 1) + 1, Position(x) - Position(x - 1) - 1)
End If
Next x
Send_The_File:
Application.DisplayAlerts = False
With ActiveWorkbook
Range("A1").Select
strfilename = Cells(1, 3) & " " & Cells(2, 3) & " " & Cells(3, 3).Text
.SaveAs FileName:=strfilename
End With
Application.DisplayAlerts = True
' assemble message
Set objRichText = objNotesDocument.CreateRichTextItem("Body")
Set objAttachment = objRichText.EmbedObject(EMBED_ATTACHMENT, "", ActiveWorkbook.FullName, strfilename)
Msg = Msg & vbCr & vbCr & "Report sent by " & objNotesSession.CommonUserName
With objNotesDocument
.Subject = strfilename
.Body = Msg
If strNameCt = 1 Then
.SendTo = Array(mail_list, fOSUserName)
ElseIf strNameCt = 2 Then
.SendTo = Array(NameList(1), NameList(2), fOSUserName)
ElseIf strNameCt = 3 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), fOSUserName)
ElseIf strNameCt = 4 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), fOSUserName)
ElseIf strNameCt = 5 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), fOSUserName)
ElseIf strNameCt = 6 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), fOSUserName)
ElseIf strNameCt = 7 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), fOSUserName)
ElseIf strNameCt = 8 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), NameList(8), fOSUserName)
ElseIf strNameCt = 9 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), fOSUserName)
ElseIf strNameCt = 10 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), NameList(10), fOSUserName)
ElseIf strNameCt = 11 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), NameList(10), NameList(11), fOSUserName)
ElseIf strNameCt = 12 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), _
NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), _
NameList(10), NameList(11), NameList(12), fOSUserName)
ElseIf strNameCt = 13 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), _
NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), _
NameList(10), NameList(11), NameList(12), NameList(13), fOSUserName)
ElseIf strNameCt = 14 Then
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), _
NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), _
NameList(10), NameList(11), NameList(12), NameList(13), NameList(14), fOSUserName)
Else
.SendTo = Array(NameList(1), NameList(2), NameList(3), NameList(4), _
NameList(5), NameList(6), NameList(7), NameList(8), NameList(9), _
NameList(10), NameList(11), NameList(12), NameList(13), NameList(14), _
NameList(15), fOSUserName)
End If
.SaveMessageOnSend = True ' save in Sent folder
.Send (False)
End With
ActiveWorkbook.Close
End Sub
Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If lngX <> 0 Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = ""
End If
End Function
-----------------------
Bye,
Jay