Create List of all Building Blocks

[Greg Maxey]

There have been a few questions lately asking yow to create a list of all
building blocks in the Word2007 template collection. Here is some code that
will do that:

Option Explicit
Dim bbArray()
Dim oTmp As Template
Dim i As Long
Dim j As Long
Sub BuildList()
Dim lngCount As Long
Dim BBC As Category
Dim BBT As BuildingBlockType
lngCount = 0
For Each oTmp In Templates
For i = 1 To oTmp.BuildingBlockEntries.Count
lngCount = lngCount + 1
Next
Next
If lngCount > 0 Then
ReDim bbArray(0 To lngCount - 1, 1 To 5)
Else
ReDim bbArray(0)
End If
j = 0
For Each oTmp In Templates
For i = 1 To oTmp.BuildingBlockEntries.Count
Set BBT = oTmp.BuildingBlockEntries(i).Type
Set BBC = oTmp.BuildingBlockEntries(i).Category
bbArray(j, 1) = oTmp.BuildingBlockEntries(i).Name
bbArray(j, 2) = oTmp.Name
bbArray(j, 3) = oTmp.BuildingBlockEntries(i).Value
bbArray(j, 4) = BBT.Name
bbArray(j, 5) = BBC.Name
j = j + 1
Next
Next
CreateList
Set BBT = Nothing
Set BBC = Nothing
StatusBar = "List complete"
System.Cursor = wdCursorNormal
End Sub
Sub CreateList()
Dim oDoc As Word.Document
Dim oRng As Word.Range
Dim pStr As String
Dim oTbl As Word.Table
Set oDoc = Documents.Add
System.Cursor = wdCursorWait
With oDoc.PageSetup
.Orientation = wdOrientLandscape
.LeftMargin = 36
.RightMargin = 36
End With
Set oRng = oDoc.Range
Set oTbl = oDoc.Tables.Add(oRng, UBound(bbArray) + 3, 5)
StatusBar = "Creating list. Please wait"
Application.ScreenUpdating = False
With oTbl
.Columns(1).Width = 100
.Columns(2).Width = 100
.Columns(3).Width = 300
.Columns(4).Width = 110
.Columns(5).Width = 110
.Rows(1).Cells.Merge
.Cell(1, 1).Range.Text = "BuildingBlocks"
For i = 1 To 5
.Cell(2, i).Range.Text = Choose(i, "Name", "Template", "Value",
"Gallery", "Category")
Next
For i = 0 To UBound(bbArray)
For j = 1 To 5
.Cell(i + 3, j).Range.Text = bbArray(i, j)
Next j
Next i
.Rows(1).Shading.BackgroundPatternColor = wdColorGray25
.Rows(1).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Rows(2).Shading.BackgroundPatternColor = wdColorGray10
.Rows.AllowBreakAcrossPages = False
For i = -6 To -1
With .Borders(i)
.LineStyle = Options.DefaultBorderLineStyle
.LineWidth = Options.DefaultBorderLineWidth
.Color = Options.DefaultBorderColor
End With
Next i
If MsgBox("Do you want to sort the list by building block name?", _
vbQuestion + vbYesNo, "Sort List") = vbYes Then
.Rows(1).ConvertToText
.Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType _
:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
End If
End With
Application.ScreenUpdating = True
Beep
End Sub

 

[jec]

As always, thank you Greg

jec
www.ribbonspace.com