Advertisement
Guest User

Untitled

a guest
Jan 18th, 2017
168
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 3.08 KB | None | 0 0
  1. Column G Column W
  2. File1.xls recipient1@email.com
  3. File2.xls recipient2@email.com
  4. File3.xls recipient3@email.com
  5. File4.xls recipient4@email.com
  6.  
  7. End with without with
  8.  
  9. End With
  10.  
  11. Sub email()
  12.  
  13. 'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
  14. 'Working in Office 2000-2016
  15.  
  16. 'Variables
  17. Dim cell As Range
  18.  
  19.  
  20.  
  21. Application.ScreenUpdating = False
  22.  
  23. Dim Maildb As Object
  24. Dim MailDoc As Object
  25. Dim Body As Object
  26. Dim Session As Object
  27. 'Start a session of Lotus Notes
  28. Set Session = CreateObject("Lotus.NotesSession")
  29. 'This line prompts for password of current ID noted in Notes.INI
  30. Call Session.Initialize
  31. 'or use below to provide password of the current ID (to avoid Password prompt)
  32. 'Call Session.Initialize("<password>")
  33. 'Open the Mail Database of your Lotus Notes
  34. Set Maildb = Session.GETDATABASE("", "D:NotesdataMaileXceLiTems.nsf")
  35. If Not Maildb.IsOpen = True Then
  36. Call Maildb.Open
  37. End If
  38.  
  39.  
  40.  
  41. 'Loop
  42.  
  43. On Error GoTo cleanup
  44. For Each cell In Columns("V").Cells.SpecialCells(xlCellTypeConstants)
  45. If cell.Value Like "?*@?*.?*" And _
  46. LCase(Cells(cell.Row, "G").Value) <> "" Then
  47.  
  48.  
  49. 'Email COde
  50.  
  51.  
  52. Set MailDoc = Maildb.CREATEDOCUMENT
  53. Call MailDoc.REPLACEITEMVALUE("Form", "Memo")
  54. 'Set the Recipient of the mail
  55. Call MailDoc.REPLACEITEMVALUE("SendTo", cell.Value)
  56. 'Set subject of the mail
  57. Call MailDoc.REPLACEITEMVALUE("Subject", "Attention Required: Promotion Announcement for Week " & Range("O10").Value & " " & Range("O13").Value)
  58. 'Create and set the Body content of the mail
  59. Set Body = MailDoc.CREATERICHTEXTITEM("Body")
  60.  
  61.  
  62. 'Email Body
  63.  
  64. Call Body.APPENDTEXT("Good " & Range("A1").Value & "," _
  65. & vbNewLine & vbNewLine & _
  66. "Thank you for your interest in participating in this weeks special promotion. Please see the details below." _
  67. & vbNewLine & vbNewLine _
  68. & vbNewLine & vbNewLine _
  69. & Range("I10").Value _
  70. & vbNewLine & vbNewLine _
  71. & "Thank you and kind regards / Danke und freundliche Grüße," _
  72. & vbNewLine & vbNewLine _
  73. & "The Food Specials Team" _
  74. & vbNewLine)
  75.  
  76.  
  77. 'End Email Body
  78.  
  79.  
  80.  
  81. 'Example to create an attachment (optional)
  82. Call Body.ADDNEWLINE(2)
  83. Call Body.EMBEDOBJECT(1454, "", Filename, cell.Offset(0, -19).Value)
  84. 'Example to save the message (optional) in Sent items
  85. MailDoc.SAVEMESSAGEONSEND = True
  86. 'Send the document
  87. 'Gets the mail to appear in the Sent items folder
  88. Call MailDoc.REPLACEITEMVALUE("PostedDate", Now())
  89. Call MailDoc.SEND(True)
  90. 'Clean Up the Object variables - Recover memory
  91.  
  92.  
  93.  
  94.  
  95. 'End Loop
  96.  
  97. End With
  98. On Error GoTo 0
  99. Set OutMail = Nothing
  100. End If
  101.  
  102. Next cell
  103.  
  104. cleanup:
  105. Set Maildb = Nothing
  106. Set MailDoc = Nothing
  107. Set Body = Nothing
  108. Set Session = Nothing
  109.  
  110. Application.ScreenUpdating = True
  111.  
  112. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement