Keskustelu: Ohjelmointikysymykset: VBA: Excel: Sähköpostiin ajastettu muistutus

'Module1
Dim aOutlook As Outlook.Application
Dim aEmail As Outlook.MailItem

Public RunWhen As Double
Public Const cRunIntervalSeconds = 60 '300 '(5 minuuttia)
Public Const cRunWhat = "RunAtInterval"


Public Sub StartTimer()

   RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
   Application.OnTime EarliestTime:=RunWhen, _
   Procedure:=cRunWhat, Schedule:=True

End Sub

Sub RunAtInterval()

    Dim rvalues As Variant
    rvalues = CheckDates()

    If rvalues(0) Then
        SendMail rvalues(1), "Moi " & Split(rvalues(2), " ")(0) & "!" & _
        vbLf & vbLf & rvalues(3)
    End If

    StartTimer

End Sub

Sub StopTimer()

   On Error Resume Next
   Application.OnTime RunWhen, "RunAtInterval", Schedule:=False
   If Err <> 0 Then
      Err.Clear
      On Error GoTo 0
   End If

End Sub

Function CheckDates() As Variant()

    Dim rArray(3) As Variant

    Dim pvm As String
    pvm = Split(Now(), " ")(0)

    Dim vrivi As Long

    ActiveSheet.Unprotect Password:="salasana"
    vrivi = Taul1.Cells.SpecialCells(xlCellTypeLastCell).Row
    ActiveSheet.Protect Password:="salasana", DrawingObjects:=True, Contents:=True, Scenarios:=True

    For i = 1 To vrivi
        If Taul1.Cells(i, 3).Text = pvm Then
            rArray(0) = True
            rArray(1) = Taul1.Cells(i, 2).Text
            rArray(2) = Taul1.Cells(i, 1).Text
            rArray(3) = Taul1.Cells(i, 4).Text
            Taul1.Cells(i, 3).Value = ""
            Taul1.Cells(i, 4).Value = ""
            Exit For
        End If
    Next i


    CheckDates = rArray

End Function

Sub SendMail(ByVal address As String, ByVal message As String)

    Set aOutlook = New Outlook.Application
    Set aEmail = aOutlook.CreateItem(olMailItem)
    aEmail.Importance = 1
    aEmail.Subject = "ASIAA"
    aEmail.BodyFormat = olFormatPlain
    aEmail.Body = message
    aEmail.To = address

    On Error Resume Next
    aEmail.Send

    If Err <> 0 Then
        MsgBox "Sähköpostia lähetettäessä tapahtui virhe" & _
                                    vbCrLf & vbCrLf & Error$
        Err.Clear
        On Error GoTo 0
    End If

    aOutlook.Quit
    Set aEmail = Nothing
    Set aOutlook = Nothing

End Sub

Sub SendMail(ByVal address As String, ByVal message As String)

    Dim cdoMsg As Object
    Dim cdoConf As Object
    Set cdoMsg = CreateObject("CDO.Message")
    Set cdoConf = CreateObject("CDO.Configuration")
    Dim schema As String

    schema = "http://schemas.microsoft.com/cdo/configuration/"

    Set Flds = cdoConf.Fields

    With Flds
        .Item(schema & "sendusing") = 2
        .Item(schema & "smtpserver") = "smtp.gmail.com"
        .Item(schema & "smtpserverport") = 465
        .Item(schema & "smtpauthenticate") = 1
        .Item(schema & "sendusername") = "erkki.esimerkki@gmail.com"
        .Item(schema & "sendpassword") = "salasana"
        .Item(schema & "smtpusessl") = 1
        .Update
    End With

    With cdoMsg
        Set .Configuration = cdoConf
        .To = address
        .From = "Erkki Esimerkki"
        .Subject = "ASIAA"
        .TextBody = message
        On Error Resume Next
        .Send
        If Err <> 0 Then
            MsgBox "Sähköpostin lähettämisessä tapahtui virhe" _
            & vbCrLf & vbCrLf & Err.Description
            Err.Clear
            On Error GoTo 0
        End If
    End With

    Set cdoMsg = Nothing
    Set cdoConf = Nothing
    Set Flds = Nothing

End Sub