PDA

View Full Version : Email through excel from lotus notes 9



sachin483
07-23-2015, 03:05 AM
i have this macro for sending email with email-id , subject , body of the email from excel , but it is sending one email at a time on which the cursor is , i want to modify it with sending email to all the email address present in column one after another and if the email-id is same then also it should send, please let us know where should i modify as i am new to VB.



Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long


Sub SendEMail()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As Integer, x As Double


r = ActiveCell.Row
'Get the email address
Email = Cells(r, 3)


'Message subject
Subj = Cells(r, 6)


'Compose the message
Msg = ""
Msg = Msg & Cells(r, 7) & "," & vbCrLf & vbCrLf


'Replace spaces with %20 (hex)
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")


'Replace carriage returns with %0D%0A (hex)
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")


'Create the URL
URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg


'Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus


'Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%1"
End Sub

Kenneth Hobs
07-23-2015, 09:48 AM
Why not use the LotusNotes application? I don't have it any more but you can do it like this below. Be sure to change the mail\ken.nsf to your database name in the SendNotesMail(). You will then just need to send the input string of emails delimited by commas, which I demonstrate next.


Sub ken()
Dim s As String
s = Join(WorksheetFunction.Transpose(Range("A2", Range("A2").End(xlDown))), ",")
MsgBox s
End Sub


Sub test() Dim lErr As ErrObject
SendNotesMail _
"PMP Handbook5", _
"c:\t.pdf", _
"ken@odot.org,ken@aaahawk.com", _
"Click file: " & vbCrLf & _
"file://u:\Material\pmp\PMP%20Handbook.pdf" & vbCrLf & _
"or, open the attachement.", , lErr
If lErr.Number <> 0 Then MsgBox lErr.Number & vbCrLf & lErr.Description
End Sub


'Escape characters, %20=space, http://everything2.com/node/1350052
'Similar to: Brian Walters, http://www.ozgrid.com/forum/showthread.php?t=67089
Public Sub SendNotesMail(subject As String, Attachment As String, _
ByVal Recipient As String, _
BodyText As String, _
Optional SaveIt As Boolean = True, _
Optional ByRef lErr As ErrObject)
'lErr is used when using the Sub in a batch process,
'to handle instances where an error appears

'Example of use:
'SendNotesMail "The Subject", "C:\My Documents\TestFile.txt", _
"john@doe.com, jane@doe.com", _
"This is the body text, can be longer", True, lErr

'Set up the objects required for Automation into lotus notes
Dim Maildb As Object 'The mail database
Dim UserName As String 'The current users notes name
Dim MailDoc As Object 'The mail document itself
Dim AttachME As Object 'The attachment richtextfile object
Dim Session As Object 'The notes session
Dim EmbedObj As Object 'The embedded object (Attachment)
Dim ArRecipients() As String 'Array of recipients
Dim i As Long 'Counter
Dim oBody As Object 'Body of text in for rich text format

'Early Bind - Tools > Reference > Lotus Notes Automation Classes, notes32.tlb
'Dim ln As lotus.NOTESSESSION
'Set ln = CreateObject("Notes.NotesSession")
'Dim db As lotus.NOTESDATABASE
'Set db = ln.GETDATABASE("", "mail\username.nsf")
'Dim mDoc As lotus.NOTESDOCUMENT
'Set mDoc = db.CREATEDOCUMENT


'Create an array of recipients (Separated by commas)
Recipient = Recipient & ","

While InStr(1, Recipient, ",", 1) > 0
i = i + 1
ReDim Preserve ArRecipients(1 To i) As String
ArRecipients(i) = _
Left(Recipient, InStr(1, Recipient, ",", 1) - 1)
Recipient = _
Mid(Recipient, InStr(1, Recipient, ",", 1) + 1, Len(Recipient))
Wend

'Start a session to notes
Set Session = CreateObject("Notes.NotesSession")
On Error GoTo err_h

'Open the mail database in notes
UserName = Session.UserName
'************** ADD YOUR username.
Set Maildb = Session.GETDATABASE("", "mail\ken.nsf")
If Maildb.IsOpen = False Then
Maildb.OPENMAIL
End If

'Set up the new mail document
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
MailDoc.SendTo = ArRecipients
MailDoc.subject = UCase(subject)
'MailDoc.Body = UCase(BodyText)
Set oBody = MailDoc.CREATERICHTEXTITEM("Body")
oBody.APPENDTEXT BodyText

'This is supposed to be the property, but works
'on some systems only
'without an apparent reason of failure
MailDoc.SAVEMESSAGEONSEND = SaveIt

'Set up the embedded object and attachment and attach it
If Attachment <> "" Then
Set AttachME = MailDoc.CREATERICHTEXTITEM("Attachment")
Set EmbedObj = AttachME.EMBEDOBJECT(1454, "", Attachment, "Attachment")
End If

'Send the document
MailDoc.PostedDate = Now() 'Gets the mail to appear in the sent items folder
MailDoc.Send 1
MailDoc.Save True, True, False

'Clean Up
err_h:
Set lErr = Err
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing
End Sub

sachin483
07-24-2015, 03:19 AM
Thanks for the suggestion , i will definitely try out , but the macro given for sending all the email id concatenates email id , but in my case it has different subject , body of the text and for different email id , and it is not executing the second row after sending mail of first row, hence i needed to loop second row after sending the mail to first one until all the email id has been sent

Kenneth Hobs
07-24-2015, 06:04 AM
If you want one sent per row, then either test routine below would work. Note that c.Offset(,1).Value2 means than if c is B2 then the offset of one column's string value is C2. Be sure to change the offset values to the columns with the strings you want to send for that input parameter.

Use Text rather than Value2 if you want the format value of a cell. Obviously, you can concatenate extra string to the cell values for each input parameter as needed.


Sub Test_Mailto()
Dim c As Range
For Each c In Range("A2", Range("A2").End(xlDown))
With c
MailTo2 .Value2, .Offset(, 1), .Offset(, 2)
End With
Next c
End Sub


Sub MailTo(vTo As String, vSubject As String, vBody As String)
Shell "iexplore.exe mailto:" & vTo & "?Subject:" & vSubject & "?Body:" & vBody
End Sub


Sub test_SendNotesMail()
Dim lErr As ErrObject, c As Range
For Each c In Range("A2", Range("A2").End(xlDown))
With c
SendNotesMail .Offset(, 1).Value2, .Offset(, 2).Value2, .Value2, .Offset(, 3).Value2, True, lErr
If lErr.Number <> 0 Then MsgBox lErr.Number & vbCrLf & lErr.Description
End With
Next c

End Sub

sachin483
01-28-2016, 09:13 PM
After adding it as a sub macro the same is not executing with the main macro as i am new to VBA please let me know where should i change



Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long

Sub SendEMail1()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As Integer, x As Double
r = ActiveCell.Row
'Get the email address
Email = Cells(r, 10) & ";" & Cells(r, 11)

'Message subject
Subj = Cells(r, 17)

'Compose the message
Msg = ""
Msg = Msg & Cells(r, 19) & "," & vbCrLf & vbCrLf

'Replace spaces with %20 (hex)
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")

'Replace carriage returns with %0D%0A (hex)
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")

'Create the URL
URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg

'Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus

'Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%1"
End Sub

Sub Macro1()
'Sending all the email address which are in coloumn J & K
Dim nSheet As String, dateN As String
Dim x As Long, LRow As Long
Dim dateV As String
Dim CRT As Range, RNG As Range
nSheet = Sheets("sheet2").Name
dateV = Range("B2").Value
LRow = Cells(Rows.Count, "M").End(xlUp).Row

Cells(Rows.Count, "A").End(xlUp).Offset(1, 28) = Range("M3")
Cells(Rows.Count, "A").End(xlUp).Offset(1, 29) = Range("N3")
Cells(Rows.Count, "A").End(xlUp).Offset(1, 30) = Range("O3")
Cells(Rows.Count, "A").End(xlUp).Offset(2, 28) = Range("B2").Value
Cells(Rows.Count, "A").End(xlUp).Offset(3, 29) = Range("B2").Value
Cells(Rows.Count, "A").End(xlUp).Offset(4, 30) = Range("B2").Value
Set RNG = Sheets(nSheet).Range("A3:X" & LRow)
Set CRT = Sheets(nSheet).Cells(Rows.Count, "A").End(xlUp).Offset(1, 28).CurrentRegion

CRT.Clear

End Sub