none
VBA Update of ActiveX Textbox's in PowerPoint Failing RRS feed

  • Question

  • Greetings. The intent of the below code is to access a range within an Excel spreadsheet, find a value and then loop through all ActiveX TextBox's within a PowerPoint slide until the TextBox name is found. Once found, the TextBox is updated with the value from Excel and background colour changed accordingly. The code works well when there are no other shapes or tables on the slide. However when there are, it's throwing run time error "-2147188160 (80048240): OLEFormat (unknown member): Invalid Request. This property only applies to OLE objects."

    Any suggestions on how to best skip all non-required shapes or tables except the required TextBox's?

    Private Sub CommandButton1_Click()
    
    Dim objExcel As Object
    Dim exWb As Object
    Dim rng As Object
    Dim c As Object
    Dim TaskStatus As String
    Dim oTB As PowerPoint.Shape
    
        Set objExcel = CreateObject("Excel.Application")
        Set exWb = objExcel.Workbooks.Open("C:\Temp\SAMPLE.xlsm")
        Set rng = exWb.Sheets("Data").Range("TEEE")
    
        For Each c In rng.Cells
            TaskStatus = c.Offset(0, 1)
            MsgBox TaskStatus
            
            For Each oTB In ActivePresentation.Slides(1).Shapes
                If oTB.OLEFormat.Object.Name = c Then
                    oTB.OLEFormat.Object.Text = TaskStatus
                    If TaskStatus = "B" Then oTB.OLEFormat.Object.BackColor = RGB(0, 0, 255)
                    If TaskStatus = "R" Then oTB.OLEFormat.Object.BackColor = RGB(255, 0, 0)
                    If TaskStatus = "A" Then oTB.OLEFormat.Object.BackColor = RGB(255, 204, 0)
                    If TaskStatus = "G" Then oTB.OLEFormat.Object.BackColor = RGB(0, 255, 0)
                    Exit For
                End If
    
            Next
        Next
    
        exWb.Close
        objExcel.Quit
    
        Set exWb = Nothing
        Set objExcel = Nothing
        Set rng = Nothing
        Set c = Nothing
        Set oTB = Nothing
    
    End Sub

    Friday, July 29, 2016 11:59 AM

Answers

  • You have to check whether the shape is an OLE control:

            For Each oTB In ActivePresentation.Slides(1).Shapes
                If oTB.Type = msoOLEControlObject Then
                    If oTB.OLEFormat.Object.Name = c Then
                        oTB.OLEFormat.Object.Text = TaskStatus
                        If TaskStatus = "B" Then oTB.OLEFormat.Object.BackColor = RGB(0, 0, 255)
                        If TaskStatus = "R" Then oTB.OLEFormat.Object.BackColor = RGB(255, 0, 0)
                        If TaskStatus = "A" Then oTB.OLEFormat.Object.BackColor = RGB(255, 204, 0)
                        If TaskStatus = "G" Then oTB.OLEFormat.Object.BackColor = RGB(0, 255, 0)
                        Exit For
                    End If
                End If
            Next oTB


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by IIOIIOII Friday, July 29, 2016 11:53 PM
    Friday, July 29, 2016 12:20 PM

All replies

  • You have to check whether the shape is an OLE control:

            For Each oTB In ActivePresentation.Slides(1).Shapes
                If oTB.Type = msoOLEControlObject Then
                    If oTB.OLEFormat.Object.Name = c Then
                        oTB.OLEFormat.Object.Text = TaskStatus
                        If TaskStatus = "B" Then oTB.OLEFormat.Object.BackColor = RGB(0, 0, 255)
                        If TaskStatus = "R" Then oTB.OLEFormat.Object.BackColor = RGB(255, 0, 0)
                        If TaskStatus = "A" Then oTB.OLEFormat.Object.BackColor = RGB(255, 204, 0)
                        If TaskStatus = "G" Then oTB.OLEFormat.Object.BackColor = RGB(0, 255, 0)
                        Exit For
                    End If
                End If
            Next oTB


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by IIOIIOII Friday, July 29, 2016 11:53 PM
    Friday, July 29, 2016 12:20 PM
  • Fantastic! Thanks! Works perfectly.
    Friday, July 29, 2016 11:53 PM