Email Sender VBA Outlook

Email Sender VBA Outlook is an emailing program that sends emails by communicating with Microsoft Outlook.

Explanation

Email Sender VBA Outlook is a VBA Excel program that communicates with Microsoft Outlook. The program sends email templates from a predefined place on you computer, the file needs to be an .oft-file. There is also a function for blocking certain email addresses. The program requires the reference “Microsoft Outlook XX.X Object Library” to be enabled. In the new version of office it is easy to block communication between excel and outlook make sure to enable the communication before trying the code otherwise it will not work

Code

Sub Email_Sender_VBA_Microsoft_Outlook()

Dim NoMailList(1500)
Call LoadNoMailList(NoMailList)

WaitTimeSecondsBetweenMail = Range("c4").Value
PlaceToStoreEmailTemplate = Range("c5").Value

RowA = 0
While Range("A14").Offset(RowA, 0).Value <> tom
    ToAdress = Range("c14").Offset(RowA, 0).Value
    Subject = Range("d14").Offset(RowA, 0).Value
    FileName = Range("D14").Offset(RowA, 0).Value
    Call WaitTimeProgram(WaitTimeSecondsBetweenMail)
    Subject = Range("e14").Offset(RowA, 0).Value
    Call MatchAdressWithNoMailList(ToAdress, Funnen, NoMailList)
    If Funnen = False Then
        Call EmailSenderProgram(ToAdress, FileName, Subject, PlaceToStoreEmailTemplate)
    End If
    RowA = RowA + 1
Wend

End Sub

Sub EmailSenderProgram(ToAdress, FileName, Subject, PlaceToStoreEmailTemplate)

Dim VBAOutlookEmailSend As Object, vItem As Object, vStr As String
Set VBAOutlookEmailSend = CreateObject("Outlook.Application")
Dim temp2 As String
temp2 = FileName
Set vItem = VBAOutlookEmailSend.CreateItemFromTemplate(PlaceToStoreEmailTemplate + temp2 + ".oft")
vItem.Subject = Subject
Dim ToContact As Outlook.Recipient
Set ToContact = vItem.Recipients.Add(ToAdress)
vItem.ReadReceiptRequested = False
vItem.Send
Set vItem = Nothing
Set VBAOutlookEmailSend = Nothing

End Sub

Public Sub LoadNoMailList(NoMailList)

rad = 0
While Range("g14").Offset(rad, 0).Value <> tom
    NoMailList(rad + 1) = Range("g14").Offset(rad, 0).Value
    rad = rad + 1
Wend

End Sub

Public Sub MatchAdressWithNoMailList(ToAdress, Funnen, NoMailList)

Funnen = False
plats = 1
While NoMailList(plats) <> tom
    komp = InStr(ToAdress, NoMailList(plats))
    If komp <> 0 Then Funnen = True
    plats = plats + 1
Wend

End Sub

Public Sub WaitTimeProgram(sek)

newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + sek
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime

End Sub