Fill Color

[magnel]

Hello,

I am using PPT 2010, and I am trying to get a code which allows to fill defined rgb color in an autoshapes as well as tables.
After lots of searching and trying to merge many type of codes have come till this point, but still there is something that's giving error while compiling vba code.

Please can someone fill in the missing puzzle.


Sub Color()
Dim iCol As Integer
Dim iRow As Integer
Dim otbl As Shape
Dim oshpR As ShapeRange
ActiveWindow.Selection.ShapeRange.Select
On Error GoTo err

With ActiveWindow.Selection.ShapeRange 'Make use of the new object to access Glow for text
.Fill.Transparency = 0.25
.Fill.Visible = msoTrue
.Fill.ForeColor.rgb = rgb(205, 120, 35)
.Fill.BackColor.rgb = rgb(255, 255, 255)
.Fill.Patterned msoPatternLightUpwardDiagonal
End With
Exit Sub
err:
MsgBox "Select shapes with text!"


Set otbl = ActiveWindow.Selection.ShapeRange(1)
If otbl.HasTable Then
For iRow = 1 To otbl.Table.Rows.Count
For iCol = 1 To otbl.Table.Columns.Count
If otbl.Table.Cell(iRow, iCol).Selected Then
otbl.Table.Cell(iRow, iCol).Shape.TextFrame2.TextRange.Fill.Transparency = 0.25
otbl.Table.Cell(iRow, iCol).Shape.TextFrame2.TextRange.Fill.Visible = msoTrue
otbl.Table.Cell(iRow, iCol).Shape.TextFrame2.TextRange.Fill.ForeColor.rgb = rgb(205, 120, 35)
otbl.Table.Cell(iRow, iCol).Shape.TextFrame2.TextRange.Fill.BackColor.rgb = rgb(255, 255, 255)
otbl.Table.Cell(iRow, iCol).Shape.TextFrame2.TextRange.Fill.Patterned msoPatternLightUpwardDiagonal
End If
Next iCol
Next iRow
End If
End Sub


Thanks

[Paul_Hossler]

Use the [#] icon and paste the code between the tags to make if look pretty


.Fill is a property of a Shape object, not a TextRange object.


This compiles at least




Option Explicit

Sub Color()
Dim iCol As Integer
Dim iRow As Integer
Dim otbl As Shape
Dim oshpR As ShapeRange

ActiveWindow.Selection.ShapeRange.Select
On Error GoTo err

With ActiveWindow.Selection.ShapeRange 'Make use of the new object to access Glow for text
.Fill.Transparency = 0.25
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(205, 120, 35)
.Fill.BackColor.RGB = RGB(255, 255, 255)
.Fill.Patterned msoPatternLightUpwardDiagonal
End With

Exit Sub
err:
MsgBox "Select shapes with text!"

Set otbl = ActiveWindow.Selection.ShapeRange(1)
If otbl.HasTable Then
For iRow = 1 To otbl.Table.Rows.Count
For iCol = 1 To otbl.Table.Columns.Count
If otbl.Table.Cell(iRow, iCol).Selected Then
otbl.Table.Cell(iRow, iCol).Shape.Fill.Transparency = 0.25
otbl.Table.Cell(iRow, iCol).Shape.Fill.Visible = msoTrue
otbl.Table.Cell(iRow, iCol).Shape.Fill.ForeColor.RGB = RGB(205, 120, 35)
otbl.Table.Cell(iRow, iCol).Shape.Fill.BackColor.RGB = RGB(255, 255, 255)
otbl.Table.Cell(iRow, iCol).Shape.Fill.Patterned msoPatternLightUpwardDiagonal
End If
Next iCol
Next iRow
End If
End Sub

[magnel]

Thanks Paul for your reply. Have modified the code a little bit.

Sub Color()
Dim iCol As Integer
Dim iRow As Integer
Dim otbl As Shape
Dim oshpR As ShapeRange

ActiveWindow.Selection.ShapeRange.Select
On Error GoTo err

With ActiveWindow.Selection.ShapeRange.Fill
.Transparency = 0.25
.Visible = msoTrue
.ForeColor.rgb = rgb(205, 120, 35)
.BackColor.rgb = rgb(255, 255, 255)
.Patterned msoPatternLightUpwardDiagonal
End With

Exit Sub
err:
MsgBox "Select shapes with text!"

Set otbl = ActiveWindow.Selection.ShapeRange(1)
If otbl.HasTable Then
For iRow = 1 To otbl.Table.Rows.Count
For iCol = 1 To otbl.Table.Columns.Count
If otbl.Table.Cell(iRow, iCol).Selected Then
With otbl.Table.Cell(iRow, iCol).Shape.Fill
.Transparency = 0.25
.Visible = msoTrue
.ForeColor.rgb = rgb(205, 120, 35)
.BackColor.rgb = rgb(255, 255, 255)
.Patterned msoPatternLightUpwardDiagonal
End With
End If
Next iCol
Next iRow
End If
End Sub

Still it does not give the required output. The fill applies to the entire table and not just to the selected cells in the table. Please can you check the table section of the code.

[Paul_Hossler]

I think the logic is a little out of order. If the selection is in a table then the 'Exit Sub' is executed after filling the table


Maybe something like this then ...



Option Explicit
Sub Color_1()
Dim iCol As Long, iRow As Long
Dim oShapeRange As ShapeRange

On Error GoTo NothingSelected
Set oShapeRange = ActiveWindow.Selection.ShapeRange
On Error GoTo 0

With oShapeRange
If .HasTable Then
For iRow = 1 To .Table.Rows.Count
For iCol = 1 To .Table.Columns.Count
If .Table.Cell(iRow, iCol).Selected Then
With .Table.Cell(iRow, iCol).Shape.Fill
.Transparency = 0.25
.Visible = msoTrue
.ForeColor.RGB = RGB(205, 120, 35)
.BackColor.RGB = RGB(255, 255, 255)
.Patterned msoPatternLightUpwardDiagonal
GoTo FillSelectedShape
End With
End If
Next iCol
Next iRow

Else
.Fill.Transparency = 0.25
.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(205, 120, 35)
.Fill.BackColor.RGB = RGB(255, 255, 255)
.Fill.Patterned msoPatternLightUpwardDiagonal
End If
End With

FillSelectedShape:
Exit Sub

NothingSelected:
Exit Sub
End Sub

[magnel]

This logic has really helped improve the code. Based on the above code did some modification on my code. Thank you so much Paul.

Sub Color()
Dim iCol As Long
Dim iRow As Long
Dim otbl As Shape
On Error GoTo NothingSelected


Set otbl = ActiveWindow.Selection.ShapeRange(1)
If otbl.HasTable Then
For iRow = 1 To otbl.Table.Rows.Count
For iCol = 1 To otbl.Table.Columns.Count
If otbl.Table.Cell(iRow, iCol).Selected Then
With otbl.Table.Cell(iRow, iCol).Shape
.Fill.ForeColor.rgb = rgb(210, 203, 141)
.Fill.BackColor.rgb = rgb(255, 255, 255)
.Fill.Patterned msoPatternLightUpwardDiagonal
End With
End If
Next iCol
Next iRow
Else
With ActiveWindow.Selection.ShapeRange()
.Fill.ForeColor.rgb = rgb(210, 203, 141)
.Fill.BackColor.rgb = rgb(255, 255, 255)
.Fill.Patterned msoPatternLightUpwardDiagonal
End With


End If

NothingSelected:
Exit Sub

End Sub