Excel VBA Email Rows to a Single Recipient - vba

I have a worksheet that tracks invoices and I am trying to generate an auto-emailer that if a cell in column 12 contains AUTOEMAIL it will combine all of the rows with a similar email address which I've generated using a TRIM function. It will pull all of the like rows (Email Addresses based on column 15) into a LotusNotes Email. Ron De Bruin has some fantastic examples on his site. I attempted to write a loop which attempts to loop through and copy all rows based on an email address. When I go to run, the code does nothing but no errors are presented. There are instances online of this done in Outlook, but they don't apply to LotusNotes as the issue is late vs early binding. I'm newer to VBA automation as well.
Sub Send_Data()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Const stSubject As String = "TEST"
Const stMsg As String = "TEST"
Const stPrompt As String = "Please select the range:"
lastrow = Range("N" & Rows.Count).End(xlUp).row
For Each Cell In Range("N8:N" & lastrow)
If WorksheetFunction.CountIf(Range("N8:N" & Cell.row), Cell) = 1 Then
If Cells(Cell.row, 11) = "AUTOEMAIL" Then
rnBody = "Hello" & vbNewLine & vbNewLine & _
ActiveCell.EntireRow.Select
On Error Resume Next
'The user canceled the operation.
If rnBody Is Nothing Then Exit Sub
On Error GoTo 0
'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.
rnBody.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 = stMsg & " " & Data.GetText
.SaveMessageOnSend = True
End With
' SEND EMAIL
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
' REMOVE FROM MEMORY
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'SWITCH BACK TO EXCEL
AppActivate "Microsoft Excel"
'EMPTY COPY-PAST CLIPBOARD
Application.CutCopyMode = False
' DISPLAYS TO USER IF SUCCESSFUL
MsgBox "Complete!", vbInformation
End If
End If
Next Cell
End Sub

I set the email body range as a Prompt Box where the user could highlight the cells and then another prompt box in which it asked for the email that was created using a TRIM() function. I realized that the way the code was set-up would not allow for what I wanted to do. The new method works quite well
Treevar

Related

Code for checking to see if a new message with a specific subject line has been already created Lotus

I'm not a programmer so I apologize in advance.
I have three different worksheets in a workbook. Each sheet has a specific macro so that after numbers are entered, shift supervisors can press a button with the assigned macro and metrics from that sheet will be copied and pasted to a different worksheet in a format with filter-able/pivot-able columns. It then saves and closes the data, goes back to the shift report worksheet, copies the pertinent cells, then opens lotus and formats a new message with a subject line stating the correct shift number and date and pastes the shift report data into the body of the e-mail.
Since there is a different button to press on 3 worksheets, and I can't count on supervisors to enter numbers in any specific order, I need to be able to tell if Lotus has already opened and created an e-mail with that specific subject line to see if it needs to be created or if it exists with some information already in the body. Does anyone know if this is possible?
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 WordDoc As Object
Dim msg As String
msg = "Leads Report " & Now() & vbNewLine & vbNewLine & _
"Finishing:" & vbNewLine & _
"**PASTE Leadsheet CELLS HERE**" & vbNewLine & vbNewLine
Sheets("Leadsheet").Select
Set newRange = Range("e4")
mystring = RangeToString(newRange)
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then
NDatabase.OPENMAIL
End If
'Create a new document
'******************************(if statement to see
'if a document with specific subject line has already been
'created....'subject = doc.GetItemValue("subject")(0)???????
'****************************************
Set NDoc = NDatabase.createdocument
With NDoc
.SendTo = "email#email.com" 'CHANGE THIS
.CopyTo = ""
.Subject = Format(Date, "mm-dd-yyyy") & " Lead Report Shift " & mystring
'Email body text, including marker text which will be replaced by the Excel cells
.Body = msg
.Save True, False
End With
'Edit the just-created document to copy and paste the Excel cells into it
Set NUIdoc = NUIWorkSpace.editdocument(True, NDoc)
'Find the marker text in the Body item
'Replace it with the Excel cell
With NUIdoc
'leadsheet
Workbooks("Master Shift Report Sheet.xlsm").Activate
Sheets("LeadSheet").Select
Range("B2:o62").Select
ActiveWindow.zoom = 86
Selection.copy
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Add
With WordApp.Selection
.PasteSpecial DataType:=4 & vbNewLine
.wholestory
.copy
End With
.gotofield ("Body")
.findstring "**PASTE Leadsheet CELLS HERE**"
.Paste
'Application.CutCopyMode = False
'.Send
'.Close
End With
Set NSession = Nothing
anything else looks wonky don't hesitate to point it out! I'm learning.

Emailing Ranges Instead Of Rows

I am attempting to run through sheet 2 of an Excel workbook to email ranges to customers.
The ranges would be A1:B30,C1:D30,E1:F30 and so on with their account number in A1 & email in B1 and information below.
Every time I try to run the email it comes up with:
Run Time Error 1004
and then goes on to error
Object has been moved or deleted
Is there another way of emailing ranges or a way to amend this code?
Sub EmailRanges()
Dim cr As Range
Set cr = [b1]
ActiveWorkbook.EnvelopeVisible = True
Do While cr <> ""
cr.Offset(, -1).Resize(30, 2).Select
With ActiveSheet.MailEnvelope
.Introduction = " Good Morning"
.Item.To = cr
.Item.Subject = "Just testing, sorry for filling you inbox ^_^ "
.item.Send ' to send
.Item.Display ' to test
End With
MsgBox cr & " receives " & Selection.Address
Set cr = cr.Offset(, 2)
Loop
Application.ScreenUpdating = True
MsgBox "The Customers Have Been Notified"
End Sub
You need to be more explicit about your references (workbook, sheet, ...).
Thx to #Ralph :
A range can be only selected if the sheet is activated first. Otherwise, you'll get an error.
This run smoothly on my computer :
Sub Email_Ranges()
Dim rG As Range
Dim RangeToSend As Range
Dim CustomerMail As String
Set rG = ActiveWorkbook.ActiveSheet.[b1]
ActiveWorkbook.EnvelopeVisible = True
Do While rG.Value <> vbNullString
CustomerMail = rG.Value
Set RangeToSend = rG.Offset(, -1).Resize(30, 2)
'With RangeToSend.Parent.MailEnvelope
''Uncomment below if you get an error
rG.Parent.Activate
RangeToSend.Select
With Selection.Parent.MailEnvelope
.Introduction = "Good Morning"
With .Item
.To = CustomerMail
.Subject = "Just testing, sorry for filling your inbox ^_^ "
.display 'to test
.Send 'to send
End With
End With
Debug.Print CustomerMail & " receives " & RangeToSend.Address
Set rG = rG.Offset(, 2)
Loop
ActiveWorkbook.EnvelopeVisible = False
End Sub

Excel VBA Add Spaces to Cells

I have 10 columns of data with a varying number of rows which is emailed as an unformatted range. I want to be able to right pad the cells in each column with spaces so the unformatted range copies over as evenly spaced. The reason the range is unformatted is I am using LotusNotes and I don't have the integration options like I have with Outlook. Is there anyway without adding columns that I can pad the cells with a space character so the range looks good in an email?
EDIT: So this allows me to type in an email via an input box and select a range. It will create the email and send but it dosen't preserve the cell formatting (i.e spacing) Can this be done? I have tried using the MIME entities to use HTML however I'm not sure how I'd copy the range into the HTML body
Updated Code:
Sub Lotus_Email()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As String
Dim rnBody As Range
Dim Data As DataObject
Const stSubject As String = "EMAIL SUBJECT"
Const stMsg As String = "Please review the following Purchase Orders and advise."
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 = InputBox("Please enter an e-mail address", "E-Mail Address Entry")
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
On Error GoTo 0
'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.
rnBody.Copy
Set rtItem = noDocument.CreateRichTextItem("Body")
With rtItem
.appendtext ("LINE 1")
.addnewline (2)
.appendtext ("LINE 2")
.addnewline (2)
.addnewline (1)
.appendtext ("Please review and respond to the email noted above")
.appendtext ("TEST")
rnBody.PasteSpecial
End With
'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.
' NON-HTML BODY OFF
' .Body = stMsg & vbCrLf & vbCrLf & vbCrLf & vbCrLf & Data.GetText
.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
UNTESTED. Maybe something like this?:
=A1&REPT(" ",25-LEN(A1))
So after using LotusNotes MIME I could import Rich Text, however it wouldn't preserve column width and excel formatting. I created a temp workbook with my range selection and attached it as an attachment. This seems to be the way to handle this with LotusNotes.

word macro split file on delimeter

I have multiple large docx files (word 2010) which need to be split on basis of a delimiter ("///"). I tried using a macro given http://www.vbaexpress.com/forum/showthread.php?39733-Word-File-splitting-Macro-question
However it gives an error "This method or Property is not available since No Text is Selected" on the line colNotes(i).Copy (Sub SplitNotes(...)).
The macro is reproduced below:
Sub testFileSplit()
Call SplitNotes("///", "C:\Users\myPath\temp_DEL_008_000.docx")
End Sub
Sub SplitNotes(strDelim As String, strFilename As String)
Dim docNew As Document
Dim i As Long
Dim colNotes As Collection
Dim temp As Range
'get the collection of ranges
Set colNotes = fGetCollectionOfRanges(ActiveDocument, strDelim)
'see if the user wants to proceed
If MsgBox("This will split the document into " & _
colNotes.Count & _
" sections. Do you wish to proceed?", vbYesNo) = vbNo Then
Exit Sub
End If
'go through the collection of ranges
For i = 1 To colNotes.Count
'create a new document
Set docNew = Documents.Add
'copy our range
colNotes(i).Copy
'paste it in
docNew.Content.Paste
'save it
docNew.SaveAs fileName:=ThisDocument.path & "\" & strFilename & Format(i, "000"), FileFormat:=wdFormatDocument
docNew.Close
Next
End Sub
Function fGetCollectionOfRanges(oDoc As Document, strDelim As String) As Collection
Dim colReturn As Collection
Dim rngSearch As Range
Dim rngFound As Range
'initialize a new collection
Set colReturn = New Collection
'initialize our starting ranges
Set rngSearch = oDoc.Content
Set rngFound = rngSearch.Duplicate
'start our loop
Do
'search through
With rngSearch.Find
.Text = strDelim
.Execute
'if we found it... prepare to add to our collection
If .Found Then
'redefine our rngfound
rngFound.End = rngSearch.Start
'add it to our collection
colReturn.Add rngFound.Duplicate
'reset our search and found for the next
rngSearch.Collapse wdCollapseEnd
rngFound.Start = rngSearch.Start
rngSearch.End = oDoc.Content.End
Else
'if we didn't find, exit our loop
Exit Do
End If
End With
'shouldn't ever hit this... unless the delimter passed in is a VBCR
Loop Until rngSearch.Start >= ActiveDocument.Content.End
'and return our collection
Set fGetCollectionOfRanges = colReturn
End Function
For those who might be interested:
The code does work in 2010. The issue was a delimiter which was the first thing on the file...
Deleted it and it worked...

Remove "Send Invitations" message when saving meeting in Lotus Notes using VBA

I am trying to create a tool that generates an invitation for a meeting using excel and lotus notes, and I am able to generate the email I want using code I found in StackOverflow and Lotus Notes API.
The only detail is that when I try to save the meeting in the calendar (without sending it. just save as a draft so someone could check the meeting details before sending the invitations) Lotus Notes will display the following message:
.
Is there a way to remove this message so the user won't see this message?
The code generating the meetings is below:
Private Sub salvaAppointment()
'Lotus notes objects
Set session = CreateObject("Notes.NotesSession")
Set Db = session.GetDatabase("", "")
'Prepare a document for the meeting
Call Db.OPENMAIL
Set doc = Db.CreateDocument
Set richText = doc.CreateRichTextItem("Body")
'Set meeting properties
Call doc.ReplaceItemValue("Form", "Appointment")
Call doc.ReplaceItemValue("AppointmentType", "3")
doc.Subject = "Reunião Caixa Rápido"
doc.CALENDARDATETIME = DateAdd("h", 15, Date)
doc.StartDateTime = DateAdd("h", 15, Date)
doc.EndDateTime = DateAdd("h", 17, Date)
doc.StartDate = Date
doc.Location = "Sala CCB"
'Email body
Call richText.AppendText("Modelo A3: ")
Call richText.AddNewLine(1, True)
modA3 = Application.ActiveWorkbook.Path & "\A3 Mod Modelo teste.ppt"
Call richText.EmbedObject(1454, modA3, modA3, "Attachment")
Call richText.AddNewLine(2, True)
Call richText.AppendText("**template**")
Call richText.Update
'Opens UI object to edit the document
Set UIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set uidoc = UIWorkSpace.EDITDocument(True, doc)
'Fills meeting required destination
Set nomes = Range(Range("F1"), Range("F" & Rows.Count).End(xlUp))
For Each nome In nomes
Call uidoc.FieldAppendText("EnterSendTo", nome & ",")
Next nome
'Copy Excel cells to clipboard
Dim lastRow As Integer
lastRow = Range("E" & Rows.Count).End(xlUp).Row
Range("A1:E" & lastRow).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
Set wdTemplate = WordApp.Documents.Open(Application.ActiveWorkbook.Path & "\templateEmail.doc")
'Paste into Word document and copy to clipboard
With wdTemplate.Bookmarks
.item("tabela").Range.PasteSpecial DataType:=10
End With
With WordApp.Selection
.WholeStory
.Copy
End With
'Find the marker text in the Body item
uidoc.GotoField ("Body")
uidoc.FINDSTRING "**template**"
'Paste from clipboard (Word) to Lotus Notes document
uidoc.Paste
Application.CutCopyMode = False
WordApp.Quit False
'When I call the below line, it displays the message
Call uidoc.Save
uidoc.Close
'Liberar memória
Set session = Nothing
Set UIWorkSpace = Nothing
'Deleta as planilhas temporárias
Sheets("dados").Delete
Sheets("temp").Delete
End Sub
I appreciate any help.
Notes recognizes a reserved field called MailOptions that is used to control automatic emailing when a document is saved. Try adding this within the block of code that you've got commented with 'Set meeting properties':
doc.ReplaceItemValue("MailOptions","0")