VBA

Here's the little sample I ran. This code doesn't do anything with the results, it simply queries the shapes for formulas in two different ways.

Private Sub useCellsSRC(pg As Visio.Page)
Dim shp As Visio.Shape
Dim shps As Visio.Shapes
Dim cell As Visio.cell
Dim cnt As Integer
Dim idx As Integer
Dim rowCnt As Integer
Dim strOut As String

rowCnt = 0
Set shps = pg.Shapes

Dim startTime As Date
startTime = Time

For idx = 1 To shps.Count
Set shp = shps(idx)

If (Not shp Is Nothing) Then
If (shp.SectionExists(visSectionProp, False) = True) Then
rowCnt = rowCnt + shp.RowCount(visSectionProp)
For cnt = 1 To shp.RowCount(visSectionProp)
Set cell = shp.CellsSRC(visSectionProp, cnt, visCustPropsValue)

If (Not cell Is Nothing) Then
strOut = cell.Formula
End If
Next

End If
End If
Next

Debug.Print "------------------------------- CellsSRC"
Debug.Print "Total Shapes: " & shps.Count
Debug.Print "Total Rows : " & rowCnt
Debug.Print "Total Time : " & Format(Time - startTime, "hh:mm:ss")

Set shp = Nothing
Set shps = Nothing
Set cell = Nothing
End Sub

Private Sub useGetFormulas(pg As Visio.Page)
Dim shp As Visio.Shape
Dim shps As Visio.Shapes
Dim cell As Visio.cell
Dim cnt As Integer
Dim idx As Integer
Dim rowCnt As Integer
Dim realRow As Integer
Dim formArray() As Variant

rowCnt = 0
Set shps = pg.Shapes

Dim startTime As Date
startTime = Time

For idx = 1 To shps.Count
Set shp = shps(idx)

If (Not shp Is Nothing) Then
If (shp.SectionExists(visSectionProp, False) = True) Then
rowCnt = rowCnt + shp.RowCount(visSectionProp)
' Fill the array
'
ReDim srcArray(1 To shp.RowCount(visSectionProp) * 3) As Integer
realRow = 0
For cnt = LBound(srcArray) To UBound(srcArray) Step 3
srcArray(cnt) = visSectionProp
srcArray(cnt + 1) = realRow
srcArray(cnt + 2) = visCustPropsValue
realRow = realRow + 1
Next

Call shp.GetFormulas(srcArray, formArray)
End If

End If

Next

Debug.Print "------------------------------- GetFormulas"
Debug.Print "Total Shapes: " & shps.Count
Debug.Print "Total Rows : " & rowCnt
Debug.Print "Total Time : " & Format(Time - startTime, "hh:mm:ss")

Set shp = Nothing
Set shps = Nothing
Set cell = Nothing
End Sub

Here are the results from my last run...

------------------------------- CellsSRC
Total Shapes: 938
Total Rows : 2814
Total Time : 00:00:09

------------------------------- GetFormulas
Total Shapes: 938
Total Rows : 2814
Total Time : 00:00:03

The same effect can be achieved with VBA by setting the appropriate cells in the shape's fill properties section. The snippet below will set the fill of shpObj such that it is green at its extremities and gradually more red toward its interior:

shpObj.Cells("FillPattern") = 35 ' Set fill pattern to one of available graduated fill patterns.
shpObj.Cells("FillForegnd") = 2 ' Set fill foreground color to red.
shpObj.Cells("FillBkgnd") = 3 ' Set fill background color to green.

Dim objShps As Visio.Selection, objShp As Visio.Shape
Dim objLayers As Visio.Layers, objLayer As Visio.Layer
Dim i As Integer

'get the Selection
Set objShps = Visio.ActiveWindow.Selection

'get the layers collection
Set objLayers = Visio.ActivePage.Layers
Set objLayer = objLayers("Shapes")

For i = 1 To objShps.Count
Set objShp = objShps(i)
objLayer.Add objShp, 0
Next i

End Sub

Public Sub EditMenu()

Dim visUIObj As Visio.UIObject
Dim visMenuSets As Visio.MenuSets, visMenuSet As Visio.MenuSet
Dim visMenus As Visio.Menus, visMenu As Visio.Menu
Dim visMenuItems As Visio.MenuItems, visMenuItem As Visio.MenuItem

Set visUIObj = Visio.Application.BuiltInMenus
Set visMenuSets = visUIObj.MenuSets

'get the contextmenu set for object selection
Set visMenuSet = visMenuSets.ItemAtID(visUIObjSetCntx_DrawObjSel)
Set visMenus = visMenuSet.Menus
Set visMenu = visMenus(0)
Set visMenuItems = visMenu.MenuItems

'remove the Cut, Copy and Paste items
visMenuItems(2).Delete
visMenuItems(1).Delete
visMenuItems(0).Delete

'Set the menu modifications
Visio.Application.SetCustomMenus visUIObj

End Sub