Option Explicit
Dim AppVisio As Object
Sub CreateLinkedVisioBoxesForColumn1Data()
'http://www.mrexcel.com/forum/excel-questions/865121-create-visio-flowchart-diagram-excel-row-data.html
'For each cell in column A starting in A1, create a rectangle in Visio and connect to the next box
'Note, if you turn off Visio ScreenUpdating, then the font size reduction feature will not work correctly.
' apparently the ShapeSheet TextHeight & TextWidth functions need the ScreenUpdating = True to work.
' So live with the flicker.
Dim lLastRow As Long
Dim aryRowData() As Variant
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
aryRowData = Range(Cells(1, 1), Cells(lLastRow, 1)).Value
DropStringOfBoxes aryRowData
MsgBox lLastRow & " box drawing created.", , "Complete"
End Sub
Sub DropStringOfBoxes(aryRange() As Variant)
'Given an array, create a grid of vision boxes connected in order
'Dim aryRange() As Variant '(1,1)...(1,N)
Dim aryContents() As Variant '0...N
Dim lAryIndex As Long
Dim lAryRangeIndex As Long
Dim lShapeIndex As Long
Dim sngX As Single
Dim sngY As Single
Dim sngDeltaX As Single
Dim sngDeltaY As Single
Dim lLastDropIndex As Long
Dim lCurrDropIndex As Long
Dim bAllInSameVisio As Boolean
bAllInSameVisio = True
'If using hard-coded array
' aryContents = Array("AAAAAAAAAA", "BBBBBBBBBB", "CCCCCCCCCC", "DDDDDDDDDD", "EEEEEEEEEE", "FFFFFFFFFF", "GGGGGGGGGG")
'If using a selection as input (Only takes cells in first area, read Left to Right, Top to Bottom
' aryRange = Selection.Value
' For lAryIndex = 1 To Selection.Cells.Count
' ReDim Preserve aryContents(0 To lAryRangeIndex)
' aryContents(lAryRangeIndex) = Selection.Cells(lAryIndex)
' lAryRangeIndex = lAryRangeIndex + 1
' Next
'If using input parameter array
For lAryIndex = LBound(aryRange, 1) To UBound(aryRange, 1)
ReDim Preserve aryContents(0 To lAryRangeIndex)
aryContents(lAryRangeIndex) = aryRange(lAryIndex, 1)
lAryRangeIndex = lAryRangeIndex + 1
Next
sngDeltaX = 2
sngDeltaY = 1.25
sngX = 1
sngY = 10.25
If bAllInSameVisio Then
'Is Visio already running
On Error Resume Next
' Check whether Visio is running
Set AppVisio = GetObject(, "Visio.Application")
If AppVisio Is Nothing Then
' Visio is not running, create new instance
Set AppVisio = CreateObject("visio.Application")
AppVisio.Visible = True
End If
Else
'Open new copy of Visio
Set AppVisio = CreateObject("visio.Application")
AppVisio.Visible = True
End If
On Error GoTo 0
'Add New Drawing
AppVisio.Documents.AddEx "basicd_u.vst", 0, 0
'Open Stencils if other shapes are required
'AppVisio.Documents.OpenEx "comps_u.vss", 2 + 4 'visOpenRO + visOpenDocked
'AppVisio.Documents.OpenEx "periph_u.vss", 2 + 4 'visOpenRO + visOpenDocked
'AppVisio.Documents.OpenEx "basic_u.vss", 2 + 4 'visOpenRO + visOpenDocked
'Drop first shape
AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("BASIC_U.VSS").Masters.ItemU("Rectangle"), sngX, sngY
lLastDropIndex = AppVisio.ActiveWindow.Selection.PrimaryItem.ID
SetShapeText lLastDropIndex, CStr(aryContents(0))
For lShapeIndex = LBound(aryContents) + 1 To UBound(aryContents)
'Calculate Position
sngY = sngY - sngDeltaY
If sngY < 1 Then
sngY = 10.25
sngX = sngX + sngDeltaX
End If
'Save index of last dropped stencil
lLastDropIndex = AppVisio.ActiveWindow.Selection.PrimaryItem.ID
'Drop Current stencil
AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("BASIC_U.VSS").Masters.ItemU("Rectangle"), sngX, sngY
lCurrDropIndex = AppVisio.ActiveWindow.Selection.PrimaryItem.ID
SetShapeText lCurrDropIndex, CStr(aryContents(lShapeIndex))
'Connect Last to Current
AppVisio.ActivePage.Shapes.ItemFromID(lLastDropIndex).AutoConnect AppVisio.ActivePage.Shapes.ItemFromID(lCurrDropIndex), 0
'Save Current as Last (for next loop)
lLastDropIndex = lCurrDropIndex
Next
Set AppVisio = Nothing
End Sub
Sub SetShapeText(lShapeID As Long, sEntry As String)
'Add Text to Shape, reduce font size from the default size if the text is outside the shame
Dim vsoCharacters1 As Object
Dim sShapename As String
Dim sngTextHeight As Single
Dim sngFontDefaultSize As Single
Dim vShapeheight As Variant
sngFontDefaultSize = 18 'Initial size of font in points
sngFontMinimumSize = 8 'Minimum size of font in points
Set vsoCharacters1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Characters
vsoCharacters1.Begin = 0
vsoCharacters1.End = 0
vsoCharacters1.Text = sEntry
AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(3, 0, 7).FormulaU = sngFontDefaultSize & " pt" 'visSectionCharacter, 0, visCharacterSize
vShapeheight = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(1, 1, 3).FormulaU 'visSectionObject, visRowXFormOut, visXFormHeight
vShapeheight = Replace(vShapeheight, " in", "")
'Add a user-defined cell that contains the height of the textbox
AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).OpenSheetWindow 'Open Shape ShapeSheet
AppVisio.ActiveWindow.Shape.AddRow 242, 0, 0 'visSectionUser, 0, visTagDefault
AppVisio.ActiveWindow.Shape.CellsSRC(242, 3, 0).RowNameU = "TextHeight" 'visSectionUser, 3, visUserValue
AppVisio.ActiveWindow.Shape.CellsSRC(242, 3, 0).FormulaU = "TEXTHEIGHT(TheText,width)" 'visSectionUser, 3, visUserValue
'If the text box is taller than the shape height, reduce text font size by .5 pt until it is smaller or font size = 8 pt
sngTextHeight = AppVisio.ActiveWindow.Shape.CellsSRC(242, 3, 0) 'visSectionUser, 3, visUserValue
Do While sngTextHeight > vShapeheight And sngFontDefaultSize > sngFontMinimumSize
sngFontDefaultSize = sngFontDefaultSize - 0.5
sngTextHeight = AppVisio.ActiveWindow.Shape.CellsSRC(242, 3, 0) 'visSectionUser, 3, visUserValue
AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(3, 0, 7).FormulaU = sngFontDefaultSize & " pt"
Loop
AppVisio.ActiveWindow.Close 'Close Shape ShapeSheet
Set vsoCharacters1 = Nothing
End Sub