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)
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 using this code to open a list of email-adresses directly in outlook. The email list consists of roughly 100 email-adresses.
If I let the code run for only parts of the list it works just fine for all different parts, but as soon as I let it run for the whole list I get a runtime error '5. Does anyone have a suggestion what causes this problem? I would be very thankful.
If ActiveWorkbook.Worksheets("Output").Range("I10").Value = "Wahr" Then
Dim strAddress As String
Dim lastCell As Long
Dim i As Integer
Worksheets("Output").Activate
lastCell = Range("B" & Rows.Count).End(xlUp).Row
For i = 13 To lastCell
If strAddress = "" Then
strAddress = Cells(i, 2).Value
Else
strAddress = strAddress & ";" & Cells(i, 2).Value
End If
Next i
ActiveWorkbook.FollowHyperlink Address:="mailto:" & strAddress 'this line gives me the error
End If
EDIT: The weird thing is, that it doesnt really matter which "groups" I choose. It seems to be a question of how many adresses I pick.
Not sure what you mean by I am using this code to open a list of email-adresses directly in outlook.
The code appears to create a single blank email with each cell in B13 downwards providing the email addresses?
Maybe this code below will help.
It uses late binding (so no references needed) to get a reference to Outlook, it then creates an email and adds the email addresses to it as recipients before finally displaying it. You can change the .Display to .Send to send the email rather than just display it.
Public Sub Test()
Dim oOL As Object
Dim oMail As Object
Dim rLastCell As Range
Dim rAddRange As Range
Dim rCell As Range
Set oOL = CreateOL
With ThisWorkbook.Worksheets("Output")
Set rLastCell = .Cells(.Rows.Count, 2).End(xlUp)
Set rAddRange = .Range("B13", rLastCell)
End With
Set oMail = oOL.CreateItem(0)
With oMail
For Each rCell In rAddRange
.Recipients.Add rCell.Value
Next rCell
.Display
End With
End Sub
Public Function CreateOL() As Object
Dim oTmpOL As Object
On Error GoTo ERROR_HANDLER
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Creating an instance of Outlook is different from Excel. '
'There can only be a single instance of Outlook running, '
'so CreateObject will GetObject if it already exists. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set oTmpOL = CreateObject("Outlook.Application")
Set CreateOL = oTmpOL
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure CreateOL."
Err.Clear
End Select
End Function
I am actually quite new to VBA but I am doing some coding to streamline my office work. I understand this would be some amateur level questions to most of you but I tried to google for quite a while and I do not find satisfactory answer.
I have an excel write up that based on the inputted parameters, It should ultimately refer to the correct sheet -> copy the selected cells -> Generate an e-Mail with the body pasting the copied cells along with an attachment
I can do most of the parts, just that I cannot reference the "Correct Sheet" as a variable in my codes. Please shed some lights on for me. Thank you.
Here are most of the codes, the rest are irrelevant and too clumsy to paste all I guess.
Sub GenerateEmail()
Dim olApp As Object
Dim olMailItm As Object
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim StrAtt1 As String
Dim rng As Range
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("test").Range("A1:Q500").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng 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
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
On Error Resume Next
With olMailItm
SDest = ""
StrAtt1 = ThisWorkbook.Path & "\PDF\" & Sheets("Email_Generator").Range("B16")
.To = Worksheets("Email_Generator").Range("B14")
.CC = "Myself"
.BCC = ""
.Subject = Worksheets("Email_Generator").Range("B18")
.HTMLBody = RangetoHTML(rng)
.attachments.Add StrAtt1
.Display
End With
Set olMailItm = Nothing
Set olApp = Nothing
End Sub
Specifically, I would like this code "Sheets("test") as a Cell in Sheet "Test" that is a variable based on the paramters I have inputted in my excel so that this code will reference to the correct worksheet
Set rng = Sheets("test").Range("A1:Q500").SpecialCells(xlCellTypeVisible)
But when I identify the sheet as a named sheet e.g. Sheets("Email1"), it perfectly works, just that it cannot become a variable.
I hope this post is not too long to read because I tried to be as specific as possible. Thank you to all who reads this and tries to help. I really appreciate it.
This function to return the worksheet name selected by the user from an InputBox. If the user cancels or enters an invalid number then the function returns a zero length string.
Sub TestFunction()
Dim SheetName As String
Dim rng As Range
SheetName = getSheetNameFromInputBox
If Len(SheetName) = 0 Then
MsgBox Prompt:="Try Again", Title:="Invalid Sheet"
Exit Sub
End If
Set rng = Sheets(SheetName).Range("A1:Q500").SpecialCells(xlCellTypeVisible)
MsgBox rng.Address(External:=True)
End Sub
Function getSheetNameFromInputBox() As String
Dim ws As Worksheet
Dim Prompt As String
Dim result
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Sheet3" Then
Prompt = Prompt & ws.Index & ") " & ws.Name & vbCrLf
End If
Next
result = InputBox(Prompt:=Prompt, Title:="Enter the Worksheet number", Default:=1)
On Error Resume Next
If IsNumeric(result) Then getSheetNameFromInputBox = Worksheets(CInt(result)).Name
On Error GoTo 0
End Function
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.
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.