Contour // VBA // Countour same Color as

Hi.

Declare a new object variable and Set it while declaring

     Dim col As New Color

If the shape has a uniform fill then copy assign the color to the new object variable ( col )

     If s.Fill.Type = cdrUniformFill Then col.CopyAssign s.Fill.UniformColor 'added

Assign it below to the correct shape in the shaperange. The first shape in the shaperange is always your contour when you use the separate method which returns a shaperange:

     sr.Shapes.First.Fill.ApplyUniformFill col 'added

All together like this:

Sub TxtThickn() ' outer contour to thicken text .007

ActiveDocument.BeginCommandGroup "my crunchy macro"

    Dim s As Shape, e As Effect, sr As ShapeRange
    Dim dVal#
    Dim colOutline As Color, colFill1 As Color, colFill2 As Color
    Dim col As New Color 'added

  
    Set s = ActiveShape
    If s Is Nothing Then Exit Sub
 
    dVal = 0.007
    Set colOutline = CreateCMYKColor(0, 0, 0, 100)
    Set colFill1 = CreateCMYKColor(80, 40, 24, 100)
    Set colFill2 = CreateCMYKColor(80, 40, 24, 100)
   
    If s.Fill.Type = cdrUniformFill Then col.CopyAssign s.Fill.UniformColor 'added
 
    Set e = s.CreateContour
    With e.Contour
        .Direction = cdrContourOutside
        .Offset = dVal
        .Steps = 1
        .OutlineColor = colOutline
        .FillColor = colFill1
        .FillColorTo = colFill2
        .SpacingAcceleration = 0
        .ColorAcceleration = 0
        .EndCapType = cdrContourRoundCap
        .CornerType = cdrContourCornerRound
        .MiterLimit = 15
    End With
 
    Set sr = e.Separate
    sr.Shapes.Last.Delete 'added
    sr.Shapes.First.Fill.ApplyUniformFill col 'added
  
    ActiveDocument.EndCommandGroup
  
    saveFormPos True
   
End Sub