PhilCon, Well, I got this finished. I thought I would post the whole thing. The intent is to send out an automated email on Mondays with 2 reports and 2 *$*&!
graphs attached as snapshots to a primary and CC'd recipients. I think I still have some unnecessary stuff in here but it works fine.
The original email code was from another post and modified for this purpose. Added some html formatting and some other stuff too.
Someone else might find some of this useful.
Private Sub Form_Load()
On Error GoTo Err_EmailError
Dim response
Dim exitapp
'This is to check to see if the day is a Monday and checks to see if the email has been sent.
Me.txtTodayDate = WeekdayName(Weekday(Date))
If Me.txtTodayDate = DLookup("[sendDate]", "tblEmailSendDate", "[id]=1") Then
DoCmd.Close acForm, "frmEmailRpts", acSaveNo
End If
'See if the item has been sent
Select Case Me.txtTodaysDate
Case Is = DLookup("[sendDate]", "tblEmailSendDate", "[id]=1")
DoCmd.Close acForm, "frmEmailRpts", acSaveNo
'If not sent - Send the files
Case Is > DLookup("[sendDate]", "tblEmailSendDate", "[id]=1")
If Me.txtTodayDate <> "Monday" Then
GoTo exitapp
End If
'See if Date is Monday
If Me.txtTodayDate = "Monday" Then
response = MsgBox("It's Monday and time to send out the weekly reports." & _
Chr(13) & Chr(13) & _
"Is your default printer capable of printing 11x17 reports?", vbYesNo, "Default Printer Check")
End If
If response = vbNo Then
MsgBox "Set the correct default printer for 11x17", vbInformation, "Change Printer Settings"
DoCmd.Quit acQuitSaveNone
End If
If response = vbYes Then
MsgBox "Thank You, Continuing with Report Generation", vbOKOnly
End If
Dim myDir
Dim myfile
myDir = Dir("C:\Snapshots", vbDirectory) 'Check to see if directory exists
If myDir = "" Then
'Need to create Directory
MkDir ("C:\Snapshots")
End If
'If Directory is Full, Empty Directory
If Dir("c:\Snapshots\*.*") > vbNullString Then
Kill ("c:\Snapshots\*.*")
End If
'Output reports to Snapshot Format
DoCmd.SetWarnings False
'/////////////////////////////////////////////////////////////////////////////////////////'
'This should fix the turnover Completion Graph - 08-16-04'
Dim StDocName As String
Dim Systems
Dim MileStones
Dim Package
Systems = DCount("[SuSys]", "tblSus") 'Get Number of Packages
MileStones = DCount("[SuSys]", "tblSus", "left([SuSys],1)='*'") 'Get Number of Milestones
Package = Systems - MileStones 'Real Packages
StDocName = "rptToPkCompletion"
DoCmd.OpenReport StDocName, acDesign
Reports!rptToPkCompletion.GraphToDts.Axes(xlValue, xlSecondary).MaximumScale = Package
Reports!rptToPkCompletion.GraphToDts.Axes(xlValue, xlSecondary).MinimumScale = 0
With Reports!rptToPkCompletion.GraphToDts.ChartTitle
.Caption = DLookup("[Jobname]", "tblJobs", "[number]=1") & " Turnover Package Completion"
End With
With Reports!rptToPkCompletion.GraphToDts.Axes(xlValue, xlSecondary)
.HasTitle = True
.AxisTitle.Text = Package & " Startup Packages" ' add Y-Axis Label
End With
DoCmd.Close acReport, StDocName, acSaveYes
'///////////////////////////////////////////////////////////////////////////////////////////'
'This should fix the Earned Completion Graph 08-16-04
Dim sys
Dim DdDate
Dim StDate
Dim X
X = DSum("[mhrs Budget]", "Ad-AddSpecialsBudget", "[mhrs budget]")
DdDate = DLookup("[CodDate]", "[tblCodDate]", "[ID]=1") 'Get Drop Dead Date
StDate = DMin("[ActToDt]", "tblStatus")
sys = DCount("[SuSys]", "tblSus") 'Get Number of Packages
DoCmd.OpenReport "rptToPkEarnedCompletion", acDesign
Reports!rptToPkEarnedCompletion.[GraphToDts].Axes(xlCategory).MinimumScale = StDate
Reports!rptToPkEarnedCompletion.[GraphToDts].Axes(xlCategory).MaximumScale = DdDate 'Set Drop Dead Date as Max for Graph
Reports!rptToPkEarnedCompletion.[GraphToDts].Axes(xlValue, xlPrimary).MinimumScale = SchTODt
Reports!rptToPkEarnedCompletion.[GraphToDts].Axes(xlValue, xlPrimary).MaximumScale = X
With Reports!rptToPkEarnedCompletion
Reports!rptToPkEarnedCompletion.GraphToDts.ChartTitle.Caption = DLookup("[Jobname]", "tblJobs", "[number]=1") & " Earned Man-Hours"
End With
With Reports!rptToPkEarnedCompletion.[GraphToDts].Axes(xlValue, xlPrimary)
.HasTitle = True
.AxisTitle.Text = "Total Budgeted Man-Hours: " & X
End With
DoCmd.Close acReport, "rptToPkEarnedCompletion", acSaveYes
'////////////////////////////////////////////////////////////////////////////////////////////////'
'Create Snapshots
DoCmd.OutputTo acOutputReport, "rptTurnoverMt", acFormatSNP, "C:\Snapshots\Commissioning Status Report.snp"
DoCmd.OutputTo acOutputReport, "rptSystemTurnover", acFormatSNP, "C:\Snapshots\System Turnover Report Report.snp"
DoCmd.OutputTo acOutputReport, "rptToPkCompletion", acFormatSNP, "C:\Snapshots\Turnover Package Completion Graph.snp"
DoCmd.OutputTo acOutputReport, "rptToPkEarnedCompletion", acFormatSNP, "C:\Snapshots\Turnover Package Earned Completion Graph.snp"
DoCmd.SetWarnings True
'Get Persons Cc'd
Dim StEql As String
StEql = "SELECT tblEmails.[E-Mail], tblEmails.CcFlag From tblEmails " & _
"WHERE tblEmails.CcFlag= -1;"
'Dim rst As Recordset
Dim StSql As String
Dim CcPers As String
Set rst = CurrentDb.OpenRecordset(StEql, dbOpenDynaset)
rst.MoveFirst
Do Until rst.EOF
CcPers = CcPers & rst.[E-Mail] & "; "
rst.MoveNext
Loop
'Go on with rest of Email
Dim db As DAO.Database
Dim MailList As DAO.Recordset
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim Subjectline As String
Dim BodyFile As String
Dim Attachment1 As String
Dim Attachment2 As String
Dim fso As FileSystemObject
Dim MyBody As TextStream
Dim myBodyText As String
Dim MyJob As String
Dim MyPrimaryAddress As String
Dim Vlv As Integer 'Total Valves
Dim VlvComp As Integer 'Valves Complete
Dim VlvPct As Double 'Valve Percentage
Dim Inst As Integer 'Total Instruments
Dim InstComp As Integer 'Instruments Complete
Dim InstPct As Double 'Instrument Percentage
Dim Eq As Integer 'Total Equipment
Dim EqComp As Integer 'Equipment Complete
Dim EqPct As Double 'Equipment Percentage
Dim Flush As Integer 'Total Flushes
Dim FlushComp As Integer 'Flushes Complete
Dim FlushPct As Double 'Flush Percentage
Dim Func As Integer 'Total Functions
Dim FuncComp As Integer 'Functions Complete
Dim FuncPct As Double 'Function Percentage
Dim Spec As Integer 'Total Specialties
Dim SpecComp As Integer 'Specialties Complete
Dim SpecPct As Double 'Specialy Percentage
Vlv = DCount("*", "tblValveList", "[ValveID]") 'Total Valves
VlvComp = DCount("*", "tblValveList", "[SuManVChkCpl] = -1") 'Valves Complete
VlvPct = FormatNumber(VlvComp / Vlv, 3) * 100 'Valve Percentage
Inst = DCount("*", "tblInstIndexSU", "[instTagNumber]") 'Total Instruments
InstComp = DCount("*", "tblInstIndexSU", "[InstComplete] = -1") 'Instruments Complete
InstPct = FormatNumber(InstComp / Inst, 3) * 100 'Instrument Percentage
Eq = DCount("*", "tblEqList", "[tagNo]") 'Total Equipment
EqComp = DCount("*", "tblEqList", "[InspecComplete] = -1") 'Equipment Complete
EqPct = FormatNumber(EqComp / Eq, 3) * 100 'Equipment Percentage
Flush = DCount("*", "tblFlushes", "[FlushID]") 'Total Flushes
FlushComp = DCount("*", "tblFlushes", "[FlushComplete] = -1") 'Flushes Complete
FlushPct = FormatNumber(FlushComp / Flush, 3) * 100 'Flush Percentage
Func = DCount("*", "tblFunctional", "[FunctionalID]") 'Total Functionals
FuncComp = DCount("*", "tblFunctional", "[Complete] = -1") 'Functionals Complete
FuncPct = FormatNumber(FuncComp / Func, 3) * 100 'Functional Percentage
Spec = DCount("*", "tblSpecialties", "[SoloDataLink]") 'Total Specialties
SpecComp = DCount("*", "tblSpecialties", "[InspecComplete] = -1") 'Specialties Complete
SpecPct = FormatNumber(SpecComp / Spec, 3) * 100 'Specialty Percentage
Set fso = New FileSystemObject
'Job Name
MyJob = DLookup("[jobname]", "tblJobs", "[number] = 1")
'Person Sent Email
MyPrimaryAddress = DLookup("[E-Mail]", "tblEmails", "[Email FLag] = -1")
'Subject - Commissioning Report
Subjectline = "Commissioning Status Reports for " & MyJob
BodyFile$ = "Commissioning Status Reports for " & txtTodaysDate & "."
myBodyText = "<Center><B>Automated Email sent from " & MyJob & "</B></Center><br><br>" & _
"<B>Completion Summary:</B><br><br>" & _
"There are <b>" & Vlv & " </b> total valves. <b> " & VlvComp & " </b> are indicated as complete. This is about <b>" & VlvPct & "%.</b><br><br>" & _
"There are <b>" & Inst & " </b> total instruments.<b> " & InstComp & " </b> are indicated as complete. This is about <b>" & InstPct & "%.</b><br><br>" & _
"There are <b>" & Eq & " </b> total pieces of equipment.<b> " & EqComp & " </b> are indicated as complete. This is about <b>" & EqPct & "%.</b><br><br>" & _
"There are <b>" & Flush & " </b> total flushes. <b>" & FlushComp & " </b> are indicated as complete. This is about <b>" & FlushPct & "%.</b><br><br>" & _
"There are <b>" & Func & " </b> total functionals.<b> " & FuncComp & " </b> are indicated as complete. This is about <b>" & FuncPct & "%.</b><br><br>" & _
"There are <b>" & Spec & " </b> total specialties. <b>" & SpecComp & " </b> are indicated as complete. This is about <b>" & SpecPct & "%.</b>"
'Attachments
Attachment1 = "C:\Snapshots\Commissioning Status Report.snp"
Attachment2 = "C:\Snapshots\System Turnover Report Report.snp"
Attachment3 = "C:\Snapshots\Turnover Package Completion Graph.snp"
Attachment4 = "C:\Snapshots\Turnover Package Earned Completion Graph.snp"
' Open Outlook
Set MyOutlook = New Outlook.Application
' Set up the database and query connections
Set db = CurrentDb()
Set MailList = db.OpenRecordset("tblEMails")
' Creates the e-mail
Set MyMail = MyOutlook.CreateItem(olMailItem)
' This addresses it
MyMail.To = MyPrimaryAddress
MyMail.CC = CcPers
'This gives it a subject
MyMail.Subject = Subjectline$
'This gives it the body. HTMLBody allows the for the use of HTML tabs in the message body.
MyMail.HTMLBody = myBodyText
'This gives it the attachment
MyMail.Attachments.Add Attachment1
MyMail.Attachments.Add Attachment2
MyMail.Attachments.Add Attachment3
MyMail.Attachments.Add Attachment4
'This sends it!
MsgBox "Sending out Weekly Reports." & vbCrLf & vbLf & _
"Please Select OK when Prompted by Outlook." & vbCrLf & vbLf & _
"If Randall Does Not Recieve Reports from Your Site Today," & vbCrLf & vbLf & _
"Please be Prepared to Explain Why Not", vbExclamation, "Helpful Message"
MyMail.Send
'Cleanup
Set MyMail = Nothing
'Uncomment the next line if you want Outlook to shut down when its done.
'Otherwise, it will stay running.
'MyOutlook.Quit
Set MyOutlook = Nothing
MailList.Close
Set MailList = Nothing
db.Close
Set db = Nothing
DoCmd.SetWarnings True
'Update the Send Date so Email Doesn't get Sent Twice
DoCmd.SetWarnings False
DoCmd.RunSQL "UPDATE tblEmailSendDate SET tblEmailSendDate.SendDate = [Forms]![frmEmailRpts]![txtTodaysDate]" & _
"WHERE (((tblEmailSendDate.ID)=1)); "
DoCmd.SetWarnings True
Case Else:
DoCmd.Close acForm, "frmEmailRpts", acSaveNo
End Select
exitapp:
DoCmd.Close acForm, "frmEmailRpts", acSaveNo
Exit_EmailError:
Exit Sub
Err_EmailError:
MsgBox "There was a problem sending the weekly reports. Please try Again", vbInformation, "Error Message"
Resume Exit_EmailError
End Sub
