'The procedure for sending a workbook to recipients
Sub SendWorkbook()
Dim bcLotus As Office.CommandBarControl
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim obAttachment As Object, EmbedObject As Object
Dim stSubject2 As Variant, stAttachment2 As String
Dim vaRecipient2 As Variant, vaMsg2 As Variant, vaCopyTo2 As Variant
Dim signatureName As Variant, Recipients2 As Variant, CopyTo2 As Variant
Const EMBED_ATTACHMENT As Long = 1454
Const stTitle2 As String = "Status Active workbook"
Const stMsg2 As String = "The active workbook must first be saved " & vbCrLf _
& "before it can be sent as an attachment."
'Check if the active workbook is saved or not
'If the active workbook has not been saved at all.
If Len(ActiveWorkbook.path) = 0 Then
MsgBox stMsg2, vbInformation, stTitle2
Exit Sub
End If
'If the changes in the active workbook has been saved or not.
If ActiveWorkbook.Saved = False Then
If MsgBox("Do you want to save the changes before sending?", vbYesNo + vbInformation, stTitle2) = vbYes Then ActiveWorkbook.Save
End If
'Get the name of the recipient from the user.
Do
Recipients2 = Application.InputBox( _
Prompt:="Please add the name of the recipient such as:" & vbCrLf _
& "excel@microsoft.com or just the name if it's internally. (Cannot use just name if you have more than one recipient!)" & vbCrLf _
& "You will be asked for a Copy To next.", Title:="Recipient", Type:=2)
Loop While Recipients2 = ""
'If the user has canceled the operation.
If Recipients2 = False Then Exit Sub
CopyTo2 = Application.InputBox( _
Prompt:="Please add the name of any copy to recipients such as:" & vbCrLf _
& "excel@microsoft.com or just the name if it's internally. (Cannot use just name if you have more than one recipient!)" & vbCrLf _
& "A copy to recipient is optional.", Title:="Recipient", Type:=2)
'Add the subject to the outgoing e-mail.
'Get the subject from the user.
Do
stSubject2 = Application.InputBox( _
Prompt:="Please enter the subject of the message such as:" & vbCrLf _
& "Weekly Reports", Title:="Subject", Type:=2)
Loop While stSubject2 = ""
'If the user has canceled the operation.
If stSubject2 = False Then Exit Sub
'Get the message from the user.
Do
vaMsg2 = Application.InputBox( _
Prompt:="Please enter the message such as:" & vbCrLf _
& "Enclosed please find the weekly report.", _
Title:="Message", Type:=2)
Loop While vaMsg2 = ""
'If the user has canceled the operation.
If vaMsg2 = False Then Exit Sub
'Get the signature from the user.
Do
signatureName = Application.InputBox( _
Prompt:="Please enter your name for the signature such as:" & vbCrLf _
& "John Doe", _
Title:="Message", Type:=2)
Loop While signatureName = ""
'If the user has canceled the operation.
If signatureName = False Then Exit Sub
'Retrieve the path and filename of the active workbook.
stAttachment2 = ActiveWorkbook.FullName
'Create the list of recipients.
vaRecipient2 = VBA.Array(Recipients2)
vaCopyTo2 = VBA.Array(CopyTo2)
'Instantiate the Lotus Notes COM's Objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'If Lotus Notes is not open then open the mail-part of it.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the e-mail and the attachment.
Set noDocument = noDatabase.CreateDocument
Set obAttachment = noDocument.CreateRichTextItem("stAttachment2")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment2)
'Add values to the created e-mail main properties and sends e-mail.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient2
.CopyTo = vaCopyTo2
.Subject = stSubject2
.Body = vaMsg2 & vbCrLf & vbCrLf & "Thanks," & vbCrLf & vbCrLf & signatureName & vbCrLf & vbCrLf
.SaveMessageOnSend = True
.PostedDate = Now()
.Send 0, vaRecipient2
End With
'Release objects from the memory.
Set EmbedObject = Nothing
Set obAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
AppActivate "Microsoft Excel"
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub