Hello-
I am trying to iterate through an excel list and insert shapes connected to each other. Each connection arrow would come from the bottom of the shape to the top of the next shape. All shapes would be spaced one inch apart.
I have referenced this thread (http://visguy.com/vgforum/index.php?topic=7450.0) and have got it working as far as putting the shapes on the empty page. However, I am at a loss as to connect them.
I will post the code here for reference:
Sub MyMac()
'
' The macro is now interactive. Once the initial selection of Excel cells has been copied
' to Visio shapes, macro asks to exit or not. If not, it will prompt to make a new set of
' cell selections. If this is not desired from current Excel file, it will prompt for a new
' file. NOTE, if a new selection in current file is desired, you will have to click on the
' Excel window to regain its focus.
'
' Before exiting the sub, you will be prompted to save changes to existing Excel file.
'
' This macro has updated code to begin "hunt" for Excel file beginning with
' Visio drawing root directory. Old code is still here, commented out.
' It is still possible to search other directories.
'
' The following references are used:
' Visual Basic for Applications
' Microsoft Visio Type Library
' OLE Automation
' Microsoft Office Object Library
' Microsoft Excel Object Library
' You'll have to choose the appropriate versions based upon your installation
'
Dim XlApp As Object
Dim XlWrkbook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim rng As Range
Dim docPath As Variant
Dim vsoCharacters1 As Visio.Characters
Dim visSel As Visio.Shape
Dim ptX1 As Double
Dim ptX2 As Double
Dim ptY1 As Double
Dim ptY2 As Double
Dim dltX As Double
Dim dltY As Double
'Initial shape location
ptX1 = 3
ptX2 = 5
ptY1 = 3
ptY2 = 4 '.3.5
dltX = 0 '0.25
dltY = -2 '0.25
docPath = ActiveDocument.Path
Set XlApp = CreateObject("Excel.Application")
SelFile:
With XlApp.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Filters.Add "Excel Files", "*.xls, *.xlsx, *.xlsm"
.InitialFileName = docPath
.Show
XlApp.Workbooks.Open FileName:=.SelectedItems(1)
End With
Set XlWrkbook = XlApp.Workbooks(1)
Set XlSheet = XlWrkbook.Worksheets("Sheet1")
XlApp.Visible = True
' Old file hunting routine:
' Dim fNameAndPath As Variant
'
' fNameAndPath = XlApp.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS, (*.XLSX), *.XLSX, (*.XLSM), *.XLSM", Title:="Select File To Be Opened")
' If fNameAndPath = False Then Exit Sub
' XlApp.Workbooks.Open FileName:=fNameAndPath
' Set XlWrkbook = Workbooks.Open(fNameAndPath)
' Set XlSheet = XlWrkbook.Worksheets("Sheet1")
' XlApp.Visible = True
SelCells:
Set rng = XlApp.InputBox("Select a range", "Obtain Range Object", Type:=8)
'Transfer Excel contents to Visio shapes on active page
For Each Cell In rng
Cell.Copy
Visio.ActiveWindow.Page.DrawRectangle ptX1, ptY1, ptX2, ptY2
Set visSel = Visio.ActiveWindow.Selection(1)
Set vsoCharacters1 = visSel.Characters
vsoCharacters1.Begin = 0
vsoCharacters1.End = 0
ActiveWindow.SelectedText = vsoCharacters1
ActiveWindow.SelectedText.Paste
' Options: remove fill and line patterns-> only text is visible
visSel.TextStyle = "Normal"
visSel.LineStyle = "Text Only"
visSel.FillStyle = "Text Only"
ActiveWindow.DeselectAll
' Increment next shape location:
ptX1 = ptX1 + dltX
ptX2 = ptX2 + dltX
ptY1 = ptY1 + dltY
ptY2 = ptY2 + dltY
Next
' User Prompts:
If MsgBox("Exit Subroutine?", vbYesNo, "Exit Sub") = vbYes Then
GoTo EndIt
End If
If MsgBox("Make additional selections?", vbYesNo, "Continue Selections") = vbYes Then
GoTo SelCells
End If
If MsgBox("Select new Excel file?", vbYesNo, "Select File") = vbYes Then
GoTo SelFile
End If
EndIt:
If MsgBox("Save Excel file changes?", vbYesNo, "Excel Update") = vbYes Then
XlWrkbook.Close SaveChanges:=True
Else
XlWrkbook.Close SaveChanges:=False
End If
XlApp.Quit
End Sub
I would like to simply add a connector line to this code. Can anyone please tell me how the above code can be modified to achieve this goal. Thank you in advance.
I tried referring to this example (https://learn.microsoft.com/en-us/office/vba/api/visio.shape.autoconnect) but I'm a bit confused how it works. It appears to me that it will not execute without first having these objects on the diagram? Is there a simple way to add 1 object then add another then connect them? I'm obviously missing something quite simple. I would think the below would work but it doesn't.
Public Sub AutoConnect_Example()
Dim vsoShape1 As Visio.Shape
Dim vsoShape2 As Visio.Shape
Dim vsoConnectorShape As Visio.Shape
Set vsoShape1 = Visio.ActivePage.Shapes("Decision")
Set vsoShape2 = Visio.ActivePage.Shapes("Process")
Set vsoConnectorShape = Visio.ActivePage.Shapes("Dynamic connector")
vsoShape1.AutoConnect vsoShape2, visAutoConnectDirRight, vsoConnectorShape
End Sub
In order to connect two shapes you need to get a handle on them in one way or the other.
First tip to use, is that the drop method returns the shape object newly created. So instead of only "dropping", you assert the drop method to shp1.
set shp1 = ... drop ...
Now, iterating over the excel range if you store this object for the next loop, you can re-use it to connect to the current one:
shp2.autoconnect shp1 ...
Then set the current shape to be the previous one:
set shp2 = shp1
Since for the very first element you won't have a previous one, you would check for "nothing" (That is when you first enter the loop):
if not shp2 is nothing then ...
Remark: instead of drawing and formatting the shape over and over again, you might consider first creating a master and reuse it in the loop.
Something like set masterShp = ....
+ formatting
Then set shp1 = activepage.drop mastershp, x,y
You may as well store it in a stencil (the doc stencil or another dedicated one).
This way you can move the formatting code to extensive formatting or "shapesheet" smartness without too much coding.
Option Explicit
Sub MyMac()
'
' The macro is now interactive. Once the initial selection of Excel cells has been copied
' to Visio shapes, macro asks to exit or not. If not, it will prompt to make a new set of
' cell selections. If this is not desired from current Excel file, it will prompt for a new
' file. NOTE, if a new selection in current file is desired, you will have to click on the
' Excel window to regain its focus.
'
' Before exiting the sub, you will be prompted to save changes to existing Excel file.
'
' This macro has updated code to begin "hunt" for Excel file beginning with
' Visio drawing root directory. Old code is still here, commented out.
' It is still possible to search other directories.
'
' The following references are used:
' Visual Basic for Applications
' Microsoft Visio Type Library
' OLE Automation
' Microsoft Office Object Library
' Microsoft Excel Object Library
' You'll have to choose the appropriate versions based upon your installation
'
Dim XlApp As Object
Dim XlWrkbook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim rng As Range
Dim docPath As Variant
Dim vsoCharacters1 As Visio.Characters
Dim visSel As Visio.Shape
Dim ptX1 As Double
Dim ptX2 As Double
Dim ptY1 As Double
Dim ptY2 As Double
Dim dltX As Double
Dim dltY As Double
'Initial shape location
ptX1 = 3
ptX2 = 5
ptY1 = 3
ptY2 = 4 '.3.5
dltX = 0 '0.25
dltY = -2 '0.25
docPath = ActiveDocument.Path
Set XlApp = CreateObject("Excel.Application")
SelFile:
With XlApp.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Filters.Add "Excel Files", "*.xls, *.xlsx, *.xlsm"
.InitialFileName = docPath
.Show
XlApp.Workbooks.Open FileName:=.SelectedItems(1)
End With
Set XlWrkbook = XlApp.Workbooks(1)
Set XlSheet = XlWrkbook.Worksheets(1)
XlApp.Visible = True
' Old file hunting routine:
' Dim fNameAndPath As Variant
'
' fNameAndPath = XlApp.GetOpenFilename(FileFilter:="Excel Files (*.XLS), *.XLS, (*.XLSX), *.XLSX, (*.XLSM), *.XLSM", Title:="Select File To Be Opened")
' If fNameAndPath = False Then Exit Sub
' XlApp.Workbooks.Open FileName:=fNameAndPath
' Set XlWrkbook = Workbooks.Open(fNameAndPath)
' Set XlSheet = XlWrkbook.Worksheets("Sheet1")
' XlApp.Visible = True
SelCells:
Set rng = XlApp.InputBox("Select a range", "Obtain Range Object", Type:=8)
'Transfer Excel contents to Visio shapes on active page
' For Each Cell In rng
' Cell.Copy
'
' Visio.ActiveWindow.Page.DrawRectangle ptX1, ptY1, ptX2, ptY2
' Set visSel = Visio.ActiveWindow.Selection(1)
' Set vsoCharacters1 = visSel.Characters
' vsoCharacters1.Begin = 0
' vsoCharacters1.End = 0
' ActiveWindow.SelectedText = vsoCharacters1
' ActiveWindow.SelectedText.Paste
'
'' Options: remove fill and line patterns-> only text is visible
' visSel.TextStyle = "Normal"
' visSel.LineStyle = "Text Only"
' visSel.FillStyle = "Text Only"
'
' ActiveWindow.DeselectAll
'
'' Increment next shape location:
' ptX1 = ptX1 + dltX
' ptX2 = ptX2 + dltX
' ptY1 = ptY1 + dltY
' ptY2 = ptY2 + dltY
'
' Next
Dim shp1 As Shape
Dim shp2 As Shape
Dim conn As Shape
Dim cell As Excel.Range
For Each cell In rng
Set shp1 = ActiveWindow.Page.DrawRectangle(ptX1, ptY1, ptX2, ptY2)
shp1.Text = cell.Value
' Options: remove fill and line patterns-> only text is visible
shp1.Cells("LinePattern").FormulaU = 0
shp1.Cells("FillPattern").FormulaU = 0
shp1.Cells("Width").FormulaU = "TEXTWIDTH(TheText)"
shp1.Cells("Height").FormulaU = "TEXTHEIGHT(TheText,Width)"
If Not shp2 Is Nothing Then
shp2.AutoConnect shp1, visAutoConnectDirDown
End If
Set shp2 = shp1
' Increment next shape location:
ptX1 = ptX1 + dltX
ptX2 = ptX2 + dltX
ptY1 = ptY1 + dltY
ptY2 = ptY2 + dltY
Next
' User Prompts:
If MsgBox("Exit Subroutine?", vbYesNo, "Exit Sub") = vbYes Then
GoTo EndIt
End If
If MsgBox("Make additional selections?", vbYesNo, "Continue Selections") = vbYes Then
GoTo SelCells
End If
If MsgBox("Select new Excel file?", vbYesNo, "Select File") = vbYes Then
GoTo SelFile
End If
EndIt:
If MsgBox("Save Excel file changes?", vbYesNo, "Excel Update") = vbYes Then
XlWrkbook.Close SaveChanges:=True
Else
XlWrkbook.Close SaveChanges:=False
End If
XlApp.Quit
End Sub
Hey Yacine-
Thanks so much for the help. I have a fair amount of experience with VBA in other applications so your explanations make perfect sense. Still trying to get a handle on the Visio object model as it is quite different then the other one's I'm used to (Excel, Outlook or Access). I haven't really ever had the need to use Visio until recently. I'm so grateful to have found this forum and I will look forward to more communication down the line as I continue to learn.
I really appreciate your assistance. You rock!