Изменение цвета строки фона в соответствии с уровнями задач в MS Project VBA

Привет, я пытался выяснить код, чтобы покрасить разные строки в зависимости от их уровня задачи. Я новичок в VBA в MS Project. У меня есть код, который я нашел в Интернете, но он окрашивает только текст в столбце задачи.

Sub ColorFormatOL()
Dim t As Task
Dim i As Integer
SelectTaskColumn
  i = 0
For Each t In ActiveSelection.Tasks
   If Not t Is Nothing Then
       i = i + 1
   If t.Summary Then
       SelectRow row:=i, Columrowrelative:=False
       Select Case t.OutlineLevel
           Case 1
               FontEx Color:=pjRed
           Case 2
               FontEx Color:=pjGreen
           Case 3
               FontEx Color:=pjTeal
        End Select
    End If
  End If
 Next t
End Sub

vba ms-project
person dhruva_04    schedule 01.07.2015    source источник

Ответы (2)


arrow_upward
3
arrow_downward

Я немного поигрался с кодом и нашел ответ: D

Sub ColorFormatOL()
Dim t As Task
Dim i As Integer

i = 1
For Each t In ActiveProject.Tasks


       SelectRow row:=i, rowrelative:=False

       Select Case t.OutlineLevel
           Case 1
           Font32Ex CellColor:=&HB37F15
           Case 2
           Font32Ex CellColor:=&HD6982E
           Case 3
           Font32Ex CellColor:=&HF6BE41
           Case 4
           Font32Ex CellColor:=&HF7D577


       End Select

i = i + 1
Next t
End Sub
person dhruva_04    schedule 01.07.2015

arrow_upward
0
arrow_downward

Вот макрос, который я использую:

Public Sub FormatOutline_Blue()
Call FormatOutlineLevels(9851951, 14396046, 15189684, 14084850, 15791610, 16777215, 16777215, 16777215, 16777215, 16777215)

End Sub

Public Sub FormatOutline_Green()
Call FormatOutlineLevels(4697456, 9293992, 11788485, 14084850, 15791610, 16777215, 16777215, 16777215, 16777215, 16777215)
End Sub

Public Sub FormatOutline_Aqua()
Call FormatOutlineLevels(13998939, 15057820, 15652797, 14084850, 15791610, 16777215, 16777215, 16777215, 16777215, 16777215)

End Sub

Private Sub FormatOutlineLevels(level1 As String, level2 As String, level3 As String, level4 As String, level5 As String, level6 As String, level7 As String, level8 As String, level9 As String, Optional font1 As String)
'Format the outline levels. The macro filters to summary tasks, selects the entire sheet, shows outline level x, formats entire sheet.
'Next, it shows one outline level up (x - 1), formats entire sheet.
'Last, it removes formatting from inactive summary tasks.

'Prepare
    On Error GoTo ErrorHandler
    SaveOriginalSettings
    OutlineShowAllTasks
    FilterApply Name:="Summary Tasks"
    SelectSheet

'Format all rows, starting with this outline level
    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel9
        Font32Ex CellColor:=level9

    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel8
        Font32Ex CellColor:=level8

    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel7
        Font32Ex CellColor:=level7

    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel6
        Font32Ex CellColor:=level6

    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel5
        Font32Ex CellColor:=level5

    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel4
        Font32Ex CellColor:=level4

    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel3
        Font32Ex CellColor:=level3

    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel2
        Font32Ex CellColor:=level2

    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel1
        Font32Ex CellColor:=level1
        If Len(font1) > 0 Then Font32Ex Color:=font1
'Remove formatting from inactive summary tasks
    ScreenUpdating = False
    OutlineShowAllTasks
    FilterEdit Name:="Inactive Summary Tasks", TaskFilter:=True, Create:=True, OverwriteExisting:=True, FieldName:="Summary", test:="equals", Value:="yes", ShowInMenu:=False, ShowSummaryTasks:=False
    FilterEdit Name:="Inactive Summary Tasks", TaskFilter:=True, FieldName:="", NewFieldName:="Active", test:="equals", Value:="no", Operation:="And", ShowSummaryTasks:=False
    FilterApply Name:="Inactive Summary Tasks"
    SelectSheet
    EditClearFormats
    ScreenUpdating = True

'Clean up
    FilterApply Name:="All Tasks"
    RestoreOriginalSettings
    CascadeOutline

Exit Sub
ErrorHandler:
    HandlingErrors

End Sub

Public Sub CascadeOutline()

On Error Resume Next
    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel9
    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel8
    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel7
    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel6
    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel5
    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel4
    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel3
    OutlineShowTasks OutlineNumber:=pjTaskOutlineShowLevel2
    SelectRow Row:=1, rowrelative:=False
On Error GoTo 0

End Sub

Private Sub HandlingErrors()
    Select Case Err.Number
        Case 91
            MsgBox "The first row you've selected is missing a task name.", vbCritical
        Case 424
            MsgBox "The row you've selected may be missing a task name.", vbCritical
        Case 1100
            MsgBox "This view and table combination doesn't have Outlines available. Try going to " & _
                        "View >> Data Group: Outline. If Outline is grayed out, try clicking on the task name." & _
                        vbNewLine & vbNewLine & "This error usually happens when the timeline or details pane is selected.", _
                    vbCritical, "Oops! Outline is Unavailable"
        Case 1101
            MsgBox "Try using this macro on the Task Sheet view." & vbNewLine & vbNewLine & _
                "Error#" & Str(Err.Number) & " - " & Err.Description, vbCritical, "Invalid View"
        Case Else
            MsgBox "Error#" & Str(Err.Number) & " - " & Err.Description & vbNewLine _
                    & "Line: " & Erl & vbNewLine _
                    , vbCritical
    End Select
End Sub
person Hey Romey    schedule 17.03.2016