Yes of course:
The first macro help me to calculate the value inside my shape on the left depending on the values of the shapes which are connected to it by an incomming connection
Public Sub FindOffPageShapes()
Dim shp As Visio.Shape
Dim pagShape As Visio.Shape
Dim Shape1 As Visio.Shape
Dim lngShapeIDs() As Long
Dim Shape2 As Visio.Shape
Dim ConnectorsIds() As Long
Dim Shape1ConnectorId() As Long
Dim Connector As Visio.Shape
Dim Tempo As Visio.Shape
Dim lngShapeID As Long
Dim i As Integer
Dim j As Integer
Dim K As Integer
Dim Value As Double
Dim value2 As Double
Dim Value3 As Double
Set pagShape = Visio.ActivePage.PageSheet
For l = 1 To 10
For Each shp In Visio.ActivePage.Shapes
Set Shape1 = shp
If Shape1.OneD = 0 Then
Debug.Print (Shape1.Name)
lngShapeIDs = Shape1.ConnectedShapes _
(visConnectedShapesIncomingNodes, "")
For i = 0 To UBound(lngShapeIDs)
Set Shape2 = ActivePage.Shapes.ItemFromID(lngShapeIDs(i))
Shape1ConnectorId = Shape1.ConnectedShapes _
(visConnectedShapesIncomingNodes, "")
If UBound(Shape1ConnectorId) > 0 Then
Value3 = 0
For j = 0 To UBound(Shape1ConnectorId)
Set Connector = ActivePage.Shapes.ItemFromID(Shape1ConnectorId(j))
Debug.Print CStr(Connector.Text)
ConnectorsIds = Connector.GluedShapes(visGluedShapesOutgoing1D, "", Shape1)
For K = 0 To UBound(ConnectorsIds)
Set Tempo = ActivePage.Shapes.ItemFromID(ConnectorsIds(K))
value2 = CDbl(Tempo.Text) * CDbl(Connector.Data1)
Next
Value3 = Value3 + value2
Next
Debug.Print CStr(Value3)
Shape1.Data1 = CStr(Value3)
Shape1.CellsU("prop.Cost").FormulaU = Chr(34) & CStr(Value3) & Chr(34)
Else
Value = 0
ConnectorsIds = Shape1.GluedShapes(visGluedShapesIncoming1D, "", Shape2)
For j = 0 To UBound(ConnectorsIds)
Set Connector = ActivePage.Shapes.ItemFromID(ConnectorsIds(j))
Value = CDbl(Shape2.Data1) * CDbl(Connector.Text)
Debug.Print (Shape1.Name)
Debug.Print (Connector.Name)
Next
Shape1.Data1 = CStr(Value)
Shape1.CellsU("prop.Cost").FormulaU = Chr(34) & CStr(Value) & Chr(34)
End If
Next
End If
Next shp
Next l
Visio.Application.Addons("VisRpt").Run ("/rptDefName=ProjectSorting /rptOutput=EXCEL")
The next macro generated a report in a new sheet to get all the connector with input and output shapes
Sub ExcelReport(ByVal pgCnt, shpCnt, ByRef cnxArry() As Variant)
Dim i As Integer, j As Integer
Dim p As Integer
Dim m As Integer
Dim XlApp As Object
Dim XlWrkbook As Excel.Workbook
Dim XlSheet As Excel.Worksheet
Dim prpData(10, 10) As String
Set XlApp = CreateObject("Excel.Application")
Set XlWrkbook = XlApp.Workbooks.Add
Set XlSheet = XlWrkbook.Worksheets("Sheet1")
XlApp.Visible = False
XlApp.ScreenUpdating = False
XlSheet.Cells(1, 1) = "PAGE"
XlSheet.Cells(1, 2) = "CONNECTOR"
XlSheet.Cells(1, 3) = "FROM SHAPE"
XlSheet.Cells(1, 4) = "TO SHAPE"
For p = 1 To pgCnt
m = 0
j = 0
If p = 1 Then
XlWrkbook.Worksheets("Sheet" & p).Activate
ElseIf p >= 2 Then
XlWrkbook.Worksheets("Sheet" & p).Activate
Set XlSheet = XlWrkbook.Worksheets("Sheet" & p)
XlSheet.Cells(1, 1) = "PAGE"
XlSheet.Cells(1, 2) = "CONNECTOR"
XlSheet.Cells(1, 3) = "FROM SHAPE"
XlSheet.Cells(1, 4) = "TO SHAPE"
End If
For i = 1 To shpCnt
conShp = cnxArry(0, 0, 0, 0, 0, 0, 0, 0, p, i)
If conShp = Empty Then
m = m + 1
GoTo Skippy
End If
XlSheet.Cells(i + 1 + j - m, 1) = cnxArry(0, 0, 0, 0, 0, 0, 0, 0, p, 0)
XlSheet.Cells(i + 1 + j - m, 2) = cnxArry(0, 0, 0, 0, 0, 0, 0, 0, p, i)
XlSheet.Cells(i + 1 + j - m, 3) = cnxArry(0, 0, 0, 0, 0, 0, 0, 1, p, i)
XlSheet.Cells(i + 1 + j - m, 4) = cnxArry(0, 0, 0, 0, 0, 1, 1, 1, p, i)
XlSheet.Cells(i + 1 + j - m, 5) = cnxArry(0, 0, 0, 1, 1, 1, 1, 1, p, i)
Skippy:
Next i
NxtPg:
Next p
Dim LastCol As Long
Dim LastRow As Long
Dim q As Long
Dim rowCell As Range
Dim FirstRow As Range
Dim myUsedRng As Range
Dim xptSheet As Excel.Worksheet
p = 0
For Each xptSheet In XlWrkbook.Sheets
p = p + 1
xptSheet.Activate
Set myUsedRng = xptSheet.UsedRange
Set FirstRow = myUsedRng.Rows(1).Cells
LastCol = myUsedRng.Columns.Count
LastRow = myUsedRng.Rows.Count
With myUsedRng
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
'Add light borders around all individual used cells
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
'Heavy outer border around the used worksheet region
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
'Set used cell background fill to white
.Interior.Color = RGB(255, 255, 255)
End With
' Double line: selection range used is top row of cells
FirstRow.Borders(xlEdgeBottom).LineStyle = xlDouble
FirstRow.Borders(xlEdgeBottom).Weight = xlThick
'Set top row upper case, font bold, cell background fill to light yellow, and set column widths
For Each rowCell In FirstRow
rowCell = UCase(rowCell)
rowCell.Font.Bold = True
rowCell.Font.Color = RGB(0, 0, 200)
rowCell.Font.Size = 9
rowCell.Interior.Color = RGB(255, 255, 204)
rowCell.EntireColumn.AutoFit
Next rowCell
If p <= pgCnt Then
Call VisPushBack(myUsedRng, xptSheet.Name)
End If
Next xptSheet
XlApp.ScreenUpdating = True
XlApp.Visible = True
XlWrkbook.Close SaveChanges:=False
End Sub
So any idea if I could say bye to Visio 2016?
