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:

Installation Snapshot.jpg

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.