Forum Discussion

Klausbdl's avatar
Klausbdl
Copper Contributor
Jan 20, 2025

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

No RepliesBe the first to reply

Resources