Использование Excel vba для размещения объектов в таблице PowerPoint

Question

Я использую лист Excel для заполнения расписания собраний в PowerPoint. В моем файле Excel есть столбцы от a до f (название собрания, местоположение, категория (в каком разделе персонала проводится встреча), дни недели, время дня и продолжительность встречи). Заголовки рабочего листа находятся в строке 4, поэтому данные начинаются со строки 5. Эти данные используются для помещения фигур PowerPoint в таблицу на слайде. У меня есть объект класса с именем BREpptObjects, который имеет BREpptObjectName As String, BREpptObjectLocation As String, BREpptObjectCategory As String, BREpptObjectDays as String, BREpptObjectTime As Integer, BREpptObjectLength As Double, BREpptObjectPIC As Integer. PI C должен быть позицией в ячейке для нескольких объектов в одной ячейке. Все Gets и Lets также закодированы. Оставим это для краткости.

У меня есть кнопка команды в моей электронной таблице, чтобы начать экспорт. Проблема в том, что если несколько встреч одновременно, мои фигуры накладываются друг на друга. Что касается жизни, я не могу понять, как компенсировать или деконфликтовать сложенные фигуры. Любая помощь будет принята с благодарностью.

Sub ExportToPPTButton_Click()

Dim BREobjects() As BREpptObjects
Dim BREdaysString() As String

Dim BREppt As PowerPoint.Presentation
Dim BREpptURL As String
Dim PowerPointApp As PowerPoint.Application
Dim BREpptLayout As CustomLayout
Dim NewBREslide As Slide
Dim BREtable As PowerPoint.Shape
Dim BREbubble As PowerPoint.Shape
Dim BREdtg As Range
Dim placeInCell As Integer
Dim lastrow As Integer
Dim BREitems as Range
Dim yy As Single
Dim xx As Single
Dim dx As Single
Dim dy As Single
Dim count As Integer
Dim objInCell As Integer
Dim daysAsInt As Integer

Dim BREname As String
Dim BRELocation As String
Dim BREcategory As String
Dim BREtime As Long
Dim BRElength As Double
Dim BREdays As String

BREpptURL = "https://MyURL.com"

Set PowerPointApp = CreateObject("PowerPoint.Application")
Set BREppt = PowerPointApp.Presentations.Open(BREpptURL)
Set BREpptLayout = BREppt.Slides(1).CustomLayout
Set NewBREslide = BREppt.Slides.AddSlide(1, BREpptLayout)
Set BREtable = BREppt.Slides(2).Shapes("BREslideTable")

lastrow = Cells(Rows.count, "a").End(xlUp).Row

Set BREitems = Range("a5:a" & lastrow)

BREtable.Copy
BREppt.Slides(1).Shapes.Paste
BREppt.Slides(1).Select

Set NewBREslide = BREppt.Slides(1)
Set BREtable = BREppt.Slides(1).Shapes("BREslideTable")

placeInCell = 0
For Each i In BREitems
    ReDim Preserve BREobjects(i.Row - 4)
    Set BREobjects(i.Row - 4) = New BREpptObjects

    With BREobjects(i.Row - 4)
        .BREname = Cells(i.row, "a").value
        .BRELocation = Cells(i.row, "b").value
        .BREcategory = Cells(i.row, "c").value
        .BREdays = Cells(i.row, "d").value
        .BREtime = (Cells(i.row, "e").value / 100) + 2           'this sets the time to equal the row number in the powerpoint table
        .BRElength = Cells(i.row, "f").value
    End With

    BREname = BREobjects(i.Row - 4).BREname
    BRELocation = BREobjects(i.Row - 4).BRELocation
    BREcategory = BREobjects(i.Row - 4).BREcategory
    BREtime = BREobjects(i.Row - 4).BREtime
    BRElength = BREobjects(i.Row - 4).BRElength
    BREdays = BREobjects(i.Row - 4).BREdays

    yy = BREtable.Table.Cell(BREtime, 4).Shape.Top
    dy = BREtable.Table.Cell(BRetime, 4).Shape.Height * BRElength

    Set BREdtg = Range("d5:d" & lastrow)
    BREdaysString() = Split(BREdays, ", ")

    count = 0
    For Each j In BREdaysString
        Dim BREcompareString1 As String
        BREcompareString1 = "*" & j & "*"
        objInCell = 0

        For Each k in BREdtg
            Dim BREcompareTime As Long
            Dim BREcompareString2 As String

            BREcompareTime = (Cells(k.row, "e").value / 100) + 2
            BREcompareString2 = k.value

            If UCase(BRecompareString2) Like UCase(BREcompareString1) And BREtime = BREcompareTime Then
                objInCell = objInCell + 1
            End If
        Next k

        If objInCell = 1 Then
            BREobjects(i.Row - 4).BREpic = 1
        ElseIf objInCell > 1 Then
            count = count + 1
            BREobjects(i.Row - 4).BREpic = objInCell       'I know this causes the stacking but everything else I've tried blows us all the other powerpoint bubbles. 
        End If                                             'I feel like the count integer could be used somehow to set the BREpic but I can't figure out the loops.

        If j = "Monday" Then                               'This will set the column number in the table for the objects.
            daysAsInt = 4
        ElseIf j = "Tuesday" Then
            daysAsInt = 5
        ElseIf j = "Wednesday" Then
            daysAsInt = 6
        ElseIf j = "Thursday" Then
            daysAsInt = 7
        ElseIf j = "Friday" Then
            daysAsInt = 8
        ElseIf j = "Saturday" Then
            daysAsInt = 9
        ElseIf j = "Sunday" Then
            daysAsInt = 10
        End If

        dx = BREtable.Table.Columns(4).Width / objInCell

        If BREobjects(i.Row - 4).BREpic = 1 Then
            xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left
        ElseIf BREobjects(i.Row - 4).BREpic > 1 Then
            xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left + (dx * BREobjects(i.Row - 4).BREpic) - dx
        End If

        Set BREbubble = NewBREslide.Shapes.AddShape(msoShapeRoundedRectable, xx, yy, dx, dy)

        With BREbubble
            .Name = BREname
            .TextFrame.TextRange.Text = BREname
        End With

    Next j
Erase BREdaysString
Next i
End Sub

Answer 1

Ну, потерял мой компьютер в службу поддержки примерно на месяц. Получил это наконец, приблизительно через неделю go. У меня была выключена лампочка go, пока мой компьютер был секвестрирован. Потратил около половины дня, работая над моей идеей, и получил этот код на работу. Я не буду публиковать класс BREpptObject для краткости, но это все там с соответствующими Gets и Lets. Вот решение:

Sub ExportToPPTButton_Click()

Dim BREppt As PowerPoint.Presentation
Dim BREpptURL As String
Dim PowerPointApp As PowerPoint.Application
Dim BREpptLayout As CustomLayout
Dim NewBREslide As Slide
Dim BREtable As PowerPoint.Shape
Dim BREbubble As PowerPoint.Shape

Dim BREdtg As Range

Dim yy As Single
Dim dy As Single

BREpptURL = "https://SHAREPOINT.URL"

Set PowerPointApp = CreateObject("PowerPoint.Application")
Set BREppt = PowerPoint.Presentations.Open(BREpptURL)
Set BREpptLayout = BREppt.Slides(1).CustomLayout
Set NewBREslide = BREppt.Slides.AddSlide(1, BREpptLayout)
Set BREtable = BREppt.Slides(2).Shapes("BREslideTable")
Set BREdata = Range("a5:f" & lastrow)
Set BREitems = Range("a5:a" & lastrow)

BREtable.Copy
BREpptSlides(1).Shapes.Paste
BREppt.Slides(1).Select

Set NewBREslide = BREppt.Slides(1)
Set BREtable = BREppt.Slides(1).Shapes("BREslideTable")

'creates a new object for each BRE day/time comvination
count = 0
For Each i In BREitems
    BREdaysString() = Split(Cells(i.Row, "d"), ", ")
    For Each j In BREdaysString

        count = count + 1
        ReDim Preserve BREopbjects(count)
        Set BREobjects(count) = New BREpptObjects

        With BREobjects(count)
            .BREname = Cells(i.Row, "a").value
            .BRELocation = Cells(i.Row, "b").value
            .BRECategory = Cells(i.Row, "c").value
            .BREdays = j
            .BREtime = (Cells(i.Row, "e").value / 100) + 2
            .BRElength = Cells(i.Row, "f").value
        End With
    Next j
    Erase BREdaysString
Next i

'compares each BREobject to all other BREobjects to determine how many and which are in the same day/time
For i = 1 To UBound(BREobjects)

    BREname = BREobjects(i).BREname
    BRELocation = BREobjects(i).BRELocation
    BRECategory = BREobjects(i).BRECategory
    BREtime = BREobjects(i).BREtime
    BRElength = BREobjects(i).Length
    BREdays = BREobjects(i).BREdays

    If IsEmpty(BREobjects(i).BREpic) Then
        BREobjects(i).BREpic = 0
    End If

    objInCell = 0
    For j = 1 To UBoung(BREobjects)
        BREnameComapre = BREobjects(j).BREname
        BRELocationComapre = BREobjects(j).BRELocation
        BRECategoryComapre = BREobjects(j).BRECategory
        BREtimeComapre = BREobjects(j).BREtime
        BRElengthComapre = BREobjects(j).Length
        BREdaysComapre = BREobjects(j).BREdays

        If BREdaysCompare = BREdays And BREtimeCompare = BREtime Then           'Sets place in cell (PIC) for each objects
            objInCell = objInCell + 1
            BREobjects(j).BREpic = objInCell
        End If
    Next j
    BREobjects(i).BREobjInCell = objInCell                                      'Sets total # of objects in cell
Next i

'Converts day of the week to column number and creates bubbles for ppt slide
For i = 1 To UBound(BREobjects) - LBound(BREobjects)

    BREdays = BREobjects(i).BREdays
    BREpic = BREobjects(i).BREpic
    BREtime = BREobjects(i).BREtime
    BRECategory = BREobjects(i).BRECategory
    BREname = BREobjects(i).BREname

    objInCell = BREobjects(i).objInCell

    If BREdays = "Monday" Then
        daysAsInt = 4
    ElseIf BREdays = "Tuesday" Then
        daysAsInt = 5
    ElseIf BREdays = "Wednesday" Then
        daysAsInt = 6
    ElseIf BREdays = "Thursday" Then
        daysAsInt = 7
    ElseIf BREdays = "Friday" Then
        daysAsInt = 8
    ElseIf BREdays = "Saturday" Then
        daysAsInt = 9
    ElseIf BREdays = "Sunday" Then
        daysAsInt = 10
    End If

    yy = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Top
    dy = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Height * BRElength
    dx = BREtable.Table.Columns(daysAsInt).Width / objInCell

    If objInCell = 1 Then
        xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left
    ElseIf objInCell > 1 Then
        xx = BREtable.Table.Cell(BREtime, daysAsInt).Shape.Left + (dx * BREpic) - dx
    End If

    Set BREbubble = NewBREslide.Shapes.AddShape(msoShapeRoundedRectangle, xx, yy, dx, dy)

    With BREbubble
        .Name = BREname
        .TextFrame.TextRange.Text = BREname
        .TextFrame2.AutoSize = msoAutoSizeTextToFitShape
    End With

    If BRECategory = "CENTCOM" Then
        BREbubble.Fill.ForeColor.RGB = RGB(112, 48, 160)
        BREbubble.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
    ElseIf BRECategory = "CG Chair" Then
        BREbubble.Fill.ForeColor.RGB = RGB(255, 0, 0)
        BREbubble.TextFrame.TextRange.Font.Color = RGB(255, 255, 255)
    ElseIf BRECategory = "GO Chair" Then
        BREbubble.Fill.ForeColor.RGB = RGB(255, 204, 0)
        BREbubble.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)
    ElseIf BRECategory = "Staff Chair" Then
        BREbubble.Fill.ForeColor.RGB = RGB(146, 208, 80)
        BREbubble.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)
    End If
Next i

End Sub