New to Visio VBA - Simple Object Question

Started by mrmmickle1, January 12, 2023, 01:07:18 PM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

mrmmickle1

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


Yacine

#1
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
Yacine

mrmmickle1

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!