Forum Discussion
MS Project Professional - VBA Color row based on field value
I have a master project with code below. What it does it: whenever I change the field Text12 to "OK" or "NOK" (and other words) it colors the whole row with a specific color (see Module1). It works great at a master project level, that is, in tasks directly in this master project.
(How it works: It checks for changes in the Text12 column and sets a bool to true. Then, in Proj_Change, it applies the colors to the correct task row)
However, it doesn't work at a Subproject level. I've added Debug.Print to each sub, and when I edit a Subproject's task, it only calls up to App_ProjectBeforeTaskChange. Is there a way to solve this? Detect changes in Subprojects and color the rows?
I've tried running the ApplyColor sub directly from the App_ProjectBeforeTaskChange sub, but VBA says "this method is not available in this situation". Also tried using a Timer, didn't work, same error.
(PS: I also posted this on Stack Overflow but I couldnt get help, so I'm posting this on other forums)
ThisProject:
Private Sub Project_Open(ByVal pj As Project)
InitializeEventHandler
End Sub
Module1: Regular Module
Option Explicit
Dim EventHandler As EventClassModule
Sub InitializeEventHandler()
Set EventHandler = New EventClassModule
Set EventHandler.App = Application
Set EventHandler.proj = Application.ActiveProject
End Sub
Sub ApplyColor()
Dim t As Task
Set t = EventHandler.ChangedTask
If Not t Is Nothing Then
SelectRow Row:=t.UniqueID, RowRelative:=False
Select Case EventHandler.NewValue
Case "OK" Font32Ex CellColor:=14282722 'green
Case "NOK" Font32Ex CellColor:=11324407 'red
Case "PROGRESS" Font32Ex CellColor:=65535 'blue
Case "REPEAT" Font32Ex CellColor:=15652797 'yellow
Case Else Font32Ex CellColor:=-16777216 'no color
End Select
End If
End Sub
EventClassModule: ClassModule
Public WithEvents App As Application
Public WithEvents proj As Project
Public NewValue As String
Public ChangePending As Boolean
Public ChangedTask As Task
Private Sub App_ProjectBeforeTaskChange(ByVal tsk As Task, ByVal Field As PjField, ByVal NewVal As Variant, Cancel As Boolean)
If Field = 188743998 Then 'Custom field Text12
Set ChangedTask = tsk NewValue = NewVal
ChangePending = True
End If End
Sub Private
Sub Proj_Change(ByVal pj As Project)
If ChangePending Then ApplyColor
ChangePending = False
End If
End Sub