Option Explicit
Public gvFile
Public gcolEmails As New Collection
Public Const kTempDir = "c:\temp\"
Sub FilterRecs()
Range("A1").Select
ActiveSheet.UsedRange.Select
Selection.AutoFilter
ActiveSheet.UsedRange.AutoFilter Field:=2, Criteria1:="Arkham"
End Sub
Sub CopyData2Send()
' ExportData2eMail Macro
Dim wsNew As Worksheet
gvFile = "C:\temp\file1email.xlsx"
ActiveSheet.UsedRange.Select
Selection.Copy
Sheets.Add After:=ActiveSheet
Set wsNew = ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Range("A1").Select
wsNew.Select
wsNew.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=gvFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False ', ConflictResolution:=True
Application.DisplayAlerts = True
ActiveWindow.Close
Set wsNew = Nothing
End Sub
Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, ByVal pvCC, Optional ByVal pvFile) As Boolean
Dim oMail As Outlook.MailItem
Dim oApp As Outlook.Application
On Error GoTo ErrMail
'NOTE : YOU MUST HAVE THE OUTLOOK X.x Object Library REFERENCE CHECKED IN VBE; ctl-G, 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
.CC = pvCC
.Subject = pvSubj
If Not IsMissing(pvFile) Then .Attachments.Add pvFile, olByValue, 1
.HTMLBody = pvBody
'=RangetoHTML(rng) 'vBody will not paste XL range in the format
If Not IsNull(pvBody) Then .Body = pvBody
.Display True
'.Send
End With
Send1Email = True
endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume endit
End Function
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 Sub collectEmailList()
Dim vTo, vWord, vName, vEmail, vReg, vCC
On Error GoTo errAdd
MakeDir kTempDir
Set gcolEmails = New Collection
Sheets("Customer").Activate 'goto the email list
'cycle thru the list of email addrs
Range("A2").Select
While ActiveCell.Value <> ""
vReg = "r" & ActiveCell.Offset(0, 0).Value
If Right(vReg, 1) = "?" Then vReg = Left(vReg, Len(vReg) - 1)
vEmail = ActiveCell.Offset(0, 1).Value
vCC = ActiveCell.Offset(0, 2).Value
vWord = vReg & "~" & vEmail & "~" & vCC
gcolEmails.Add vWord, vReg 'add email to collection
ActiveCell.Offset(1, 0).Select 'next row
Wend
'free memory
'Set gcolEmails = Nothing
Exit Sub
errAdd:
If Err = 457 Then Resume Next 'prevent error for dupes
MsgBox Err.Description, , Err
End Sub
'convert the uniq collection into a list for email
Public Function BuildBulkLIst()
Dim i As Integer
Dim vEList
For i = 1 To gcolEmails.Count
vEList = vEList & gcolEmails(i) & ";"
Next
BuildBulkLIst = vEList
MsgBox vEList
End Function
Private Function split1UserEmail(ByVal pvWord, pvReg, pvEmail, pvCC)
Dim vEmail
Dim i As Integer
i = InStr(pvWord, "~")
pvReg = Left(pvWord, i - 1)
pvReg = Mid(pvReg, 2)
pvWord = Mid(pvWord, i + 1)
i = InStr(pvWord, "~")
pvEmail = Left(pvWord, i - 1)
pvCC = Mid(pvWord, i + 1)
split1UserEmail = pvReg
End Function
Private Function get1UserEmailViaName(ByVal pvName)
Dim vEmail, vWord
vWord = gcolEmails(pvName)
'pvName = Mid(vWord, InStr(vWord, "~") + 1)
vEmail = Mid(vWord, InStr(vWord, "~") + 1)
get1UserEmailViaName = vEmail
End Function
Public Sub SendAllEmails()
Dim i As Integer
Dim vEmail, vReg, vCC
MsgBox "Have Outlook open."
SetWarnings False
collectEmailList 'gather all emails
For i = 1 To gcolEmails.Count
vReg = ""
Call split1UserEmail(gcolEmails(i), vReg, vEmail, vCC)
'Debug.Print "Dear " & vName & ", via: " & vEmail
Filter1Name vReg, vEmail, vCC
Next
SetWarnings True
End Sub
Sub Filter1Name(ByVal pvReg, ByVal pvTo, ByVal pvCC)
Dim rng As Range
Dim r As Long
Dim vSubj, vBody, vFile
Dim wbTarg As Workbook
Sheets("Data").Activate
Range("A1").Select
Set rng = ActiveSheet.UsedRange
Selection.AutoFilter
rng.AutoFilter Field:=1, Criteria1:=pvReg
'select FILTERED recs only
rng.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'FAIL:
'vBody = PasteClipboardText() 'requires FM20.dll as a reference.
Workbooks.Add
Set wbTarg = ActiveWorkbook
ActiveCell.PasteSpecial xlPasteValues
r = rng.Cells.SpecialCells(xlCellTypeVisible).Rows.Count
vFile = kTempDir & pvReg & "_Data.xls"
KillFile vFile
wbTarg.SaveAs vFile, 39
wbTarg.Close True
If r > 1 Then 'dont send if no data
'--------- pastge to new workBOOK
'Selection.Copy
'Workbooks.Add
'ActiveSheet.Paste
'Application.CutCopyMode = False
'ActiveWorkbook.SaveAs Filename:=vFILE, FileFormat:=xlExcel8, CreateBackup:=False
'ActiveWindow.Close
'--------PASTE DATA TO NEW SHEET
'Sheets.Add After:=ActiveSheet
'ActiveCell.PasteSpecial xlPasteAll
'ActiveSheet.Name = pvName
'EMAIL THE DATA
vSubj = "Dear " & pvReg & vbCrLf & "here is your data:"
'format fail: vBody = PasteClipboardText()
vBody = "data attached"
Debug.Print "send " & pvReg, pvTo
Send1Email pvTo, vSubj, vBody, pvCC, vFile
End If
Sheets("Data").Activate
Application.CutCopyMode = False
Selection.AutoFilter 'filter off
End Sub
'Function PasteClipboardText()
''FM20.dll
' 'reference to Microsoft Forms 2.0 Object Library. If its not listed, add C:\Windows\System32\FM20.dll or C:\Windows\FM20.dll as a reference.
'Dim DataObj As MSForms.DataObject
'Set DataObj = New MSForms.DataObject
'
'DataObj.GetFromClipboard
'PasteClipboardText = DataObj.GetText(1)
'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
Private Sub SetWarnings(ByVal pbOn As Boolean)
Application.DisplayAlerts = pbOn 'turn off sheet compatability msg
Application.EnableEvents = pbOn
Application.ScreenUpdating = pbOn
End Sub
Public Sub MakeDir(ByVal pvDir)
Dim fso
On Error GoTo errMake
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(pvDir) Then fso.CreateFolder pvDir 'MkDir pvDir
Set fso = Nothing
Exit Sub
errMake:
'MsgBox Err.Description & vbCrLf & pvDir, , "MakeDir(): " & Err
Set fso = Nothing
End Sub
