automatic email filter

Sub test()
Dim OutApp As Object
Dim OutMail As Object
Dim Rng1 As Range
Dim Rng2 As Range
Dim Cell1 As Range
Dim Cell2 As Range
Dim NumCols As Long
Dim LastRow As Long
Dim Cnt As Long
Dim Salutation As String
Dim BodyText As String
Dim SigString As String
Dim Signature As String
Dim Txt1 As String
Dim Txt2 As String
Dim HtmlBody As String
Dim TDOpenTag As String
Dim TDCloseTag As String

With ActiveSheet
  If .FilterMode Then .ShowAllData
  With .UsedRange
    LastRow = .Rows.Count + .Rows(1).Row - 1
  End With
End With

If LastRow = 1 Then
  MsgBox "No data is available!", vbExclamation
  Exit Sub
End If

Application.ScreenUpdating = False

Set OutlookApp = CreateObject("Outlook.Application")

Range("G1:G" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:="", CopyToRange:="", Unique:=True

Set Rng1 = Range("G2:G" & LastRow).SpecialCells(xlCellTypeVisible)

With Sheets("Sheet2")
  Salutation = .Range("A1").Value
  BodyText = .Range("A2").Value
End With

'Use the second SigString if you use Vista or Windows 7 operating system
'Change the .htm file name for the signature accordingly

' SigString = "C:\Documents and Settings\" & Environ("username") & "\Application Data\Microsoft\Signatures\Mysig.htm"

'SigString = "C:\Users\" & Environ("username") & "\AppData\Roaming\Microsoft\Signatures\Mysig.htm"


'If Dir(SigString) <> "" Then
' Signature = GetBoiler(SigString)
'Else
' Signature = ""
'End If

For Each Cell1 In Rng1
  With ActiveSheet.UsedRange
    .AutoFilter field:=7, Criteria1:=Cell1
    Set Rng2 = .Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
  End With
  Cnt = 0
  Txt1 = ""
  Txt2 = ""
  HtmlBody = ""
  NumCols = Rng2.Columns.Count
  For Each Cell2 In Rng2
    Cnt = Cnt + 1
    TDOpenTag = "{td style=""background-color: " & ShowHTMLcolor(Cell2) & ";""}"
    TDCloseTag = "{/td}"
    If Cell2.Font.Bold Then
      TDOpenTag = TDOpenTag & "{b}"
      TDCloseTag = "{/b}" & TDCloseTag
    End If
    Txt1 = Txt1 & TDOpenTag & Cell2.Text & TDCloseTag & vbNewLine
    If Cnt = NumCols Then
      Txt2 = Txt2 & "{tr}" & vbNewLine & Txt1 & "{/tr}" & vbNewLine
      Txt1 = ""
      Cnt = 0
    End If
  Next Cell2
  HtmlBody = "{HTML}"
  HtmlBody = HtmlBody & vbNewLine & "{BODY}"
  HtmlBody = HtmlBody & vbNewLine & "{p}" & Salutation & "{/p}"
  HtmlBody = HtmlBody & vbNewLine & "{p}" & BodyText & "{/p}"
  HtmlBody = HtmlBody & vbNewLine & "{table style=""text-align: left; width: 100%;"" border=""1"" cellpadding=""2"" cellspacing=""2""}"
  HtmlBody = HtmlBody & vbNewLine & "{tbody}"
  HtmlBody = HtmlBody & vbNewLine & Txt2
  HtmlBody = HtmlBody & "{/tbody}"
  HtmlBody = HtmlBody & vbNewLine & "{/table}"
  HtmlBody = HtmlBody & vbNewLine & "{/BODY}"
  HtmlBody = HtmlBody & vbNewLine & "{/HTML}"
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)


  On Error Resume Next
  With OutMail
    .To = Cell1
    '.CC = " 'change the email addresses accordingly
    .Subject = "status"
    .BodyFormat = 2
    .HtmlBody = HtmlBody & "{br}{br}" & Signature
    ' Save 'to drafts folder
    .Send
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
  End With
  Set Rng2 = Nothing
Next Cell1

ActiveSheet.AutoFilterMode = False

With Application
  .EnableEvents = True
  .ScreenUpdating = True
End With


Set OutMail = Nothing
Set OutApp = Nothing
End Sub
'Function ShowHTMLcolor(xcell) As String
'David McRitchie
'Dim xColor As String
'xColor = Right("000000" & Hex(xcell.Interior.Color), 6)
'ShowHTMLcolor = "#" & Right(xColor, 2) & Mid(xColor, 3, 2) _
'& Left(xColor, 2)
'End Function
'Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
' Dim fso As Object
'Dim ts As Object
' Set fso = CreateObject("Scripting.FileSystemObject")
'Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
'GetBoiler = ts.readall
'ts.Close
' End Function