PowerPoint VBA实现盒中盒视图海报的布局算法优化求助

PowerPoint VBA自动生成海报开发求助 #

我正尝试通过VBA在PowerPoint中编写代码自动生成海报（本质为盒中盒视图），但当前开发难度已超出我的技术能力范畴。
希望获得代码结构、设计模式层面的最优实现指导，我当前的实现方案如下：

• 从CSV读取对应表格数据，存入分类、子分类、列、交叉项4个内存数组，我认为当前存储方案可能存在缺陷，但暂未找到更优方案。
• 代码先在数组中处理间距逻辑，调整每个交叉块的x、y坐标，按需扩容分类、子分类块尺寸，最终将所有块绘制到PowerPoint画布上。
• 目前以「初始选中块」作为运行上下文，将该块的尺寸作为整体布局的维度模板。

我已完成位置摆放相关逻辑，核心需要优化各组件间距、块尺寸的计算算法。

参考示意图 #

样例数据：

逻辑运行完成后生成的海报效果：

我可以分享完整代码，目前代码体量偏大，我认为实现逻辑可以进一步简化，现有代码样例如下：

Const defaultObjectWidth = 95
Const defaultObjectHeight = 50
Const defaultCategoryWidth = 90
Const defaultSubCatWidth = 90
Const defaultBuffer = 3
Const blocksPerCol = 4
Const myYAxisWidth = 100

Sub insertShape()
On Error GoTo Err_Handler
  Dim SlideHeight As Long, SlideWidth As Long
  Dim ContainerHeight As Long, ContainerWidth As Long
  Dim ObjectHeight As Long, ObjectWidth As Long
  Dim x As Long, y As Long
  Dim shp As Object
  Dim colWidth As Integer
  Dim blockSize As Integer
  Dim IntersectCalcComplete As Boolean
  
  IntersectCalcComplete = False
  
  ' create the Arrays for storing the data
  Dim CategorysArr()  As String
  Dim SubCatsArr()  As String
  Dim YAxissArr() As String
  Dim IntersectsArr() As String
  Dim tmpIntersects() As String

  
Call LoadSubCats(SubCatsArr)
Call LoadCategorys(CategorysArr)
Call LoadYAxiss(YAxissArr)
Call LoadIntersects(IntersectsArr)
    
  
ReDim tmpIntersects(0 To 2, 0 To 0)
  
  If ActiveWindow.Selection.Type = ppSelectionNone Then
    MsgBox "Please select object", vbExclamation, "Make Selection"
  Else
    Set shp = ActiveWindow.Selection.ShapeRange(1)
    
    SlideHeight = ActivePresentation.PageSetup.SlideHeight 'get slide vertical height
    SlideWidth = ActivePresentation.PageSetup.SlideWidth  'get slide horizontal width
    'Main Content Container width and height
    ContainerHeight = shp.Height
    ContainerWidth = shp.Width
    
    
    ' calculate the container column sizes.
    '
    colWidth = calcColumnSizes(shp.Width, CategorysArr, SubCatsArr, YAxissArr)
    ' calculate the blockwidth based on the density factor parameter
    blockWidth = calcBlockWidth(colWidth, blocksPerCol)
    
    ' Iterate through the Categorys, SubCats and Intersects in order to calculate the spacing of the Intersects.
    
             ' first sort the matricies by a specific column.
             ' CategorysArr = QuickSortArray(CategorysArr, -1, -1, 4)
             ' Call multiSortArray(1, CategorysArr, arrFlds(CategorysArr), "2 Asc 5 Asc")
   ' -- ------------------------------------------------------------------------------------------------------------------------------------------------
    Dim SubCatID As Integer
    'Dim myYAxisWidth As Integer
    Dim SubCatHeight, CategoryHeight, currentX, currentY, n, t As Integer
    
    SubCatHeight = 0
    CategoryHeight = 0
    currentX = 0
    currentY = 0
    currentBlockUsed = 0
    
    For i = LBound(SubCatsArr, 2) To UBound(SubCatsArr, 2) ' For each SubCat in the SubCats Array
    
    t = t + 1
    'Debug.Print (" processing SubCat: " & t & " called: " & SubCatsArr(1, i))
    
       ' Debug.Print (SubCatsArr(i, 1)) ' print the name
        SubCatID = SubCatsArr(0, i)
        If Not IsNull(SubCatID) Then
            ' with each SubCat - find all related Intersects and fit them into the canvas
            
            ' 1: Filter the Intersects by SubCat
            Call getIntersectBySubCat(SubCatID, IntersectsArr, tmpIntersects)
            'printArray (tmpIntersects)
            ' 2: re-structure the Intersects position to fit into the YAxiss allocated
          '  myYAxisWidth = 200  ' -- get YAxis width TODO: get the real width
                               ' -- we already know what the blockWidth is (above)
             SubCatHeight = defaultObjectHeight + defaultBuffer  ' set the SubCatheight on the first pass.
            For j = LBound(tmpIntersects, 2) To UBound(tmpIntersects, 2)  ' Loop through tmp Intersects to add placement
            
            
            If LBound(tmpIntersects, 2) = -1 Then   ' SubCat has no Intersects
            ' Debug.Print ("SubCat ID:" & SubCatID & " has no Intersects")
            
            
            Else
                If myYAxisWidth < (currentX + blockWidth + (defaultBuffer * 2)) Then  ' If there is not enough remaining space in YAxis
                    currentY = currentY + defaultBuffer + defaultObjectHeight
                    currentX = 0
                    SubCatHeight = SubCatHeight + defaultObjectHeight + defaultBuffer
                End If
                n = findArrStr(IntersectsArr, 0, str(tmpIntersects(0, j)))
                IntersectsArr(6, n) = str(currentX + defaultBuffer)  ' X CoOrdinate
                IntersectsArr(7, n) = str(currentY + defaultBuffer)  ' Y CoOrdinate
            
                currentX = currentX + defaultBuffer + defaultObjectWidth
            
            End If
            
            
            Next j 'filtered Intersect
        Else
      '  Debug.Print ("empty record in Array Detected")
        End If
        
         Call setSubCatHeight(SubCatHeight, SubCatID, SubCatsArr, CategorysArr)
        SubCatHeight = 0
        
        
    Next i 'SubCat
    
    
    
    
' -- -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
' -- -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
   ' ADDING OF THE SHAPES TO THE VIEW
   
   Call addCategorys(CategorysArr, shp)
   Call addSubCats(SubCatsArr, shp)
   Call addIntersects(IntersectsArr, shp)
    
    
   ' x = (SlideWidth - ObjectWidth) / 2 'calculate horizontal position
   ' y = (SlideHeight - ObjectHeight) / 2 'calculate vertical position
   ' shp.Left = x 'move object horizontal
   ' shp.Top = y 'move object vertical
  End If
  
Exit_Label:
  On Error Resume Next
  Set shp = Nothing
  Exit Sub
Err_Handler:
  MsgBox Err.Description, vbCritical
    Resume Exit_Label

End Sub
Function getIntersectBySubCat(SubCatID As Integer, ByRef IntersectsArr As Variant, ByRef tmpIntersects As Variant)
' Filters the Intersects to the specific SubCat
 Dim i, j As Integer
 j = -1

 Erase tmpIntersects
 ReDim Preserve tmpIntersects(0 To 2, -1 To 0)
 
 For i = LBound(IntersectsArr, 2) To UBound(IntersectsArr, 2)
    If IntersectsArr(2, i) = SubCatID Then  'if the Intersect relates to the current SubCat
        j = j + 1
        ReDim Preserve tmpIntersects(0 To 2, 0 To j)  ' Redimension:
 
        tmpIntersects(0, j) = IntersectsArr(0, i)  ' Intersect Code
        tmpIntersects(1, j) = IntersectsArr(3, i) ' get the YAxis
        tmpIntersects(2, j) = IntersectsArr(9, i) ' get the Order
        
        
        
        'Debug.Print ("RESULT ARRAY" & tmpIntersects(i + 1, 0) & "_" & tmpIntersects(i + 1, 1) & "_" & tmpIntersects(i + 1, 2) & "_")
    End If
 
 Next i 'Intersect
    
    ' sort the array by the Intersect order column (2)
   ' Call QuickSortArray(tmpIntersects, , , 2)



End Function

Function calcColumnSizes(lenContainer As Integer, ByRef CategorysArr As Variant, ByRef SubCatsArr As Variant, ByRef YAxissArr As Variant) As Integer
Dim lenCategory, lenSubCat, cntQtr As Integer
Dim lenWorkArea, columnSize As Integer


cntQtr = UBound(YAxissArr) + 1

lenWorkArea = lenContainer - defaultCategoryWidth - defaultSubCatWidth - (2 * defaultBuffer)
lenWorkArea = lenWorkArea - ((2 * defaultBuffer) + (cntQtr * defaultBuffer))
columnSize = lenWorkArea / cntQtr

' now propogate the columnSize into the YAxiss data
    For i = LBound(YAxissArr, 1) To UBound(YAxissArr, 1)
        YAxissArr(2, i) = str(Round(columnSize, 1)) ' Width
    Next i
 calcColumnSizes = columnSize

End Function

Function calcBlockWidth(columnSize As Integer, density As Integer) As Integer
    calcBlockWidth = columnSize / density

End Function

Function setSubCatHeight(SubCatYPos, ID As Integer, ByRef SubCatsArr As Variant, ByRef CategorysArr As Variant)
Dim curSubCat As Integer
    curSubCat = findArrStr(SubCatsArr, 0, str(ID))
    If SubCatsArr(3, curSubCat) < SubCatYPos Then
        SubCatsArr(3, curSubCat) = SubCatYPos
       Call setCategoryHeight(SubCatYPos, CInt(SubCatsArr(2, curSubCat)), CategorysArr)
    End If


End Function
Function setCategoryHeight(CategoryYPos, ID As Integer, ByRef CategorysArr As Variant)
Dim curCategory As Integer
    curCategory = findArrStr(CategorysArr, 0, str(ID))
    If CategorysArr(2, curCategory) < CategoryYPos Then
        CategorysArr(2, curCategory) = CategoryYPos
    End If
End Function
Function addCategorys(ByRef CategorysArr As Variant, masterShp As Shape)

Dim i, j As Integer

For i = LBound(CategorysArr, 2) To UBound(CategorysArr, 2)
    Call addBlockContents(CInt(CategorysArr(2, i)), CInt(CategorysArr(3, i)), CStr(CategorysArr(1, i)), masterShp)  ' X, Y, Name, Shape
Next i
    
End Function
Function addSubCats(ByRef SubCatsArr As Variant, masterShp As Shape)

Dim i, j As Integer

For i = LBound(SubCatsArr, 2) To UBound(SubCatsArr, 2)
    Call addBlockContents(CInt(SubCatsArr(3, i)), CInt(SubCatsArr(4, i)), CStr(SubCatsArr(1, i)), masterShp)
Next i
    
End Function


Function addIntersects(ByRef IntersectsArr As Variant, masterShp As Shape)

Dim i, j As Integer
Dim myX, myY As Integer
myX = 0
myY = 0
For i = LBound(IntersectsArr, 2) To UBound(IntersectsArr, 2)

' adjust the placement of the shape relative to the masterShape
myX = masterShp.Left + CInt(IntersectsArr(6, i)) + defaultCategoryWidth + defaultSubCatWidth + (defaultBuffer * 2)
myY = masterShp.Top + CInt(IntersectsArr(7, i))
Call addBlockContents(myX, myY, CStr(IntersectsArr(1, i)), masterShp)



         'For j = LBound(COAArray, 2) To UBound(COAArray, 2)
         'Next j
     Next i
    
End Function


Function addBlockContents(x, y, IntersectName As String, myShp As Shape)
Dim oSh As Shape

Set oSh = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, x, y, defaultObjectWidth, defaultObjectHeight)
    With oSh
     With .Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText2
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0.8000000119
        .Transparency = 0
        .Solid
    End With 'fill
      With .TextFrame
        .MarginLeft = 0
        .MarginRight = 0
        .MarginTop = 0
        .MarginBottom = 0
        .AutoSize = False
        
       With .TextRange
          .Text = IntersectName
           With .Font
            .Name = "Ariel"
            .Size = 6.4
            .Bold = msoFalse
            .Italic = msoFalse
            .Underline = msoFalse
            .Shadow = msoFalse
            .Emboss = msoFalse
            .BaselineOffset = 0
            .AutoRotateNumbers = msoFalse
            .Color.SchemeColor = ppForeground
        End With   ' Font
       End With   ' TextRange
       End With   ' TextFrame
End With   ' oSh, the shape itself
'Set addBlockContents = oSh
End Function

恳请各位提供相关指导，非常感谢！

内容的提问来源于stack exchange，提问作者Hightower