Adding a Picture over a table in powerpoint using Access VBA

[drcoz]

I'm new to the forum and only have been playing with MS Access VBA for about a month, but what a month, I've learned a lot.

Now I'm stuck.

I use Access VBA to create power point slides and on one slide it has a table that looks something like the top table, but I want it to look like the bottom table:

19542

Hope fully you get the idea.

Anyway, I've done a lot of research and come to find out that I can't put a picture in say R1/C2, but I can put one over it using this code:


.Shapes.AddPicture filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=235, Width:=15, Height:=14


Which works great, by itself

What I need is to have VBA search the table and if R1/C2 is "G" then to run the above code.

I'm thinking something like this:


if (r, c) = G then
.Cell(R, C).Shape.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Cell(R, C).Shape.Fill.BackColor.RGB = RGB(0, 0, 0)
.Shapes.AddPicture filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=235, Width:=15, Height:=14
elseif (r, c) = Y then
.Cell(R, C).Shape.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Cell(R, C).Shape.Fill.BackColor.RGB = RGB(0, 0, 0)
.Shapes.AddPicture filename:=yellow1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=235, Width:=15, Height:=14
elseif (r, c) = R then
.Cell(R, C).Shape.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Cell(R, C).Shape.Fill.BackColor.RGB = RGB(0, 0, 0)
.Shapes.AddPicture filename:=Red1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=235, Width:=15, Height:=14
Endif


Don't worry about the L/T/W/H values I'll change those.

My problem is the if...then will work with the two .cell lines but not with the .shapes.addpicture line.

I've tried to get it to work within the following code, but no good.



With .Table
While Not rs3.EOF
For C = 1 To 3
.Cell(R, C).Shape.TextFrame.TextRange.Text = Nz(rs3.Fields(C - 1))
.Cell(R, C).Shape.TextFrame.TextRange.Font.Size = 8
If Nz(rs3.Fields(C - 1)) = "GREEN" Then
.Cell(R, C).Shape.Fill.ForeColor.RGB = RGB(146, 208, 80) 'Green
.Cell(R, C).Shape.Fill.BackColor.RGB = RGB(146, 208, 80)
.Cell(R, C).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(146, 208, 80)
ElseIf Nz(rs3.Fields(C - 1)) = "YELLOW" Then
.Cell(R, C).Shape.Fill.ForeColor.RGB = RGB(240, 173, 40) 'Yellow
.Cell(R, C).Shape.Fill.BackColor.RGB = RGB(240, 173, 40)
.Cell(R, C).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(240, 173, 40)
ElseIf Nz(rs3.Fields(C - 1)) = "RED" Then
.Cell(R, C).Shape.Fill.ForeColor.RGB = RGB(255, 0, 0) 'Red
.Cell(R, C).Shape.Fill.BackColor.RGB = RGB(255, 0, 0)
.Cell(R, C).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 0, 0)
ElseIf Nz(rs3.Fields(C - 1)) = "BLACK" Then
.Cell(R, C).Shape.Fill.ForeColor.RGB = RGB(255, 255, 255) 'Black
.Cell(R, C).Shape.Fill.BackColor.RGB = RGB(255, 255, 255)
.Cell(R, C).Shape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
Else
End If

Next 'c column
rs3.MoveNext
R = R + 1
Wend
rs3.Close
End With



The .Shapes.AddPicture filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=235, Width:=15, Height:=14
works fine outside of the code above.

Hope I've made myself clear.

[drcoz]

We'll after a ton of research I solved my issue. I ended up using an array and three additional subs to get what I needed.

See code below:


With .Table
While Not rs3.EOF
For C = 1 To 3 'columns
.Cell(R, C).Shape.TextFrame.TextRange.Text = Nz(rs3.Fields(C - 1))
.Cell(R, C).Shape.TextFrame.TextRange.Font.Size = 8
If Nz(rs3.Fields(C - 1)) = "GREEN" Then
If Nz(rs3.Fields(C - 1)) = "GREEN" Then
Rcolor = Array(R, C, "Green")
RatingGraphic
End If
.Cell(R, C).Shape.TextFrame.TextRange.Font.color.RGB = RGB(255, 255, 255)
ElseIf Nz(rs3.Fields(C - 1)) = "YELLOW" Then
If Nz(rs3.Fields(C - 1)) = "YELLOW" Then
Rcolor = Array(R, C, "Yellow")
RatingGraphic
End If
.Cell(R, C).Shape.TextFrame.TextRange.Font.color.RGB = RGB(255, 255, 255)
ElseIf Nz(rs3.Fields(C - 1)) = "RED" Then
If Nz(rs3.Fields(C - 1)) = "RED" Then
Rcolor = Array(R, C, "Red")
RatingGraphic
End If
.Cell(R, C).Shape.TextFrame.TextRange.Font.color.RGB = RGB(255, 255, 255)
ElseIf Nz(rs3.Fields(C - 1)) = "BLACK" Then
If Nz(rs3.Fields(C - 1)) = "Black" Then
Rcolor = Array(R, C, "Black")
RatingGraphic
End If
.Cell(R, C).Shape.TextFrame.TextRange.Font.color.RGB = RGB(255, 255, 255)
Else
End If
Next 'c column
rs3.MoveNext
R = R + 1
Wend
rs3.Close
End With
End With


Got my array solution from Pedrum

I added a nested IF that loads the row, column, color of the table into Rcolor which is the array and then calls sub RatingGraphic. I did a bunch of debug.print just to make sure the variables I needed were being loaded into the array.

Here is the sub code:


Sub RatingGraphic()

On Error GoTo SubError

Set objSlide = ppPres.Slides.Item(2)

With ppPres
With .Slides

' Green ----------------------------------------------------------------
If Rcolor(0) = 2 And Rcolor(1) = 2 And Rcolor(2) = "Green" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=235, Width:=15, Height:=14) '2 x 2
ElseIf Rcolor(0) = 2 And Rcolor(1) = 3 And Rcolor(2) = "Green" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=235, Width:=15, Height:=14) '2 x 3
ElseIf Rcolor(0) = 3 And Rcolor(1) = 2 And Rcolor(2) = "Green" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=252, Width:=15, Height:=14) '3 x 2
ElseIf Rcolor(0) = 3 And Rcolor(1) = 3 And Rcolor(2) = "Green" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=252, Width:=15, Height:=14) '3 x 3
ElseIf Rcolor(0) = 4 And Rcolor(1) = 2 And Rcolor(2) = "Green" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=269, Width:=15, Height:=14) '4 x 2
ElseIf Rcolor(0) = 4 And Rcolor(1) = 3 And Rcolor(2) = "Green" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=269, Width:=15, Height:=14) '4 x 3
ElseIf Rcolor(0) = 5 And Rcolor(1) = 2 And Rcolor(2) = "Green" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=286, Width:=15, Height:=14) '5 x 2
ElseIf Rcolor(0) = 5 And Rcolor(1) = 3 And Rcolor(2) = "Green" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=green1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=286, Width:=15, Height:=14) '5 x 3
End If

' Yellow ----------------------------------------------------------------------------------
If Rcolor(0) = 2 And Rcolor(1) = 2 And Rcolor(2) = "Yellow" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=yellow1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=235, Width:=15, Height:=14) '2 x 2
ElseIf Rcolor(0) = 2 And Rcolor(1) = 3 And Rcolor(2) = "Yellow" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=yellow1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=235, Width:=15, Height:=14) '2 x 3
ElseIf Rcolor(0) = 3 And Rcolor(1) = 2 And Rcolor(2) = "Yellow" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=yellow1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=252, Width:=15, Height:=14) '3 x 2
ElseIf Rcolor(0) = 3 And Rcolor(1) = 3 And Rcolor(2) = "Yellow" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=yellow1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=252, Width:=15, Height:=14) '3 x 3
ElseIf Rcolor(0) = 4 And Rcolor(1) = 2 And Rcolor(2) = "Yellow" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=yellow1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=269, Width:=15, Height:=14) '4 x 2
ElseIf Rcolor(0) = 4 And Rcolor(1) = 3 And Rcolor(2) = "Yellow" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=yellow1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=269, Width:=15, Height:=14) '4 x 3
ElseIf Rcolor(0) = 5 And Rcolor(1) = 2 And Rcolor(2) = "Yellow" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=yellow1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=286, Width:=15, Height:=14) '5 x 2
ElseIf Rcolor(0) = 5 And Rcolor(1) = 3 And Rcolor(2) = "Yellow" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=yellow1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=286, Width:=15, Height:=14) '5 x 3
End If

' Red -----------------------------------------------------------------------------------
If Rcolor(0) = 2 And Rcolor(1) = 2 And Rcolor(2) = "Red" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=red1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=235, Width:=15, Height:=14) '2 x 2
ElseIf Rcolor(0) = 2 And Rcolor(1) = 3 And Rcolor(2) = "Red" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=red1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=235, Width:=15, Height:=14) '2 x 3
ElseIf Rcolor(0) = 3 And Rcolor(1) = 2 And Rcolor(2) = "Red" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=red1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=252, Width:=15, Height:=14) '3 x 2
ElseIf Rcolor(0) = 3 And Rcolor(1) = 3 And Rcolor(2) = "Red" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=red1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=252, Width:=15, Height:=14) '3 x 3
ElseIf Rcolor(0) = 4 And Rcolor(1) = 2 And Rcolor(2) = "Red" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=red1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=269, Width:=15, Height:=14) '4 x 2
ElseIf Rcolor(0) = 4 And Rcolor(1) = 3 And Rcolor(2) = "Red" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=red1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=269, Width:=15, Height:=14) '4 x 3
ElseIf Rcolor(0) = 5 And Rcolor(1) = 2 And Rcolor(2) = "Red" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=red1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=286, Width:=15, Height:=14) '5 x 2
ElseIf Rcolor(0) = 5 And Rcolor(1) = 3 And Rcolor(2) = "Red" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=red1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=286, Width:=15, Height:=14) '5 x 3
End If

' Black -------------------------------------------------------------------------------------
If Rcolor(0) = 2 And Rcolor(1) = 2 And Rcolor(2) = "Black" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=black1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=235, Width:=15, Height:=14) '2 x 2
ElseIf Rcolor(0) = 2 And Rcolor(1) = 3 And Rcolor(2) = "Black" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=black1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=235, Width:=15, Height:=14) '2 x 3
ElseIf Rcolor(0) = 3 And Rcolor(1) = 2 And Rcolor(2) = "Black" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=black1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=252, Width:=15, Height:=14) '3 x 2
ElseIf Rcolor(0) = 3 And Rcolor(1) = 3 And Rcolor(2) = "Black" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=black1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=252, Width:=15, Height:=14) '3 x 3
ElseIf Rcolor(0) = 4 And Rcolor(1) = 2 And Rcolor(2) = "Black" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=black1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=269, Width:=15, Height:=14) '4 x 2
ElseIf Rcolor(0) = 4 And Rcolor(1) = 3 And Rcolor(2) = "Black" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=black1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=269, Width:=15, Height:=14) '4 x 3
ElseIf Rcolor(0) = 5 And Rcolor(1) = 2 And Rcolor(2) = "Black" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=black1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=628, Top:=286, Width:=15, Height:=14) '5 x 2
ElseIf Rcolor(0) = 5 And Rcolor(1) = 3 And Rcolor(2) = "Black" Then
Set objImageBox = objSlide.Shapes.AddPicture(filename:=black1, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, Left:=680, Top:=286, Width:=15, Height:=14) '5 x 3
End If


End With
End With
SubExit:
On Error Resume Next
Exit Sub

SubError:
GeneralErrorHandler Err.Number, Err.Description, "Form_frmInstallationSnapShot", "Slide RatingGraphic"

GoTo SubExit
End Sub


I know the sub code is messy, but at my level of programming this was a victory for me.