A macro to trace free curve with constant length lines

[JuneTheSecond]

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/sqLKx8Izq5E

Code Select Expand


Option 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



[Paul Herber]

Microsoft has had 14 years to add new drawing tools to Visio.
Great stuff Yunichi.