Option Explicit
Dim AppVisio As Object
Sub CreateLinkedVisioBoxesForRow2AndDown()
Dim lLastRow As Long
Dim lRowIndex As Long
Dim lLastColumn As Long
Dim aryRowData() As Variant
Dim lDrawingCount As Long
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lRowIndex = 2 To lLastRow 'Assuming headers. If no headers, change 2 to 1
lDrawingCount = lDrawingCount + 1
Application.StatusBar = "Creating Drawing " & lDrawingCount
lLastColumn = Cells(lRowIndex, Columns.Count).End(xlToLeft).Column
aryRowData = Range(Cells(lRowIndex, 1), Cells(lRowIndex, lLastColumn)).Value
DropStringOfBoxes aryRowData
Next
MsgBox lDrawingCount & " drawing" & IIf(lDrawingCount > 1, "s", "") & " 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, 2) To UBound(aryRange, 2)
ReDim Preserve aryContents(0 To lAryRangeIndex)
aryContents(lAryRangeIndex) = aryRange(1, lAryIndex)
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 PowerPoint 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
'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
Dim vsoCharacters1 As Object
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 = "18 pt" 'visSectionCharacter, 0, visCharacterSize
Set vsoCharacters1 = Nothing
End SubSub FlowChartInVisio()
Const FlowchartTemplateName$ = "Basic Flowchart.vst"
Const FlowchartStencilName$ = "BASFLO_M.VSS"
Const MasterProcessName$ = "Process"
Const MasterDecisionName$ = "Decision"
Const MasterTerminatorName$ = "Terminator"
Dim doc As Visio.Document
Dim vsoShape1 As Visio.Shape
Dim shapeIDArray() As Integer
Dim searching As Boolean
Dim vsoPage As Visio.Page
Dim shapeList
Dim docFlowTemplate As Visio.Document
Dim docFlowStencil As Visio.Document
Set docFlowTemplate = Visio.Documents. _
Add(FlowchartTemplateName) ' New document will be added
Set vsoPage = Application.ActivePage ' page will get activated
'Shapes("Start/End") --- Process initiation
For Each doc In Visio.Documents ' it will search the open document for flowchart stensil
If (doc.Name = FlowchartStencilName) Then
Set docFlowStencil = doc
Exit For
End If
Next
Set doc = Nothing
Dim mstProcess As Visio.Master
Dim mstDecision As Visio.Master
Dim conn As Variant
Set mstProcess = _
docFlowStencil.Masters.ItemU(MasterProcessName)
Set mstDecision = _
docFlowStencil.Masters.ItemU(MasterDecisionName)
Set mstTerminator = _
docFlowStencil.Masters.ItemU(MasterTerminatorName)
Set conn = Visio.Application.ConnectorToolDataObject
Const NumShapes% = 15
Const DecisionStepNumber% = 4
Dim i As Integer
Dim x As Double, y As Double
Const dx# = 2.5
Const dy# = 1.5
Dim pg As Visio.Page
Dim shpNew As Visio.Shape
Dim shpLast As Visio.Shape
Dim shpConn As Visio.Shape
Dim shpDec As Visio.Shape
Set pg = docFlowTemplate.Pages.Item(1)
x = pg.PageSheet.CellsU("PageWidth").ResultIU / 3
y = pg.PageSheet.CellsU("PageHeight").ResultIU - 2
For i = 1 To NumShapes
If i = DecisionStepNumber Then
Set shpNew = pg.Drop(mstDecision, x, y)
shpNew.Text = " Whether site is WLA ATM ?"
Set shpDec = shpNew
Else
If i = 1 Then
Set shpNew = pg.Drop(mstTerminator, x, y)
shpNew.Text = "Start"
Else
If i = 2 Then
Set shpNew = pg.Drop(mstProcess, x, y)
shpNew.Text = "L9"
Else
If i = 3 Then
Set shpNew = pg.Drop(mstProcess, x, y)
shpNew.Text = "L8"
Else
If i = 5 Then
Set shpNew = pg.Drop(mstProcess, x, y)
shpNew.Text = "L7"
Else
If i = 6 Then
Set shpNew = pg.Drop(mstProcess, x, y)
shpNew.Text = "L6"
Else
If i = 7 Then
Set shpNew = pg.Drop(mstDecision, x, y)
shpNew.Text = "L5"
Set shpDec = shpNew
Else
If i = 8 Then
Set shpNew = pg.Drop(mstProcess, x, y)
shpNew.Text = "L4"
Else
If i = 9 Then
Set shpNew = pg.Drop(mstDecision, x, y)
shpNew.Text = "L3"
Set shpDec = shpNew
Else
If i = 10 Then
Set shpNew = pg.Drop(mstProcess, x, y)
shpNew.Text = "L2"
Set shpDec = shpNew
Else
If i = 11 Then
Set shpNew = pg.Drop(mstDecision, x, y)
shpNew.Text = "L1"
Set shpDec = shpNew
Else
Set shpNew = pg.Drop(mstTerminator, x, y)
shpNew.Text = "End"
Set shpDec = shpNew
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
shpNew.Cells("Prop.Cost").ResultIU = i
shpNew.Cells("Prop.Duration"). _
Result(Visio.VisUnitCodes.visElapsedHour) = i
If (i <> 1) Then
Set shpConn = pg.Drop(conn, 0, 0)
If (i = DecisionStepNumber + 1) Then
Call shpConn.CellsU("BeginX"). _
GlueTo(shpDec.CellsU("Connections.X2"))
Else
Call shpConn.CellsU("BeginX"). _
GlueTo(shpLast.CellsU("PinX"))
End If
Call shpConn.CellsU("EndX"). _
GlueTo(shpNew.CellsU("PinX"))
End If
Set shpLast = shpNew
Select Case i
Case DecisionStepNumber
x = x + dx
Case (DecisionStepNumber + 1)
x = x - dx
y = y - dy
shpConn.Text = "No"
Set shpLast = shpDec
Case Else
y = y - dy
End Select
Next i
Visio.ActiveWindow.DeselectAll
Call Visio.Windows. _
Arrange(Visio.visArrangeTileVertical)
End Sub
Sub draw_visio_with_containers()
'put process names into column A, group name into column B, number of people into column C
'turn off application functions like calculation, events, display alerts
With Application
.DisplayAlerts = False
.EnableEvents = False
'.ScreenUpdating = False
End With
'define variables related to visio
Dim AppVisio As Object
Dim lLastArrayRow As Long
Dim vArray As Variant
Dim WS2 As Worksheet
Dim bfound As Boolean
Dim lX As Long, lY As Long, lZ As Long, lQ As Long
Dim sngPageWidth As Single
Dim sngPageHeight As Single
Dim vsoSelection As Visio.Selection
Dim lngShapeIDs() As Long
Dim lngShapeID As Long
Dim lngContainerIDs() As Long
Dim lngContainerID As Long
Dim sngShapeHCenter As Single
Dim sngShapeVCenter As Single
Dim sngPlotCount As Single
Dim aryPlotted() As Variant
Dim aryPlotted2() As Variant
Dim IsInArray As Variant
Dim vsoDoc1 As Visio.Document
Dim shpData1 As String
Dim cntrData1 As String
Dim vsoPage As Visio.Page
Dim vsoContainerShape As Visio.Shape
Dim visShape As Visio.Shape
Dim containerId As Variant
Dim yoffset
'specify height/width for all regular shapes (not containers)
Const sngShapeHeight As Single = 0.3
Const sngShapeWidth As Single = 2
'define the last row with active data
lLastArrayRow = Cells(Rows.Count, 1).End(xlUp).Row
'open new instance of Visio application
Set AppVisio = CreateObject("visio.application")
AppVisio.Visible = True
With AppVisio
.ScreenUpdating = False
End With
'Open new Visio document
AppVisio.Documents.AddEx "", visMSDefault, 0
AppVisio.ActiveWindow.Page.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).FormulaU = "11 in"
AppVisio.ActiveWindow.Page.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).FormulaU = "17 in"
'Add required stencils
AppVisio.Documents.OpenEx "basflo_u.vss", visOpenRO + visOpenDocked
AppVisio.Documents.OpenEx "connec_u.vss", visOpenRO + visOpenDocked
'define vsoDoc1 variable as container stencil within this document
Set vsoDoc1 = AppVisio.Documents.OpenEx(AppVisio.GetBuiltInStencilFile(visBuiltInStencilContainers, visMSUS), visOpenHidden)
'define the area where new shapes/containers will be placed on the visio
sngPageWidth = AppVisio.ActivePage.PageSheet.Cells("pagewidth") '* 3
sngPageHeight = AppVisio.ActivePage.PageSheet.Cells("pageHeight") '* 3
'define range for array to be used later
vArray = ActiveSheet.Range(("A2:C" & Cells(Rows.Count, "A").End(xlUp).Row), Cells(lLastArrayRow, 1))
'this array will keep a record of all the shape names (as defined by vArray value) as they get created
ReDim Preserve aryPlotted(1 To 1)
ReDim aryPlotted2(1 To 1)
aryPlotted(1) = "xyzzy"
'create a loop that iterates through rows (lX)
For lX = LBound(vArray, 1) To UBound(vArray, 1) '0 to X
bfound = False
'Compare to shapes just plotted
For lZ = LBound(aryPlotted) To UBound(aryPlotted)
If aryPlotted(lZ) = vArray(lX, 1) Then
bfound = True
Exit For
End If
Next
If Not bfound Then 'If not then add it
'define shape location (where will shape land on page when drawn)
sngPlotCount = sngPlotCount + 1 'move down 2 vertical units each time a new shape is drawn
sngPlotCount2 = (sngPlotCount * -1) + 4 'vertical starting plot position
ReDim Preserve aryPlotted(1 To sngPlotCount)
aryPlotted(sngPlotCount) = vArray(lX, 1) 'name of shape to be drawn
With AppVisio.ActiveWindow.Page
.Drop AppVisio.Documents.Item("BASFLO_U.VSS").Masters.ItemU("Process"), 2.25, sngPlotCount2 'draw basic shape and put it sngPlotCount2 vertical location on Visio page
Set vsoSelection = AppVisio.ActiveWindow.Selection
Call vsoSelection.GetIDs(lngShapeIDs) 'get the ID of the shape just drawn and put it in array called 'lngShapeIDs'
'with the shape just drawn...
With .Shapes.ItemFromID(lngShapeIDs(0))
.CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = sngShapeHCenter 'move shape just drawn to its horizontal position
.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = sngShapeWidth 'modify shape width
.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = sngShapeHeight 'modify shape height
.Characters.Text = vArray(lX, 1) & " - " & vArray(lX, 3) 'place text inside shape
.Name = vArray(lX, 1) & " - " & vArray(lX, 3) 'name the shape
.Data1 = vArray(lX, 2) 'this is needed to associate the shape to the container it will be in
End With
End With
lQ = lX 'sync up lQ with current row that lX is on
For lQ = LBound(aryPlotted2) To UBound(aryPlotted2)
'If the value currently active in the loop (vArray) is not saved to the array called "aryPlotted2",
'then create container for it and put selected shape in it, then call up the container shape ID for it and put it in array lngContainerIDs:
If aryPlotted2(lQ) = "" Then aryPlotted2(lQ) = Chr(1)
IsInArray = (UBound(Filter(aryPlotted2, Chr(1) & vArray(lX, 2) & Chr(1))) > -1)
If Not IsInArray Then
aryPlotted2(lQ) = aryPlotted2(lQ) & vArray(lX, 2) & Chr(1)
AppVisio.ActivePage.DropContainer vsoDoc1.Masters.ItemFromID(2), AppVisio.ActiveWindow.Selection
Set vsoSelection = AppVisio.ActiveWindow.Selection
Call vsoSelection.GetIDs(lngContainerIDs)
AppVisio.ActivePage.Shapes.ItemFromID(lngContainerIDs(0)).Text = vArray(lX, 2) 'place text inside container
AppVisio.ActivePage.Shapes.ItemFromID(lngContainerIDs(0)).Name = vArray(lX, 2) 'name the container
AppVisio.ActivePage.Shapes.ItemFromID(lngContainerIDs(0)).Data1 = vArray(lX, 2) 'place data in data1 field of container. Later portion of the script searches for this for shape placement in container
AppVisio.ActiveWindow.Selection.SetContainerFormat visContainerFormatFitToContents 'adjust shape of container to fit around the shape in it
Exit For
Else
'move shape to correct existing container location and add the shape to that container:
Set vsoSelection = AppVisio.ActiveWindow.Selection
Call vsoSelection.GetIDs(lngShapeIDs) 'get the ID of the new shape just drawn
shpData1 = AppVisio.ActivePage.Shapes.ItemFromID(lngShapeIDs(0)).Data1 'get the text string from Data1 field of the shape and define it as "shpData1"
Set vsoPage = AppVisio.ActivePage
'loop through all containers on the visio page...
For Each containerId In vsoPage.GetContainers(visContainerIncludeNested)
Set vsoContainerShape = vsoPage.Shapes.ItemFromID(containerId)
cntrData1 = AppVisio.ActivePage.Shapes.ItemFromID(containerId).Data1 'get the text string from Data1 field of each container and define it as "cntrData1"
If shpData1 = cntrData1 Then 'if there is a match between active shpData1 and current cntrData1 in the loop then...
Set visShape = AppVisio.ActivePage.Shapes.ItemFromID(lngShapeIDs(0)) 'get the shape ID of the active shape
visShape.Cells("pinx").ResultIU = vsoContainerShape.Cells("pinx").ResultIU 'move active shape to same horizontal position as current container in loop
visShape.Cells("piny").ResultIU = vsoContainerShape.Cells("piny").ResultIU 'move active shape to same vertical position as current container in loop
'active shape should now be centered directly on top of current container in the loop
vsoContainerShape.ContainerProperties.SetMargin visInches, 0.25
vsoContainerShape.ContainerProperties.AddMember vsoSelection, visMemberAddUseResizeSetting 'add active shape as a member of the current conatiner in the loop
' get an enumerable list of shape ids that are already in the container
Dim colMembers As Collection
Set colMembers = getMembersOfContainer(vsoContainerShape)
If 0 < colMembers.Count Then 'count how many shapes in active container, required to help space out the shapes properly
Dim intX As Integer
For intX = 1 To colMembers.Count
If colMembers.Item(intX) = visShape.ID Then
Exit For
End If
Next intX
yoffset = (intX - 1) * 0.25
End If
' put the new member near the top of the container
visShape.Cells("pinY").FormulaU = vsoContainerShape.Cells("PinY").Result("in") + yoffset 'yoffset determines how high up in the container the shape should be positioned
visShape.Cells("pinX").FormulaU = vsoContainerShape.Cells("PinX").FormulaU
vsoContainerShape.ContainerProperties.ResizeAsNeeded = visContainerAutoResizeExpandContract
vsoContainerShape.ContainerProperties.ResizeAsNeeded = visContainerAutoResizeExpand
' active shape should now be positioned at the top position inside of the container
Exit For
End If
Next
Exit For
End If
Exit For
Next
End If
Next
vsoDoc1.Close 'close out the container stencils, if not the stencil will remain locked to the visio file created by this script
With Application
.DisplayAlerts = True
.EnableEvents = True
.ScreenUpdating = True
End With
With AppVisio
.ScreenUpdating = True
End With
AppVisio.Visible = True
Set vsoSelection = Nothing
Set AppVisio = Nothing
End Sub
' pass in a container and return a collection of shapeIds
Public Function getMembersOfContainer _
(ByRef vsoContainerShape As Visio.Shape) _
As Collection
On Error GoTo ErrHandler
Dim colReturn As Collection
Set colReturn = New Collection
Dim arrMember() As Long
arrMember = vsoContainerShape.ContainerProperties.GetMemberShapes(VisContainerFlags.visContainerFlagsDefault)
Dim memberId As Long
Dim intI As Integer
For intI = 0 To UBound(arrMember)
colReturn.Add (arrMember(intI))
Next
Set getMembersOfContainer = colReturn
Exit Function
ErrHandler:
Debug.Print "getMembersOfContainer " & Err.Description
Set getMembersOfContainer = colReturn
End Function
