Макрос в PowerPoint, который ссылается на данные, хранящиеся в электронной таблице Excel

Question

У меня есть таблица Excel (скажем, objectdata.xls), которая используется для установки ширины / длины разных прямоугольников.Таким образом, электронная таблица имеет 3 столбца:

Имя объекта Ширина объекта Длина объекта

В электронной таблице определено около 100 прямоугольников

Что я пытаюсь сделать, это запустить макросв PowerPoint (PP), которая будет считывать данные из электронной таблицы (в идеале эта информация должна храниться вне файла PP, но при необходимости это может быть связанный или встроенный файл в PP), а затем обновлять размер прямоугольных фигурчто я включил в файл PP.

Например, на первом слайде макрос читает строку 1 в электронной таблице и видит, что ширина объекта равна 5, а длина равна 10, и, таким образом, обновляет размер прямоугольной формы в PP.

Может кто-нибудь сказать мне, если это можно сделать?

Спасибо.

Answer 1

Используйте GetExcelData для выполнения работы; это вызывает GetExcel

Function GetExcel() As Object
'---------------------------------------------------------------------------------------
' Procedure : GetExcel
' Author    : Naresh Nichani / Steve Rindsberg
' Purpose   :
'               Check if an instance of Excel is running. If so obtain a reference to the running Excel application
'               Otherwise Create a new instance of Excel and assign the XL application reference to oXLApp object
' SR        :   Modified 2010-02-23 to ALWAYS create a new instance rather than using an existing one, so when we
'           :   close the one we open, we don't wack the user's other instances of Excel if any
' Params    :   None
' Returns   :   An Excel Application object on success, Nothing on failure
'---------------------------------------------------------------------------------------

   On Error GoTo GetExcel_ErrorHandler

    On Error Resume Next
    Err.Number = 0

    Dim oXLAPP As Object

' Comment out the following bits to force a new instance of Excel
' and leave any existing instances alone
'    Set oXLApp = GetObject(, "Excel.Application")
'    If Err.Number <> 0 Then
'        Err.Number = 0
        Set oXLAPP = CreateObject("Excel.Application")
        If Err.Number <> 0 Then
            'MsgBox "Unable to start Excel.", vbInformation, "Start Excel"
            Exit Function
        End If
'    End If

   On Error GoTo GetExcel_ErrorHandler

    If Not oXLAPP Is Nothing Then
        Set GetExcel = oXLAPP
    Else
        [MASTTBAR].rnrErrLog "modExcel:GetExcel - unable to invoke Excel instance"
    End If

    Set oXLAPP = Nothing

    Exit Function

NormalExit:
   On Error GoTo 0
   Exit Function

GetExcel_ErrorHandler:
    Resume NormalExit
End Function

Function GetExcelData(sFilename As String, _
    Optional lWorksheetIndex As Long = 1, _
    Optional sWorksheetName As String = "") As Variant
'---------------------------------------------------------------------------------------
' Purpose   : Gets the "active" data from the file/worksheet specified

    Dim oXLAPP As Object
    Dim oxlWB As Object
    Dim oxlRange As Object

    Dim x As Long
    Dim y As Long
    Dim sMsg As String

    Dim lVisibleRowCount As Long
    Dim lVisibleColCount As Long

    Dim aData() As String

   On Error GoTo GetExcelData_ErrorHandler

    Set oXLAPP = GetExcel()
    If oXLAPP Is Nothing Then
        Exit Function
    End If

    ' open the workbook read-only
    Set oxlWB = oXLAPP.Workbooks.Open(sFilename, , True)
    If oxlWB Is Nothing Then
        Exit Function
    End If

    If Len(sWorksheetName) > 0 Then
        Set oxlRange = GetUsedRange(oxlWB.Worksheets(sWorksheetName))
    Else
        Set oxlRange = GetUsedRange(oxlWB.Worksheets(lWorksheetIndex))
    End If

    If oxlRange Is Nothing Then
        Exit Function
    End If

    ' Get a count of visible rows/columns (ignore hidden rows/cols)
    For x = 1 To oxlRange.Rows.Count
        If Not oxlRange.Rows(x).Hidden Then
            lVisibleRowCount = lVisibleRowCount + 1
        End If
    Next    ' row

    For y = 1 To oxlRange.Columns.Count
        If Not oxlRange.Columns(y).Hidden Then
            lVisibleColCount = lVisibleColCount + 1
        End If
    Next

    ReDim aData(1 To lVisibleRowCount, 1 To lVisibleColCount)

    lVisibleRowCount = 0
    For x = 1 To oxlRange.Rows.Count
        If Not oxlRange.Rows(x).Hidden Then
            lVisibleRowCount = lVisibleRowCount + 1
            lVisibleColCount = 0
            For y = 1 To oxlRange.Columns.Count
                If Not oxlRange.Columns(y).Hidden Then
                    lVisibleColCount = lVisibleColCount + 1
                    aData(lVisibleRowCount, lVisibleColCount) = oxlRange.Cells(x, y).Text
                End If
            Next
        End If
    Next

    ' return data in array
    GetExcelData = aData

NormalExit:
    On Error GoTo 0

    ' Close the workbook
    If Not oxlWB Is Nothing Then
        oXLAPP.DisplayAlerts = False
        oxlWB.Close
        oXLAPP.DisplayAlerts = True
    End If

    'To Close XL application
    If Not oXLAPP Is Nothing Then
        oXLAPP.Quit
    End If

    'Set the XL Application and XL Workbook objects to Nothing
    Set oxlRange = Nothing
    Set oxlWB = Nothing
    Set oXLAPP = Nothing

    Exit Function

GetExcelData_ErrorHandler:
    Resume NormalExit

End Function

Blockquote Blockquote enter code here

Answer 2

Да, это, безусловно, можно сделать. Требуется немного больше кода, чем у меня на кончиках моих пальцев, и вам нужно будет адаптировать все, что я написал. Но посмотрите здесь примеры, с которых вы можете начать. Они указывают на сайт FAQ PowerPoint, который я поддерживаю. Ни за что не взимается.

Управление офисными приложениями из PowerPoint (Naresh Nichani и Brian Reilly) http://www.pptfaq.com/FAQ00795.htm

Автоматизация Excel из PowerPoint. Автоматизация PowerPoint из Excel. И так далее. http://www.pptfaq.com/FAQ00368.htm

Я бы, вероятно, сделал это, открыв файл excel, прочитав содержимое в массив, а затем используя данные из массива, чтобы выполнить фактическую работу в PPT.

Если вам нужна помощь с PPT, сообщите нам. В основном это будет вопрос написания такой функции, как [aircode]:

Sub SetRectangleSize ( sRectangleName as string, sngWidth as Single, sngHeight as Single)
  Dim oShp as Shape
  Set oShp = GetShapeNamed(sRectangleName, lSlideIndex)
  If Not oShp is Nothing Then
    With oShp
        .Width = sngWidth
        .Height = sngHeight
    End With
  End If
End Sub

И

Function GetShapeNamed(sName as String, lSlideIndex as Long) as Shape
  On Error Resume Next
  Set GetShapeNamed = ActivePresentation.Slides(lSlideIndex).Shapes(sName)
  If Err.Number <> 0 Then
     ' no shape by that name on the slide; return null
     Set GetShapeNamed = Nothing
  End If
End Function  

Кстати, я бы рассмотрел использование тегов для идентификации прямоугольников, а не имен фигур (которые, как правило, менее надежны).