Powerpoint layout algorithm for box-in-box view - vba

Question

I am trying to write some code in VBA and PowerPoint to automatically create a poster (basically a box in box view) however, its proving to be a little more challenging than my skills can cope.
looking to get some guidance on how best to structure the code (and patterns)
at the moment:
Im reading the data (see table) from csv, and placing them into 4 in memory arrays (cat, sub-cat, column, intersection) - this is probably bad - but dont know of anything better.
my code tries to process the spacing logic and adjusts the x-and-y pos of each intersection block (grows the category and sub-category blocks when needed) within the arrays, then finally draws/places the blocks on the powerpoint canvas.
You will see in the graphic "initial selected block" at the moment thats the context from which i run -- the idea is to use that block size as the template for the dimensions
Im not worried about the placement, its more the algorithm to determine the spacing (or block size of each of the components
below is a sample of the data that I read:
and once the logic is generated, this is how the "poster" would look
Im happy to share code, its just getting a bit big now (and I feel im missing a trick in terms of simplicity)
code sample included below:
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
any help will be awesome!

Answer 1

The easiest way to get started here is to use tables. It will help you with a lot of the layout issues.
As a first step, create a table manually. Insert a table and remove headings and other automatic coloring. Set the border line to maximum width and to match the background color before applying it to all cells.
Now you can merge cells to create larger boxes (like Cars in your example). Deleting cells isn't possible, but you can set the background color.
If this is good enough, then you have something to automate.
If not, then you can perhaps use this to find coordinates for boxes to create.