Automatic monthly email 1

[guitardave78]

My company sends a monthly newsletter to clients. I wish to automate this process with outlook VBA. I need to have say a folder with the news letter in it and a newsletter flagged to be sent to a distribution list on a certain date. Is this possible?

 

[Craig0201]

Dave,

Very possible. Not 100% familiar with Outlook VBA but I've code for Access that sends an email with an attachment once a file is over a week old. The code should be pretty similar for you. My problem is not knowing the events in Outlook VBA. If you know what event it can run on, you should be able to do something with this code.

Function SendMail(strPath As String, strQuery As String, strRecipient As String, strSubject As String)

Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim datFile As Date
Dim datDate As Date
Dim intWeekday As Integer
Dim strMessageBox As String
Dim strMessageBoxTitle As String

datFile = MondayDate(FileDateTime(strPath))

datDate = Date

If datFile < datDate - 6 Then

strMessageBox = &quot;You are about to send mail to &quot; & strRecipient & &quot;. Your PC will hang for up to 3 minutes&quot; & vbCrLf & &quot;whilst this email is being created.&quot;
strMessageBoxTitle = &quot;About to send mail to &quot; & strRecipient & &quot;.&quot;

MsgBox strMessageBox, vbOKOnly, strMessageBoxTitle

DoCmd.OutputTo acQuery, strQuery, &quot;MicrosoftExcel(*.xls)&quot;, strPath, False, &quot;&quot;

Set objOutlook = CreateObject(&quot;Outlook.Application&quot

Set objOutlookMsg = objOutlook.CreateItem(Outlook.olMailItem)

With objOutlookMsg
Set objOutlookRecip = .Recipients.Add(strRecipient)
objOutlookRecip.Type = Outlook.olTo
.Subject = strSubject
.Importance = Outlook.olImportanceHigh
.Attachments.Add strPath, olByValue
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
.Save
.Send
End With

strMessageBox = &quot;You have just sent mail to &quot; & strRecipient & &quot;.&quot;
strMessageBoxTitle = &quot;Sent mail to &quot; & strRecipient & &quot;.&quot;

MsgBox strMessageBox, vbOKOnly, strMessageBoxTitle

End If

End Function

Function MondayDate(Today As Date) As Date

Dim intWeekday As Integer

intWeekday = WeekDay(Today, vbMonday)

MondayDate = Today - intWeekday + 1

End Function

 

[Mossoft]

Create a recurring appointment called <Name> with a reminder.
In the code for ThisOutlookSession (ALT+F11 in Outlook, then double click ThisOutlookSession in Project1 tree view) put the following:

Private Sub Application_Reminder(ByVal Item As Object)

If Item.Subject = <Name> Then
Call Email_File(<File to attach>,<distribution list/recipient(s)>)
End If

End Sub

Function Email_File(i_strFilename As String, i_strAddress As String) As Boolean
'
'Email the file to the address given. Separate addresses delimited with semicolons
'
' Modifications
' Who When Mod What

On Error GoTo Email_Error
Dim objMailItem As MailItem
Dim lngSemiColon As Long
Dim strAddress As String

Email_File = True

'create mail item
Set objMailItem = Outlook.CreateItem(olMailItem)
objMailItem.Subject = <Subject here>

'add attachment
objMailItem.Attachments.Add Source:=i_strFilename, Type:=olByValue

'parse and add addresses
strAddress = i_strAddress
While Len(strAddress) > 0
lngSemiColon = InStr(strAddress, &quot;;&quot
If lngSemiColon > 0 Then
objMailItem.Recipients.Add Left(strAddress, lngSemiColon - 1)
strAddress = Mid(strAddress, lngSemiColon + 1)
Else
objMailItem.Recipients.Add strAddress
strAddress = vbNullString
End If
Wend

'acknowledgement
objMailItem.ReadReceiptRequested = False

'send mail
objMailItem.Send

DoEvents

Email_Exit:
Exit Function

Email_Error:
Email_File = False
Resume Email_Exit

End Function

### Reference KB Q236774 ###

HTH

M

 

[guitardave78]

Cheers this is how i've done it for now

I made a folder called news with the email i want to send in it. The email is fully formated with a recipient in the to section.
I set up a reminder with the subject news in it.
This is the send code

Private Sub Application_Reminder(ByVal Item As Object)
If Item.Sensitivity <> olConfidential Then
If TypeOf Item Is AppointmentItem Then SendApptReminder Item

End If
End Sub

Private Sub SendApptReminder(ByRef Item As AppointmentItem)
If Item.Subject = &quot;news&quot; Then sendpage2
End Sub

Sub sendpage2()

Set ol = New Outlook.Application
Set olns = ol.GetNamespace(&quot;MAPI&quot
Set MyInboxFolder = olns.GetDefaultFolder(olFolderInbox)
Set myNewsletter = MyInboxFolder.Folders(&quot;News&quot
'If myNewsletter.UnReadItemCount <> 0 Then
Set mynews = myNewsletter.Items(1)
mynews.Copy
mynews.Send
'End If

End Sub

Anyone with any improvements would be gratefully heard. Thanx for the input guys!

 

[donna6197]

Couldn't you just go to the message options (View menu) and set a date for Do not deliver before?

 

[guitardave78]

Trouble is it needs to be recurring, every month. To make life easy on my somewhat technicaly challenged boss, all he has to do is put the newsletter in a public out look folder at any time during the month and it will still be sent on time!! Gives him less to remember!!