Public gcolPmts As Collection
Public gvPmt
'---------------------
Sub SendAllPayments()
'---------------------
Dim iRows As Long, iFldNum As Long, iResultOFF As Long
Dim vTxt, vEmail, vBody, vPmt, vSubj, vFile
Dim i As Integer
vEmail = "w.e.coyote@acme.com"
'load payment vals
LoadPmtVals
Range("A1").Select
For i = 1 To gcolPmts.Count
gvPmt = gcolPmts(i)
ActiveSheet.Range("A1").AutoFilter Field:=5, Criteria1:=gvPmt 'filter results
'save payment data
vFile = SaveFoundData(gvPmt)
'send email
vSubj = "subject: " & gvPmt
vBody = "This is the body of the email"
Send1Email vEmail, vSubj, vBody, vFile
'remove filter
ActiveSheet.Range("A1").AutoFilter
Next
Set gcolPmts = Nothing
End Sub
Private Sub LoadPmtVals()
On Error Resume Next
Set gcolPmts = New Collection
Range("E2").Select
While ActiveCell.Value <> ""
gvPmt = ActiveCell.Value
gcolPmts.Add gvPmt, gvPmt
ActiveCell.Offset(1, 0).Select 'next row
Wend
End Sub
'---------------------
Private Function SaveFoundData(ByVal pvPmtNum)
'---------------------
Dim vFile, vDir
vDir = getMyDocs()
vFile = vDir & pvPmtNum & ".xlsx"
Range("A1").Select
ActiveSheet.UsedRange.Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
KillFile vFile
ActiveWorkbook.SaveAs Filename:=vFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
SaveFoundData = vFile 'return the file to email
End Function
Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional ByVal pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK REFERENCE CHECKED IN VBE; Alt-F11, menu,tools, references, Microsoft Outlook XX Object library
Set oApp = GetApplication("Outlook.Application") 'it may be open already so use this
'Set oApp = CreateObject("Outlook.Application") 'not this
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.To = pvTo
.Subject = pvSubj
If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
.HTMLBody = pvBody
'If Not IsNull(pvBody) Then .Body = pvBody
.Display True 'show user but dont send yet
'.Send 'send now
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
'DoCmd.OutputTo acOutputReport, "rMyReport", acFormatPDF, vFile
End Function
Private Function GetApplication(className As String) As Object
' function to encapsulate the instantiation of an application object
Dim theApp As Object
On Error Resume Next
Set theApp = GetObject(, className)
If Err.Number <> 0 Then
MsgBox "Unable to Get" & className & ", attempting to CreateObject"
Set theApp = CreateObject(className)
End If
If theApp Is Nothing Then
Err.Raise Err.Number, Err.Source, "Unable to Get or Create the " & className & "!"
Set GetApplication = Nothing
End If
'MsgBox "Successfully got a handle on Outlook Application, returning to caller"
Set GetApplication = theApp
End Function
Public Function getMyDocs()
getMyDocs = Environ$("USERPROFILE") & "\Documents\"
End Function
Public Sub KillFile(ByVal pvFile)
Dim fso
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
'FileReadOnly pvFile, False
fso.DeleteFile pvFile
Set fso = Nothing
End Sub