vb code to use Redemption

Option Compare Database
Option Explicit


Private dbs As DAO.Database
Private qdf As DAO.QueryDef
Private rst As DAO.Recordset


Public Sub SendInterventionEmails()
'Created by Helen Feddema 10-Jan-2010
'Last modified by Helen Feddema 10-Jan-2010

On Error GoTo ErrorHandler

   'Dim appOutlook As New Outlook.Application
   'Dim itm As Outlook.MailItem
   
'Redemption Effort
    Dim Attachment As String
    
   Dim olApp As New Outlook.Application 'Redemption Effort
   Dim olNS As Outlook.NameSpace 'Redemption Effort
   Dim olFolder As Outlook.MAPIFolder ' Redemption Effort
   Dim olMailItem As Outlook.MailItem 'Redemption Effort
   Dim olAttachment As Outlook.Attachment 'Redemtption Effort
        'add a reference to the Redemption Safe Mail Item
    Dim objSafeMail As Redemption.SafeMailItem 'Redemtption Effort
    Set olApp = CreateObject("Outlook.application") 'Redemtption Effort
    Set olNS = olApp.GetNamespace("MAPI") 'Redemtption Effort
    Set olFolder = olNS.GetDefaultFolder(olFolderInbox) 'Redemtption Effort
    Set olMailItem = olFolder.Items.Add 'Redemtption Effort

   Dim rstIntervention As DAO.Recordset
   Dim lngCount As Long
   Dim lngID As Long
   Dim rpt As Access.Report
   Dim strFileName As String
   Dim strPrompt As String
   Dim strQuery As String
   Dim strRecordSource As String
   Dim strReport As String
   Dim strSQL As String
   Dim strTitle As String
   Dim strCurrentPath As String
   Dim strFileNameAndPath As String
   Dim strEmailSource As String
   Dim Recipient As String
   Dim BodyTxt As String
      
   strEmailSource = "qryInterventionEmail"
   strRecordSource = "qryMissingAssignments"
   strQuery = "qryMissingAssignmentsSingleStudent"
   Set dbs = CurrentDb
   Set rstIntervention = dbs.OpenRecordset(strEmailSource)
   strCurrentPath = Application.CurrentProject.Path & "\"
   
   With rstIntervention
      Do While Not .EOF
         lngID = ![StID]
         Debug.Print "Processing Student ID " & lngID
         strFileName = Format(Now(), "YYYYMMDD") & " " & "Intervention Report for " & Trim(![StFirst]) _
            & " " & Trim(![StLast]) & ".pdf"
         strFileNameAndPath = strCurrentPath & strFileName
         
         'Create filtered query
         strSQL = "SELECT * FROM " & strRecordSource & " WHERE " _
            & "[StID] = " & Chr(39) & lngID & Chr(39) & ";"
         Debug.Print "SQL for " & strQuery & ": " & strSQL
         lngCount = CreateAndTestQuery(strQuery, strSQL)
         Debug.Print "No. of items found: " & lngCount
         If lngCount = 0 Then
            GoTo NextStudent
         End If
      
         'Use SQL string as the record source of a report
         strReport = "rptMissingAssignmentsNew"
         DoCmd.OpenReport ReportName:=strReport, _
            View:=acViewPreview, _
            windowmode:=acWindowNormal
         Set rpt = Reports(strReport)
         DoCmd.OutputTo objecttype:=acOutputReport, _
            objectname:=strReport, _
            outputformat:=acFormatPDF, _
            outputfile:=strFileNameAndPath
            
' Commenting out Helen's Code to try redemption
'         'Create email
'         Set itm = appOutlook.CreateItem(olMailItem)
'         itm.Subject = "You have been assigned to Intervention"
'         itm.Body = "You have been assigned to Intervention for " & ![DateToRpt] & ", Period " & ![PdToRpt] _
'                  & ". Attached is a file showing your missing assignments."
'         itm.To = ![Email]
'         itm.Attachments.Add Source:=strFileNameAndPath, _
'            Type:=olByValue
'
'         'For editing before sending
'         itm.Display
'
'         'For sending automatically
         'itm.Send
         
' Trying the redemption code
Recipient = "eharman@ohp.k12.oh.us"
BodyText = "You have been assigned to Intervention for " & vbNewLine & vbNewLine _
            & "Date to Report     " & ![DateToRpt] & vbNewLine _
            & "Period to Report   " & ![PdToRpt] & vbNewLine & vbNewLine _
            & "Attached is a file showing your missing assignments."
 With olMailItem
        .Subject = "You have been assigned to Intervention"
'        .To = ![Email]
        .To = Recipient
        .Body = BodyText
'        If Attachment <> "" Then
           Set olAttachment = .Attachments.Add(strFileNameAndPath)
'        End If
    End With
    Set objSafeMail = New Redemption.SafeMailItem
    objSafeMail.Item = olMailItem
    objSafeMail.Send
         
         DoCmd.Close objecttype:=acReport, _
            objectname:=strReport, _
            Save:=acSaveNo

NextStudent:
         .MoveNext
      Loop
   End With
   
ErrorHandlerExit:
   Exit Sub

ErrorHandler:
   MsgBox "Error No: " & Err.Number _
      & " in SendInterventionEmails procedure; " _
      & "Description: " & Err.Description
   Resume ErrorHandlerExit

Set objSafeMail = Nothing
Set olMailItem = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
    
End Sub

Public Function CreateAndTestQuery(strTestQuery As String, _
   strTestSQL As String) As Long
'Created by Helen Feddema 28-Jul-2002
'Last modified by Helen Feddema 10-Jan-2010

On Error Resume Next
   
   'Delete old query
   Set dbs = CurrentDb
   dbs.QueryDefs.Delete strTestQuery

On Error GoTo ErrorHandler
   
   'Create new query
   Set qdf = dbs.CreateQueryDef(strTestQuery, strTestSQL)
   
   'Test whether there are any records
   'Set rst = dbs.OpenRecordset(strTestQuery)
   Set rst = qdf.OpenRecordset(dbOpenDynaset, dbSeeChanges)
   With rst
      .MoveFirst
      .MoveLast
      CreateAndTestQuery = .RecordCount
   End With
   
ErrorHandlerExit:
   Exit Function

ErrorHandler:
   If Err.Number = 3021 Then
      CreateAndTestQuery = 0
      Resume ErrorHandlerExit
   Else
   MsgBox "Error No: " & Err.Number _
      & " in CreateAndTestQuery procedure; " _
      & "Description: " & Err.Description
   End If
   
End Function

Select allOpen in new window