Dim bBusy As Boolean
Dim counter As Long
Dim rejected As Long
'
Sub ConnPtAdjust(shp As Visio.Shape)
Dim start As Double
If bBusy Then
Debug.Print "Reject event"
rejected = rejected + 1
counter = counter + 1
Exit Sub
Else
rejected = 0
counter = 0
bBusy = True
start = Timer
' counter = counter + 1
Debug.Print "Start time: ", start
If Application.LiveDynamics Then
While Timer - start < 1
DoEvents
Wend
End If
Debug.Print "Executing now @" & Timer, "repetition", counter, "Rejected events", rejected
actualRoutine shp
bBusy = False
End If
End Sub
Sub actualRoutine(shp As Visio.Shape)
connPtRow = shp.RowCount(visSectionConnectionPts) - 1 ' rownum used in vba formula generation is 0 based
lastCPYVal = shp.CellsSRC(visSectionConnectionPts, connPtRow, visCnnctY).Result(visInches)
If lastCPYVal >= 0.875 Then
' Debug.Print "Add rows"
rowsToAdd = 1 + Int((lastCPYVal - 0.875) / 0.625)
rowNew = connPtRow
rowsToAdd = 1 + Int((lastCPYVal - 0.875) / 0.625)
' we add rowsToAdd*2 cuz we add two conn points (left/right side of shape) per elevation
For i = 1 To rowsToAdd
' Debug.Print "Adding " & shp.Name & " Point " & rowNew
' left side conn point
rowNew = rowNew + 1
' Debug.Print "setting data"
shp.AddRow visSectionConnectionPts, rowNew, visCnnctX
shp.CellsSRC(visSectionConnectionPts, rowNew, visCnnctX).FormulaForceU = "Connections.X3"
shp.CellsSRC(visSectionConnectionPts, rowNew, visCnnctY).FormulaForceU = "Connections.Y" & rowNew & "-0.625"
shp.CellsSRC(visSectionConnectionPts, rowNew, visCnnctDirX).FormulaU = "Connections.DirX[3]"
' right side conn point
rowNew = rowNew + 1
shp.AddRow visSectionConnectionPts, rowNew, visCnnctX
shp.CellsSRC(visSectionConnectionPts, rowNew, visCnnctX).FormulaForceU = "Connections.X4"
shp.CellsSRC(visSectionConnectionPts, rowNew, visCnnctY).FormulaForceU = "Connections.Y" & rowNew
shp.CellsSRC(visSectionConnectionPts, rowNew, visCnnctDirX).FormulaU = "Connections.DirX[4]"
Next
' need to remove connection points
ElseIf lastCPYVal < 0.375 Then
For i = connPtRow To 1 Step -1 ' start removing conn points from last row, decreasing by two (left/right side of shape)
If shp.CellsSRC(visSectionConnectionPts, i, visCnnctY).Result(visInches) < 0.375 Then
' Debug.Print "Removing"; shp.Name & " Point " & i & ", " & shp.CellsSRC(visSectionConnectionPts, i, visCnnctY).Result(visInches)
shp.DeleteRow visSectionConnectionPts, i
Else
Exit For
End If
Next
End If
End Sub
Sub DisAbleDyn()
Application.LiveDynamics = False
Debug.Print "FALSE"
End Sub
Sub EnAbleDyn()
Application.LiveDynamics = True
Debug.Print "TRUE"
End Sub
Quote from: wapperdude on April 28, 2024, 06:29:35 AMFound the issue. It is linked to re-drawing...Well, yes but no. I mean almost.
Go to File>Options>Advanced. Deselect Enable live dynamics. That halts shape re-drawing, which halts events associated with dragging.
Quote from: wapperdude on April 28, 2024, 06:29:35 AMDeselect Enable live dynamicsMakes perfect sense because I had live dynamics disabled already.
Quote from: Thomas Winkel on April 27, 2024, 09:39:08 PMAh, I see what you mean, I must be blindOh how I wish I could say I have perfect vision.
Quote from: Thomas Winkel on April 27, 2024, 09:39:08 PMAnyhow, I still think that all the events come either from the called VBA code and / or from the ShapeSheet formulas that calculate & set the height to fit a grid.I'm quite sure it's not code, barring any unusual problems. With Yacine's code, it's possible to debug.print each time the code is called, and that's before the OP's code (or any other "actualRoutine") is executed. I suppose doing Event Monitor ought to verify the repeated calls from the mouse dragging.