Results 1 to 2 of 2

Thread: MS Project 2007 Emailing Macro

  1. #1
    Join Date
    Dec 2011
    Posts
    2

    MS Project 2007 Emailing Macro

    I have put together a macro in MS Project 2007 that sends resources an email with an Excel file attached that lists all of their tasks that are due according to the status date.

    However I would like to only include tasks in each email whose predecessor tasks are complete.

    This is probably just a few lines of an IF-THEN statement that needs to be added somewhere in my macro.

    Below is my macro, please let me know what I need to add.

    ' Emailing Daily Status out to addresses

    Public Sub Email_Task_Report()

    Dim sEmailMessage As String
    Dim sfilename As String
    Dim sResourceGroup As String
    Dim sEmails As String
    Dim oResource As Resource
    Dim oAssignment As Assignment
    Dim oTask As Task
    Dim dTodayDate As Date
    dTodayDate = Now()
    Dim dFriday As Date
    dFriday = Now + (7 - Weekday(Now)) 'actually returns Sat
    Dim oTaskFound As Boolean

    Set proProj = ActiveProject
    On Error Resume Next

    ResourcePromptLine:
    sResourceGroup = InputBox("Enter Resource Group", "Resource Group", "")

    If Len(sResourceGroup) = 0 Then
    spromptanswer = MsgBox("Please Enter a resource group", vbOKCancel)
    If spromptanswer = vbOK Then
    GoTo ResourcePromptLine
    Else
    Exit Sub
    End If
    End If


    sEmails = MsgBox("Do you want to send emails?", vbYesNo)
    If sEmails = "6" Then

    frmGetMessage.Show
    sEmailMessage = frmGetMessage.txtMessage.Text

    End If


    ''''''
    If oExcelApplication Is Nothing Then
    Set oExcelApplication = CreateObject("Excel.Application") 'Start new instance
    If oExcelApplication Is Nothing Then
    MsgBox "Can't Find Excel, please try again.", vbCritical
    End 'Stop, can't proceed without Excel
    End If
    oExcelApplication.Visible = True
    Else
    Set oexcelrange = Nothing
    Set oExcelApplication = Nothing
    Set oExcelWorkbook = Nothing
    Set oExcelApplication = CreateObject("Excel.Application") ' Start New Instance
    If oExcelApplication Is Nothing Then
    MsgBox "Can't Find Excel, please try again.", vbCritical
    End 'Stop, can't proceed without Excel
    End If
    oExcelApplication.Visible = True
    End If
    ''''''


    Application.ActivateMicrosoftApp pjMicrosoftExcel

    'Create new Excel file. Add worksheets and name all of them (10)
    On Error Resume Next

    For Each oResource In ActiveProject.Resources

    If Not (oResource Is Nothing) Then
    If oResource.Group = sResourceGroup Then
    Set oExcelWorkbook = oExcelApplication.Workbooks.Add
    oExcelApplication.Calculation = gCnxlCalculationManual ' Set Manual Calculation

    With oExcelWorkbook
    .Worksheets(1).Name = "Task Report"
    .Worksheets(1).Activate
    Set oexcelrange = .Worksheets(1).Range("A1")

    With oexcelrange
    .Range("A1").ColumnWidth = 20
    .Range("B1").ColumnWidth = 18
    .Range("C1").ColumnWidth = 55
    .Range("D:E").ColumnWidth = 20
    .Range("F:G").ColumnWidth = 14
    .Range("H:H").ColumnWidth = 30
    .Range("B7:B50").EntireColumn.NumberFormat = "0%"
    .Range("E1").EntireColumn.NumberFormat = "#,##0"
    .Range("F1").EntireColumn.NumberFormat = "MM/DD/YYYY"
    .Range("G1").EntireColumn.NumberFormat = "MM/DD/YYYY"
    With .Range("A6:H6").Interior
    .ColorIndex = 35
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    End With
    With .Range("A7:B50").Interior
    .ColorIndex = 48
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    End With
    With .Range("F7:G50").Interior
    .ColorIndex = 48
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    End With
    End With ' oExcelRange

    'Worksheet headings and other details formatting
    oexcelrange.Range("A1").Formula = "Daily Status Report"
    oexcelrange.Range("A2").Formula = "Current Date"
    oexcelrange.Range("B2").Formula = Now()
    oexcelrange.Range("A3").Formula = "Resource"
    oexcelrange.Range("B3").Formula = oResource.Name

    With oexcelrange.Range("A1:A3")
    .Font.Bold = True
    .Font.Size = 12
    End With

    Set oexcelrange = oexcelrange.Range("A6")
    End With

    'Gathering information for each task below
    'Add headers for base measures of task, date and hours worked.Format the column headings
    oexcelrange.Range("A1:H1") = Array("Unique ID", _
    "% Complete", _
    "Task Name/Description", _
    "Team Owner", _
    "Remaining Work (hrs)", _
    "Baseline Start", _
    "Baseline Finish", _
    "Notes")
    Set oexcelrange = oexcelrange.Offset(1, 0)


    oTaskFound = False

    'Add headers for base measures of task, date and hours worked.Format the column headings
    For Each oAssignment In oResource.Assignments
    If oAssignment.RemainingWork > 0 And oAssignment.Start <= dTodayDate Then
    oexcelrange.Range("A1:H1") = Array(oAssignment.TaskUniqueID, _
    (oAssignment.PercentWorkComplete / 100), _
    oAssignment.TaskName, _
    ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqueID).Text1, _
    (oAssignment.RemainingWork / 60), _
    ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqueID).BaselineStart, _
    ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqueID).BaselineFinish, _
    ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqueID).Notes)
    Set oexcelrange = oexcelrange.Offset(1, 0)
    oTaskFound = True
    End If
    Next oAssignment


    '''''''Make sure you add/have a temp folder on your hard drive or else it wont save''''''''''''
    Application.ScreenUpdating = True
    sfiletitle = oResource.Name & "_" & format(Date, "mmm_dd_yyyy") & ".xls"
    sfilename = "C:\temp\" & sfiletitle
    ActiveWorkbook.SaveAs FileName:=sfilename
    ActiveWorkbook.Close


    ' Emailing Outlook 2010
    If sEmails = "6" And oTaskFound = True Then

    Dim OutApp As Object
    Dim OutMail As Object
    Dim SenderEmailAddress As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
    .SentOnBehalfOfName = "PROPELCutover@emc.com"
    .To = oResource.EMailAddress
    '.CC = "propelcutover@emc.com" & ";" & "propeldeploymentcutover@emc.com"
    .BCC = ""
    .Subject = "Daily Cutover Tasks;" & " " & format(Date, "mmm dd, yyyy")
    .Body = "Attached are your cutover tasks for today" & " " & format(Date, "mmm dd, yyyy")
    .Attachments.Add ("C:\temp\" & sfiletitle)
    .Send
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

    End If
    '''End Emailing


    End If

    Else
    Exit For

    End If

    Next oResource

    Call MsgBox("Compiled and Emailed Tasks")


    End Sub

  2. #2
    Join Date
    Dec 2011
    Posts
    2

    Re: MS Project 2007 Emailing Macro

    I believe this extra condition should be added into this loop:

    'Add headers for base measures of task, date and hours worked.Format the column headings
    For Each oAssignment In oResource.Assignments
    If oAssignment.RemainingWork > 0 And oAssignment.Start <= dTodayDate Then
    oexcelrange.Range("A1:H1") = Array(oAssignment.TaskUniqueID, _
    (oAssignment.PercentWorkComplete / 100), _
    oAssignment.TaskName, _
    ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqueID).Text1, _
    (oAssignment.RemainingWork / 60), _
    ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqueID).BaselineStart, _
    ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqueID).BaselineFinish, _
    ActiveProject.Tasks.UniqueID(oAssignment.TaskUniqueID).Notes)
    Set oexcelrange = oexcelrange.Offset(1, 0)
    oTaskFound = True
    End If
    Next oAssignment

Similar Threads

  1. MS Project 2007 - macro buttons grayed out
    By jbarbara11@yahoo.com in forum Microsoft Project
    Replies: 1
    Last Post: 10-12-2011, 02:45 AM
  2. Need help with MS Project Macro!!!
    By meatloaf_o in forum Windows Software
    Replies: 1
    Last Post: 02-12-2011, 06:32 PM
  3. Replies: 3
    Last Post: 10-11-2010, 07:27 PM
  4. MS Project export to PDF via Macro
    By rosscosack in forum Windows Software
    Replies: 1
    Last Post: 20-05-2010, 12:56 AM
  5. Project 2007 Client Cannot Connect To Project Server 2003
    By PARRISH in forum Microsoft Project
    Replies: 1
    Last Post: 21-02-2007, 10:24 PM

Tags for this Thread

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Page generated in 1,711,688,339.29406 seconds with 17 queries