### Author Topic: A macro to trace free curve with constant length lines  (Read 6991 times)

0 Members and 1 Guest are viewing this topic.

#### JuneTheSecond

• Hero Member
•     • • Posts: 1027 ##### A macro to trace free curve with constant length lines
« on: May 09, 2014, 02:06:31 AM »
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
``Option ExplicitOption Base 1Sub 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 SubSub 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 SubSub 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 SubSub 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``
« Last Edit: May 10, 2014, 06:17:36 AM by JuneTheSecond »
Best Regards,

Junichi Yoda
http://june.minibird.jp/

#### Paul Herber

• Global Moderator
• Hero Member
•     • • Posts: 3343 ##### Re: A macro to trace free curve with constant length lines
« Reply #1 on: May 09, 2014, 03:53:17 AM »
Microsoft has had 14 years to add new drawing tools to Visio.
Great stuff Yunichi.
Electronic and Electrical engineering, business and software stencils and applications for Visio -

https://www.paulherber.co.uk/