I have a macro which sends an email to recipients automatically from Excel VBA, I have different columns in my Excel file such as "recipient email address" and "cc", my macro will retrieve data from worksheet and then format accordingly. Now I need to add a "CC" field with two email addresses to my email format and I couldn't figure out how to do that, can anyone help me with that?
Here's how my worksheet looks like:
Here's the entire code for macro:
Sub Send_Unformatted_Rangedata(i As Integer)
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Dim rngGen As Range
Dim rngApp As Range
Dim rngspc As Range
y:
Dim stSubject As String
stSubject = "Change Request " + (Sheets("Summary").Cells(i, "AA").Value) + (Sheets("Summary").Cells(i, "AB").Value) + (Sheets("Summary").Cells(i, "AC").Value) + (Sheets("Summary").Cells(i, "AD").Value) + (Sheets("Summary").Cells(i, "AE").Value) + (Sheets("Summary").Cells(i, "AF").Value) + (Sheets("Summary").Cells(i, "AG").Value) + (Sheets("Summary").Cells(i, "AH").Value) + (Sheets("Summary").Cells(i, "AI").Value)
'Const stMsg As String = "Data as part of the e-mail's body."
'Const stPrompt As String = "Please select the range:"
'This is one technique to send an e-mail to many recipients but for larger
'number of recipients it's more convenient to read the recipient-list from
'a range in the workbook.
vaRecipient = VBA.Array(Sheets("Summary").Cells(i, "U").Value, Sheets("Summary").Cells(i, "V").Value)
On Error Resume Next
'Set rnBody = Application.InputBox(Prompt:=stPrompt, _
Default:=Selection.Address, Type:=8)
'The user canceled the operation.
'If rnBody Is Nothing Then Exit Sub
Set rngGen = Nothing
'Set rngApp = Nothing
'Set rngspc = Nothing
Set rngGen = Sheets("General Overview").Range("A1:C30").SpecialCells(xlCellTypeVisible)
'Set rngApp = Sheets("Application").Range("A1:E13").SpecialCells(xlCellTypeVisible)
'Set rngspc = Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "Q").Value).SpecialCells(xlCellTypeVisible)
'Set rngspc = Union(rngspc, Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "R").Value).SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If rngGen Is Nothing And rngApp Is Nothing And rngspc Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
'The clipboard will get replaced by the multiple copies.
'rngApp.Copy
'rngspc.Copy
rngGen.Copy
'To be able to see the email and manually send it add this below
'Call oUIDoc.Save(True, False, False)
'CreateObject("Notes.NotesUIWorkspace").EDITDOCUMENT True, oUIDoc
'AppActivate "> " & oUIDoc.Subject
'Retrieve the data from then copied range.
Set Data = New DataObject
Data.GetFromClipboard
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
.Body = Data.GetText & " " & stMsg
.SAVEMESSAGEONSEND = True
End With
'Send the e-mail.
'changed by Xu Ying to make the email being sent from automatically to manually
Dim uiMemo As Object
Dim ws As Object
Set ws = CreateObject("Notes.NotesUIWorkspace")
noDocument.Save True, True, False
Set uiMemo = ws.EDITDOCUMENT(True, noDocument)
'Release objects from memory.
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
'AppActivate "Excel"
'Empty the clipboard.
Application.CutCopyMode = False
i = i + 1
If Sheets("Summary").Cells(i, "U").Value <> "" Then
GoTo y:
End If
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub
Sub Send_Formatted_Range_Data(i As Integer)
Dim oWorkSpace As Object, oUIDoc As Object
Dim rnBody As Range
Dim lnRetVal As Long
Dim stTo As String
Dim stSubject As String
Const stMsg As String = "An e-mail has been succesfully created and saved."
Dim rngGen As Range
Dim rngApp As Range
Dim rngspc As Range
stTo = Sheets("Summary").Cells(i, "U").Value
stSubject = "E-Mail For Approval for " + (Sheets("Summary").Cells(i, "A").Value) + " for the Project " + Replace(ActiveWorkbook.Name, ".xls", "")
'Check if Lotus Notes is open or not.
lnRetVal = FindWindow("NOTES", vbNullString)
If lnRetVal = 0 Then
MsgBox "Please make sure that Lotus Notes is open!", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False
Set rngGen = Sheets("General Overview").Range("A1:C30").SpecialCells(xlCellTypeVisible)
Set rngApp = Sheets("Application").Range("A1:E13").SpecialCells(xlCellTypeVisible)
Set rngspc = Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "Q").Value).SpecialCells(xlCellTypeVisible)
Set rngspc = Union(rngspc, Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "R").Value).SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If rngGen Is Nothing And rngApp Is Nothing And rngspc Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
rngGen.Copy
rngApp.Copy
rngspc.Copy
'Instantiate the Lotus Notes COM's objects.
Set oWorkSpace = CreateObject("Notes.NotesUIWorkspace")
On Error Resume Next
Set oUIDoc = oWorkSpace.ComposeDocument("", "mail\xldennis.nsf", "Memo")
On Error GoTo 0
Set oUIDoc = oWorkSpace.CurrentDocument
'Using LotusScript to create the e-mail.
Call oUIDoc.FieldSetText("EnterSendTo", stTo)
Call oUIDoc.FieldSetText("EnterCopyTo", stCC)
Call oUIDoc.FieldSetText("Subject", stSubject)
'The can be used if You want to add a message into the created document.
Call oUIDoc.FieldAppendText("Body", vbNewLine & stBody)
'Here the selected range is pasted into the body of the outgoing e-mail.
Call oUIDoc.GoToField("Body")
Call oUIDoc.Paste
'Save the created document.
Call oUIDoc.Save(True, False, False)
'If the e-mail also should be sent then add the following line.
'Call oUIDoc.Send(True)
'Release objects from memory.
Set oWorkSpace = Nothing
Set oUIDoc = Nothing
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox stMsg, vbInformation
'Activate Lotus Notes.
AppActivate ("Notes")
'Last edited Feb 11, 2015 by Peter Moncera
End Sub
Here's the way how I solved my own problem with the help from #Siddharth Rout
Firstly, I need to add Dim vaCC As Variant and cell position of email addresses for those I need to cc:
vaCC = VBA.Array(Sheets("Summary").Cells(i, "AA").Value, Sheets("Summary").Cells(i, "AB").Value, Sheets("Summary").Cells(i, "AC").Value)
Then add data to the mainproperties of the e-mail's document:
With noDocument
.CopyTo = vaCC
End With
At the last step, set Dim CopyTo As String
Hope this will be of any help to those in need.
Related
I have a Excel VBA (Send_Mail) to send emails thru Lotus Notes. It is working fine, however I need help in sending individual email to multiple people in one go.
In my excel sheet. Cell A7 downwards will be the email addresses that can go upto 200+ rows, B7 has the subject Line and Cell C7 has the body of email. (all of this is getting auto populated with a different macro). However my code (Send_Mail) is just sending one email to the address which is in cell A7. I need your help in sending mail to all the email address that are in Col A7 onwards with its respective subject (Col B) and mail body (col C)
Below is my code.
Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String
Sub Send_Mail()
Dim answer As Integer
answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")
If answer = vbNo Then
MsgBox "Please Open Notes and Try the Macro Again"
Exit Sub
Else
End If
Application.DisplayAlerts = False
Call Send
MsgBox "Mail Sent to " & (Range("L2").Value) & " " & "Recipents"
Application.DisplayAlerts = True
End Sub
Public Function Send()
SendEMail = True
Sheets("Main").Select
TOID = Range("A7").Value
CCID = ""
SUBJ = Range("B7").Value
'On Error GoTo ErrorMsg
Dim EmailList As Variant
Dim ws, uidoc, Session, db, uidb, NotesAttach, NotesDoc, objShell As Object
Dim RichTextBody, RichTextAttachment As Object
Dim server, mailfile, user, usersig As String
Dim SubjectTxt, MsgTxt As String
Set Session = CreateObject("Notes.NotesSession")
user = Session.UserName
usersig = Session.COMMONUSERNAME
mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
server = Session.GETENVIRONMENTSTRING("MailServer", True)
Set db = Session.GETDATABASE(server, mailfile)
If Not db.IsOpen Then
Call db.Open("", "")
Exit Function
End If
Set NotesDoc = db.CREATEDOCUMENT
With NotesDoc
.Form = "Memo"
.Subject = SUBJ 'The subject line in the email
.Principal = user
.sendto = TOID 'e-mail ID variable to identify whom email need to be sent
.CopyTo = CCID
End With
Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")
With NotesDoc
.COMPUTEWITHFORM False, False
End With
'==Now set the front end stuff
Set ws = CreateObject("Notes.NotesUIWorkspace")
If Not ws Is Nothing Then
Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)
If Not uidoc Is Nothing Then
If uidoc.EDITMODE Then
'Mail Body
Sheets("Main").Select
Range("C7").Select
Dim rnBody1 As Range
Set rnBody1 = Selection
rnBody1.CopyPicture
'rnBody1.Copy
Call uidoc.GOTOFIELD("Body")
Call uidoc.Paste
End If
End If
End If
Call uidoc.Send
Call uidoc.Close
'close connection to free memory
Set Session = Nothing
Set db = Nothing
Set NotesAttach = Nothing
Set NotesDoc = Nothing
Set uidoc = Nothing
Set ws = Nothing
Sheets("Main").Select
End Function
I am worried about confusing you with too much new detail and must profess i haven't tested the following code so please don't assume this will solve your problem outright.
The following gives you an idea of how you might use a loop as you requested. See example also here which covers instances where you might need to batch send (admittedly link is for Outlook) and is also an example of using a loop.
I have included some explanations along the way in the code. It is difficult without more information to properly tailor this but i hope it helps.
Option Explicit
Public TOID As String
Public CCID As String
Public SECT As String
Public ACCO As String
Public SUBJ As String
Public Sub Send_Mail()
Dim wb As Workbook
Dim ws1 As Worksheet
Set wb = ThisWorkbook 'These are assumptions
Set ws1 = wb.Worksheets("Sheet1") 'These are assumptions. You would change as necessary
Dim answer As Long 'Integer types changed to Long
answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES")
If answer = vbNo Then
MsgBox "Please Open Notes and Try the Macro Again"
Exit Sub
'Else 'Not being used so consider removing
End If
Application.DisplayAlerts = False
Dim lRow As Long
Dim loopRange As Range
Dim currentRow As Long
Dim TOIDvar As String
Dim SUBJvar As String
With ws1
lRow = .Range("A7").End(xlDown).Row 'Assume no gaps in column A in the TOID range
Set loopRange = .Range("A7:A" & lRow)
For currentRow = 1 To loopRange.Rows.Count 'Loop range assigning values to arguments and call send sub with args
TOIDvar = loopRange.Cells(currentRow, 1)
SUBJvar = loopRange.Cells(currentRow, 1).Offset(0, 1) ' get column B in same row using Offset
Send TOIDvar, SUBJvar
Next currentRow
End With
'Commented out MsgBox at present as unsure what you will do when sending multiple e-mails
'MsgBox "Mail Sent to " & (ws1.Range("L2").Value) & " " & "Recipents" 'use explicit fully qualified Range references
Application.DisplayAlerts = True
End Sub
Public Sub Send(ByVal TOIDvar As String, ByVal SUBJvar As String) 'changed to sub using arguments
Dim SendEMail As Boolean 'declare with type
Dim wb As Workbook
Dim ws2 As Worksheet
Set wb = ThisWorkbook 'These are assumptions. Ensuring you are working with correct workbook
Set ws2 = wb.Worksheets("Main")
SendEMail = True
TOID = TOIDvar
CCID = vbNullString 'use VBNullString rather than empty string literals
SUBJ = SUBJvar
'On Error GoTo ErrorMsg
Dim EmailList As Variant 'declaration of separate lines and with their types
Dim ws As Object
Dim uidoc As Object
Dim Session As Object
Dim db As Object
Dim uidb As Object
Dim NotesAttach As Object
Dim NotesDoc As Object
Dim objShell As Object
Dim RichTextBody As Object
Dim RichTextAttachment As Object
Dim server As String
Dim mailfile As String
Dim user As String
Dim usersig As String
Dim SubjectTxt As String
Dim MsgTxt As String
Set Session = CreateObject("Notes.NotesSession")
user = Session.UserName
usersig = Session.COMMONUSERNAME
mailfile = Session.GETENVIRONMENTSTRING("MailFile", True)
server = Session.GETENVIRONMENTSTRING("MailServer", True)
Set db = Session.GETDATABASE(server, mailfile)
If Not db.IsOpen Then
db.Open vbNullString, vbNullString
Exit Sub
End If
Set NotesDoc = db.CREATEDOCUMENT
With NotesDoc
.Form = "Memo"
.Subject = SUBJ 'The subject line in the email
.Principal = user
.sendto = TOID 'e-mail ID variable to identify whom email need to be sent
.CopyTo = CCID
End With
Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body")
With NotesDoc
.COMPUTEWITHFORM False, False
End With
'==Now set the front end stuff
Set ws = CreateObject("Notes.NotesUIWorkspace")
If Not ws Is Nothing Then
Set uidoc = ws.EDITDOCUMENT(True, NotesDoc)
If Not uidoc Is Nothing Then
If uidoc.EDITMODE Then
'Mail Body
With ws2.Range("C7")
Dim rnBody1 As Range
Set rnBody1 = .Value2
rnBody1.CopyPicture
'rnBody1.Copy
uidoc.GOTOFIELD "Body"
uidoc.Paste
End With
End If
End If
End If
uidoc.Send
uidoc.Close
'removed garbage collection
ws2.Activate ' swopped out .Select and used Worksheets collection held in variable ws2
End Sub
You may want to consider this.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
See this link for all details.
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
I am trying to get the personalized message working. I have difficulty in sending pictures and text while preserving the text formatting (bold, italic,...).
I read on a related subject on this website regarding a similar problem (Preserve text format when sending the content of a word document as the body of an email,). It helped me to get started.
Code I am using:
Sub emailmergewithattachments_2()
Dim Source As Document, Maillist As Document, wdDoc As Document
Dim Datarange As Range
Dim wdRange As Range
Dim i As Long, j As Long
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim Insp As Outlook.Inspector
Dim MySubject As String, Message As String, Title As String
'The source document is Word document that contains the personnalised
'letters sent to the recipients
Set Source = ActiveDocument
' Check if Outlook is running. If it is not, start Outlook
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
' Open the catalog mailmerge document
With Dialogs(wdDialogFileOpen)
.Show
End With
'The Maillist is a 2 column table containing the email adress and the second column
'contains the path and the name of the file to be joined with the email
Set Maillist = ActiveDocument
' Show an input box asking the user for the subject to be inserted into the email messages
Message = "Enter the subject to be used for each email message." ' Set prompt.
Title = " Email Subject Input" ' Set title.
' Display message, title
MySubject = InputBox(Message, Title)
' Iterate through the Sections of the Source document and the rows of the catalog mailmerge document,
' extracting the information to be included in each email.
For j = 1 To Source.Sections.Count - 1
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.Subject = MySubject 'subject line
'reading the first column of the maillist (the email)
Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
Datarange.End = Datarange.End - 1
.To = Datarange 'recipient's email
'joining the personalised attachements to each recipient
For i = 2 To Maillist.Tables(1).Columns.Count
Set Datarange = Maillist.Tables(1).Cell(j, i).Range
Datarange.End = Datarange.End - 1
.Attachments.Add Trim(Datarange.Text), olByValue, 1
Next i
'Obtain the Inspector for this Email
Set Insp = oItem.GetInspector
'Obtain the Word document for the Inspector
Set wdDoc = Insp.WordEditor
'Use the Range object to insert text
Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
wdRange.InsertAfter ("Text inserted") 'for testing only (to check if it really working)
'Word document containing the text and the images
Windows("lettres.docx").Activate
Selection.WholeStory
'*******************************************************************************
'Problematic part: trying to paste the selection into wdDoc while preserving the formatting
'and the entire content of the document of the file "lettres.docx"
'...missing code
'********************************************************************************
.Send
End With
Set oItem = Nothing
Next j
Maillist.Close wdDoNotSaveChanges
' Close Outlook if it was started by this macro.
If bStarted Then
oOutlookApp.Quit
End If
MsgBox Source.Sections.Count - 1 & " messages have been sent."
'Clean up
Set oOutlookApp = Nothing
End Sub
I took a different approach. I did a regular mail merge in MS Word and sent the mail in HTML format which keeps all the formatting and the graphics. Then in Outlook, i created a macro which adds the attachments when each email is sent. An Excel worksheet contains the path of files to be joined for each email.
==> important note: Outlook must be opened (application loaded) before sending the data from Word to Outlook or else the emails will likely get stuck in the outbox and as a result the macro will simply not work (emails will be sent but with no attachments)
Code in a ThisOutlookSession:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If Item.Class = olMail Then
Dim objCurrentMessage As MailItem
Set objCurrentMessage = Item
If UCase(objCurrentMessage.Subject) Like "PUBLIIDEM*" Then
On Error Resume Next
'Pour ajouter la même PJ à tous
Dim i As Long
i = 0
If publipostagePJ <> "" Then
While publipostagePJ(i) <> "fin"
objCurrentMessage.Attachments.Add Source:=publipostagePJ(i)
i = i + 1
Wend
End If
'On supprime le terme PUBLIIDEM du sujet
objCurrentMessage.Subject = Replace(objCurrentMessage.Subject, "PUBLIIDEM ", "")
ElseIf UCase(objCurrentMessage.Subject) Like "PUBLIPERSO*" Then
If Chemin = "" Then
Chemin = InputBox("Entrez le chemin d'accès et le nom du fichier:", "Envoies personnalisés")
On Error Resume Next
Set oExcelApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set oExcelApp = CreateObject("Excel.Application")
bStarted = True
End If
Workbooks.Open Chemin
Set oWB = Excel.ActiveWorkbook
oWB.Sheets("fichiers").Select
DerniereLigne = Cells(Rows.Count, 1).End(xlUp).Row
'DerniereColonne = Cells(1, Columns.Count).End(xlToLeft).Column
End If
For i = 1 To DerniereLigne
If Cells(i, 1) = objCurrentMessage.To Then
For j = 2 To 5
FichierJoin = Cells(i, j)
If Len(FichierJoin) > 0 Then objCurrentMessage.Attachments.Add Source:=FichierJoin
Next j
End If
Next i
'On supprime le terme PUBLIPERSO du sujet
objCurrentMessage.Subject = Replace(UCase(objCurrentMessage.Subject), "PUBLIPERSO ", "")
End If
Set objCurrentMessage = Nothing
End If
End Sub
Private Sub Application_Quit()
If bStarted Then
oExcelApp.Quit
End If
Set oExcelApp = Nothing
Set oWB = Nothing
End Sub
Code in a module
Public publipostagePJ As Variant
Public oExcelApp As Excel.Application
Public oWB As Excel.Workbook
Public DerniereLigne As Long
Public DerniereColonne As Long
Public bStarted As Boolean
Public FichierJoin, Chemin As String
Sub setPublipostage()
On Error Resume Next
If publipostagePJ(0) = "" Then publipostagePJ = Array("fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin", "fin")
While publipostagePJ(i) <> "fin"
contenu = contenu & vbCr & publipostagePJ(i)
i = i + 1
Wend
If contenu = "" Then contenu = "vide"
modifier = MsgBox(contenu & vbCr & "Voulez vous modifier les fichiers ?", vbYesNo, "Fichiers paramétrés")
If modifier = vbYes Then
For i = 0 To 9
If i > 0 Then encore = MsgBox("un autre ?", vbYesNo)
quest:
If encore <> vbNo Then
PJ = InputBox("Emplacement du fichier joint au PUBLIPOSTAGE?", _
"Paramétrage du PUBLIPOSTAGE pour la session", publipostagePJ(i))
If "" = Dir(PJ, vbNormal) Then GoTo quest
publipostagePJ(i) = PJ
Else: Exit For
End If
Next i
End If
MsgBox "Votre publipostage doit comporter le terme :" & vbCr & "PUBLIIDEM" & vbCr & "dans le sujet." & vbCr & "Celui-ci sera retiré lors de l'envoi"
End Sub
'This code is inside an module of a Workbook.
Sub Notes_Email_Excel_Cells2()
Application.WindowState = xlNormal
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim NUIdoc As Object
Dim WordApp As Object
Dim subject As String
Dim dd As String
Dim stAttachment As String
Dim obAttachment As Object, EmbedObject As Object
Const EMBED_ATTACHMENT As Long = 1454
Dim Wb As Workbook
Dim FirstCell As Range, LastCell As Range
Dim CC(1)
CC(1) = "yyy#itc.in,"
If bIsBookOpen("Daily Beetle Count Report - MMGR.xlsx") = True Then
Set Wb = Workbooks("Daily Beetle Count Report - MMGR.xlsx")
Else
Workbooks.Open ("B:\Sangeet\Daily Beetle Count Report - MMGR.xlsx")
Set Wb = Workbooks("Daily Beetle Count Report - MMGR.xlsx")
End If
Set NSession = CreateObject("Notes.NotesSession")
'Next line only works with 5.x and above. Replace password with your password
subject = "HOT SPOTS Infestation " & Now
Debug.Print subject
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
'Create a new Lotus Notes document
Set NDoc = NDatabase.CreateDocument
stAttachment = ActiveWorkbook.FullName
Set obAttachment = NDoc.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
With NDoc
.SendTo = "xxx#itc.in" 'CHANGE RECIPIENT EMAIL ADDRESS
.CopyTo = ""
.subject = subject
'Email body text, including marker text which will be replaced by the Excel cells
.body = "Dear All," & vbLf & vbLf & "Please find the Hotspot areas" & vbLf & vbLf & _
"**PASTE HERE**" & vbLf & vbLf & vbLf & vbLf & _
"Auto Generated Mail. Please Donot Reply."
.Save True, False
End With
'Edit the just-created document to copy and paste the Excel cells into it via Word
Set NUIdoc = NUIWorkSpace.EDITDocument(True, NDoc)
With NUIdoc
'Find the marker text in the Body item
.GotoField ("Body")
.FINDSTRING "**PASTE HERE**"
'.DESELECTALL 'Uncomment to leave the marker text in place (cells are inserted immediately before)
'Copy Excel cells to clipboard
Wb.Sheets("HOT SPOT").Activate
Sheets("HOT SPOT").Range("v2:w21").Copy 'CHANGE SHEET AND RANGE TO BE COPIED AND PASTED
'Create a temporary Word Document
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False 'True to aid debugging
WordApp.Documents.Add
'Paste into Word document and copy to clipboard
With WordApp.Selection
.PasteSpecial DataType:=10 'Enum WdPasteDataType: 10 = HTML; 2 = Text; 1 = RTF
.WholeStory
.Copy
End With
'Paste from clipboard (Word) to Lotus Notes document
.Paste
Application.CutCopyMode = False
WordApp.Quit SaveChanges:=False
Set WordApp = Nothing
.Send
.Close
End With
Set NSession = Nothing
If bIsBookOpen("Daily Beetle Count Report - MMGR.xlsx") Then
Workbooks("Daily Beetle Count Report - MMGR.xlsx").Close SaveChanges:=False
Else
End If
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
I'm writing a macro code to send email through IBM Lotus Notes, I'm able to send to customers, but with wrong content, I have saved the content of the email in worksheet "General Overview" at here:
Set rngGen = Sheets("General Overview").Range("A1:C30").SpecialCells(xlCellTypeVisible)
But it will auto send to one customer an email with wrong content like yes and no, I'm now clueless about this and will appreciate much for your help.
Here's the whole part:
Sub Send_Unformatted_Rangedata(i As Integer)
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Dim rngGen As Range
Dim rngApp As Range
Dim rngspc As Range
Dim stSubject As String
stSubject = "E-Mail For Approval for " + (Sheets("Summary").Cells(i, "A").Value) + " for the Project " + Replace(ActiveWorkbook.Name, ".xls", "")
'Const stMsg As String = "Data as part of the e-mail's body."
'Const stPrompt As String = "Please select the range:"
'This is one technique to send an e-mail to many recipients but for larger
'number of recipients it's more convenient to read the recipient-list from
'a range in the workbook.
vaRecipient = VBA.Array(Sheets("Summary").Cells(i, "U").Value, Sheets("Summary").Cells(i, "V").Value)
On Error Resume Next
'Set rnBody = Application.InputBox(Prompt:=stPrompt, _
Default:=Selection.Address, Type:=8)
'The user canceled the operation.
'If rnBody Is Nothing Then Exit Sub
Set rngGen = Nothing
Set rngApp = Nothing
Set rngspc = Nothing
Set rngGen = Sheets("General Overview").Range("A1:C30").SpecialCells(xlCellTypeVisible)
Set rngApp = Sheets("Application").Range("A1:E13").SpecialCells(xlCellTypeVisible)
Set rngspc = Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "Q").Value).SpecialCells(xlCellTypeVisible)
Set rngspc = Union(rngspc, Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "R").Value).SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If rngGen Is Nothing And rngApp Is Nothing And rngspc Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
rngGen.Copy
rngApp.Copy
rngspc.Copy
'Retrieve the data from then copied range.
Set Data = New DataObject
Data.GetFromClipboard
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
.Body = Data.GetText & " " & stMsg
.SaveMessageOnSend = True
End With
'Send the e-mail.
With noDocument
.PostedDate = Now()
.send 0, vaRecipient
End With
'Release objects from memory.
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
'Change Microsoft Excel to Excel
AppActivate "Excel"
'Empty the clipboard.
Application.CutCopyMode = False
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub
Sub Send_Formatted_Range_Data(i As Integer)
Dim oWorkSpace As Object, oUIDoc As Object
Dim rnBody As Range
Dim lnRetVal As Long
Dim stTo As String
Dim stCC As String
Dim stSubject As String
Const stMsg As String = "An e-mail has been succesfully created and saved."
Dim rngGen As Range
Dim rngApp As Range
Dim rngspc As Range
stTo = Sheets("Summary").Cells(i, "U").Value
stCC = Sheets("Summary").Cells(i, "V").Value
stSubject = "E-Mail For Approval for " + (Sheets("Summary").Cells(i, "A").Value) + " for the Project " + Replace(ActiveWorkbook.Name, ".xls", "")
'Check if Lotus Notes is open or not.
lnRetVal = FindWindow("NOTES", vbNullString)
If lnRetVal = 0 Then
MsgBox "Please make sure that Lotus Notes is open!", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False
Set rngGen = Sheets("General Overview").Range("A1:C30").SpecialCells(xlCellTypeVisible)
Set rngApp = Sheets("Application").Range("A1:E13").SpecialCells(xlCellTypeVisible)
Set rngspc = Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "Q").Value).SpecialCells(xlCellTypeVisible)
Set rngspc = Union(rngspc, Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "R").Value).SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If rngGen Is Nothing And rngApp Is Nothing And rngspc Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
rngGen.Copy
rngApp.Copy
rngspc.Copy
'Instantiate the Lotus Notes COM's objects.
Set oWorkSpace = CreateObject("Notes.NotesUIWorkspace")
On Error Resume Next
Set oUIDoc = oWorkSpace.ComposeDocument("", "mail\xldennis.nsf", "Memo")
On Error GoTo 0
Set oUIDoc = oWorkSpace.CurrentDocument
'Using LotusScript to create the e-mail.
Call oUIDoc.FieldSetText("EnterSendTo", stTo)
Call oUIDoc.FieldSetText("EnterCopyTo", stCC)
Call oUIDoc.FieldSetText("Subject", stSubject)
'If You experience any issues with the above three lines then replace it with:
'Call oUIDoc.FieldAppendText("EnterSendTo", stTo)
'Call oUIDoc.FieldAppendText("EnterCopyTo", stCC)
'Call oUIDoc.FieldAppendText("Subject", stSubject)
'The can be used if You want to add a message into the created document.
Call oUIDoc.FieldAppendText("Body", vbNewLine & stBody)
'Here the selected range is pasted into the body of the outgoing e-mail.
Call oUIDoc.GoToField("Body")
Call oUIDoc.Paste
'Save the created document.
Call oUIDoc.Save(True, False, False)
'If the e-mail also should be sent then add the following line.
'Call oUIDoc.Send(True)
'Release objects from memory.
Set oWorkSpace = Nothing
Set oUIDoc = Nothing
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox stMsg, vbInformation
'Activate Lotus Notes.
AppActivate ("Notes")
'Last edited Feb 11, 2015 by Peter Moncera
End Sub
The clipboard will get replaced by the multiple copies you do.
To be able to see the email and manually send it add this
CreateObject("Notes.NotesUIWorkspace").EDITDOCUMENT True, oUIDoc
AppActivate "> " & oUIDoc.subject
Below
Call oUIDoc.Save(True, False, False)
Cannot test to see if that will work correctly as no longer have lotus notes. But this is simular to what I used in my last job.
There's a command button as a trigger to send email to customers when you click on it. It will call the function first like this:
Private Sub Lotus2_Click()
ThisWorkbook.Send_Unformatted_Rangedata (2)
End Sub
Then there are two parts for the function in another sheet waiting to be called, I couldn't debug this since whenever I want to, the system only show me the line which calls the function. The problem is I know there's something wrong about calling function, but I'm not sure which part of the function goes wrong. I'm sorry as the function part is a bit tedious, as you can see below. I will truly appreciate a lot for any advice given, thanks.
*********UPDATE*******************
Hi, I just found something wrong with this line with the error message ofRun time error -2147417851 (80010105) Automation error The server threw an exception:
Set noDocument = noDatabase.CreateDocument
But I don't see anything wrong with it. Any help will be appreciated much.
Sub Send_Unformatted_Rangedata(i As Integer)
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Dim rngGen As Range
Dim rngApp As Range
Dim rngspc As Range
Dim stSubject As String
stSubject = "E-Mail For Approval for " + (Sheets("Summary").Cells(i, "A").Value) + " for the Project " + Replace(ActiveWorkbook.Name, ".xls", "")
'Const stMsg As String = "Data as part of the e-mail's body."
'Const stPrompt As String = "Please select the range:"
'This is one technique to send an e-mail to many recipients but for larger
'number of recipients it's more convenient to read the recipient-list from
'a range in the workbook.
vaRecipient = VBA.Array(Sheets("Summary").Cells(i, "U").Value, Sheets("Summary").Cells(i, "V").Value)
On Error Resume Next
'Set rnBody = Application.InputBox(Prompt:=stPrompt, _
Default:=Selection.Address, Type:=8)
'The user canceled the operation.
'If rnBody Is Nothing Then Exit Sub
Set rngGen = Nothing
Set rngApp = Nothing
Set rngspc = Nothing
Set rngGen = Sheets("General Overview").Range("A1:C30").SpecialCells(xlCellTypeVisible)
Set rngApp = Sheets("Application").Range("A1:E13").SpecialCells(xlCellTypeVisible)
Set rngspc = Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "Q").Value).SpecialCells(xlCellTypeVisible)
Set rngspc = Union(rngspc, Sheets(Sheets("Summary").Cells(i, "P").Value).Range(Sheets("Summary").Cells(i, "R").Value).SpecialCells(xlCellTypeVisible))
On Error GoTo 0
If rngGen Is Nothing And rngApp Is Nothing And rngspc Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
rngGen.Copy
rngApp.Copy
rngspc.Copy
'Retrieve the data from then copied range.
Set Data = New DataObject
Data.GetFromClipboard
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
.Body = Data.GetText & " " & stMsg
.SaveMessageOnSend = True
End With
'Send the e-mail.
With noDocument
.PostedDate = Now()
.send 0, vaRecipient
End With
'Release objects from memory.
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'Activate Excel for the user.
AppActivate "Microsoft Excel"
'Empty the clipboard.
Application.CutCopyMode = False
MsgBox "The e-mail has successfully been created and distributed.", vbInformation
End Sub
Then there are two parts for the function in another sheet
If the procedures are located in a sheet module, then you should call them with:
Sheet_Object_Name.Send_Unformatted_Rangedata (2)
Second option is to move procedures to ThisWorkbook module, and your code:
ThisWorkbook.Send_Unformatted_Rangedata (2)
should work fine.
Another solution is to add a separate module to your project (using Insert->Module), move procedures there, and then you can call those procedures from other modules using simply:
Send_Unformatted_Rangedata (2)