I tried to make a macro that trace a free curve or ellipse with chain of lines of constant length.
There are people in Visio Guy Forum who wish to draw line with constant length.
Visio does not have such a native tool.
I am not sure the needs for the tool.
I don't know the purpose of such a tool.
I assume one of the purpose is to trace a free curve with a chain of constant length lines.
This Macro can trace free curve with lines of approximetly constant length, and may have many bugs.
But you can see if there is any meaning to trace with constant lines.
I prefer to trace with variable length lines.
When a curve turns quick, the length of lines should be short.
When slow, it should be long.
Visio Paths object and Point popperty just gives the way to such a trace.
Here is a short video how the macro runs.
http://youtu.be/sqLKx8Izq5EOption Explicit
Option Base 1
Sub TraceCurveWithConstantLengthLines()
Dim x0 As Double, y0 As Double
Dim LenghtLine As Double
Dim Px As Double, Py As Double
Dim i2m
Dim P0 As Long, Pi As Long
Dim I As Long
Dim ax() As Long, ay() As Long
Dim shpLine As Visio.Shape
Dim collectionShapes As New Collection
Dim numLines As Long
Dim x() As Double, y() As Double
GetPointsXY 0.00001, x, y
i2m = 25.4
P0 = 1
x0 = x(1)
y0 = y(1)
LenghtLine = 10 / i2m
numLines = 40
ReDim ax(numLines)
ReDim ay(numLines)
For I = 1 To numLines
GetPointGivenLenghtLine x, y, P0, x0, y0, LenghtLine, Px, Py, Pi
ax(I) = Px
ay(I) = Py
ActiveWindow.DeselectAll
Set shpLine = ActivePage.DrawLine(x0, y0, Px, Py)
collectionShapes.Add shpLine
P0 = Pi
x0 = Px
y0 = Py
Next
ActiveWindow.DeselectAll
For Each shpLine In collectionShapes
ActiveWindow.Select shpLine, visSelect
Next
ActiveWindow.Selection.Join
End Sub
Sub GetPointGivenLenghtLine(x() As Double, y() As Double, P0 As Long, x0 As Double, y0 As Double, LenghtLine As Double, Px As Double, Py As Double, Pi As Long)
Dim er As Double
Dim I As Long
Dim dis() As Double
Dim dblmin As Double
Dim i2m
Dim L As Long, U As Long
i2m = 25.4
L = LBound(x)
U = UBound(x)
ReDim dis(U - L + 1)
For I = P0 To UBound(x)
dis(I) = Abs(Sqr((x(I) - x0) ^ 2 + (y(I) - y0) ^ 2) - LenghtLine)
Next
dblmin = LenghtLine
Pi = P0
For I = P0 To U
If dblmin > dis(I) Then
dblmin = dis(I)
Pi = I
If I < U Then
If dis(I) < dis(I + 1) Then Exit For
End If
End If
Next
Px = x(Pi)
Py = y(Pi)
End Sub
Sub GetPointsXY(er As Double, x() As Double, y() As Double)
Dim shp As Visio.Shape
Dim xy() As Double
Dim I As Long
Dim L As Long, U As Long
Set shp = ActivePage.Shapes(1)
shp.Paths(1).Points er, xy
L = LBound(xy)
U = UBound(xy)
ReDim x(Int((U - L + 1) / 2))
ReDim y(Int((U - L + 1) / 2))
For I = LBound(x) To UBound(x)
x(I) = xy(2 * (I - 1))
y(I) = xy(2 * (I - 1) + 1)
Next
End Sub
Sub DrawLinesWtPaths()
Dim er As Double
Dim x() As Double, y() As Double
Dim I As Long
Dim shpLine As Visio.Shape
Dim collectionLines As New Collection
er = 0.01
GetPointsXY er, x, y
For I = LBound(x) To UBound(y) - 1
ActiveWindow.DeselectAll
Set shpLine = ActivePage.DrawLine(x(I), y(I), x(I + 1), y(I + 1))
collectionLines.Add shpLine
Next
ActiveWindow.DeselectAll
For Each shpLine In collectionLines
ActiveWindow.Select shpLine, visSelect
Next
ActiveWindow.Selection.Join
End Sub
