Wrox Programmer Forums
Go Back   Wrox Programmer Forums > Microsoft Office > Excel VBA > Excel VBA
|
Excel VBA Discuss using VBA for Excel programming.
Welcome to the p2p.wrox.com Forums.

You are currently viewing the Excel VBA section of the Wrox Programmer to Programmer discussions. This is a community of software programmers and website developers including Wrox book authors and readers. New member registration was closed in 2019. New posts were shut off and the site was archived into this static format as of October 1, 2020. If you require technical support for a Wrox book please contact http://hub.wiley.com
 
Old May 21st, 2007, 09:45 PM
Authorized User
 
Join Date: Mar 2007
Posts: 11
Thanks: 0
Thanked 0 Times in 0 Posts
Default attach excel content to emails,based on criteria

Hi,

I need help on the following desperately
I need to write a macro to send out 2 types of email via excel 2000 for those (DEPENDING ON their Action_Item_Status
1)action items with Action_Item_Status='Overdue', (over due email)
1)action items with Action_Item_Status='Due Soon', (reminder email)

Action_Status_As_Of_Today can have these values:-Done,Overdue,Due Soon,Not Due Yet

My datasheet contains the following columns:-
--------------------------------------------
Action_source(filename-worksheet_name) 'column A'
Status_Item 'column B'
Status_Item_details 'column C'
Action_Due_date 'column D'
Action_Party 'column E'
Action_Party_Email 'column F'
Classification_of_Status 'column G'
Action_Status 'column H'
Action_Status_As_Of_Today 'column I'

The 'Action_Party_Email' can be duplicated.(Ie. the same email address can be found in different 'Action_Item_No' records.

In each email, i need to also include the data found in 'Status_Item' & "Action_Due_date" columns.

Please kindly help.Thanks alot in advanced:)

Below is my sample code
==========================

Sub Button1_Click()
'
' Button1_Click Macro
' Macro recorded 5/22/2007 by Registered User
'
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim rng As Range
    Dim Ash As Worksheet

    Set Ash = ActiveSheet
    On Error GoTo cleanup
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    For Each cell In Ash.Columns("F").Cells.SpecialCells(xlCellTypeCons tants)
        If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0,1).Value) = "Overdue" Then
            Ash.Range("A1:S100").AutoFilter Field:=6, Criteria1:=cell.Value

            With Ash.AutoFilter.Range
                On Error Resume Next
                Set rng = .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
            End With

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Updates"
                .HTMLBody = RangetoHTML(rng)
                .Send

                '.Display

            End With
            On Error GoTo 0

            Set OutMail = Nothing
            Ash.AutoFilterMode = False
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Function RangetoHTML(rng As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function








Similar Threads
Thread Thread Starter Forum Replies Last Post
sum group values based on cell criteria darkdestroyer Excel VBA 1 January 9th, 2008 09:13 PM
'Search Form' based on criteria Grafixx01 Access 7 May 4th, 2007 09:39 AM
select rows based on a criteria and paste ashu_gupta75 Excel VBA 2 July 30th, 2004 01:32 AM
Report Heading Based On Selection Criteria Fo CloudNine Access 5 March 4th, 2004 08:09 PM
HTML content in Outlook Emails generated by Access Justine Access VBA 0 January 13th, 2004 04:47 PM





Powered by vBulletin®
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright (c) 2020 John Wiley & Sons, Inc.