Consulting

Results 1 to 8 of 8

Thread: Calculate total length?

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1

    Calculate total length?

    I want to calculate total length (sum of all individual demission of lines) of lines present in current layer in AutoCAD using VBA.

  2. #2
    Moderator VBAX Master Tommy's Avatar
    Joined
    May 2004
    Location
    Houston, TX
    Posts
    1,184
    Location
    Hi VB_IT,

    Welcome to VBA Express!!

    The below code will select all items in the active layer that are lines. Then it will get a sum of their lengths and display it in a message box.

    Function Aset(iSSetName As String) As AcadSelectionSet
        Dim ssetA As AcadSelectionSet
        On Error Resume Next
        Set ssetA = ThisDrawing.SelectionSets.Add(iSSetName)
        If Err.Number <> 0 Then
            Set ssetA = ThisDrawing.SelectionSets(iSSetName)
            ssetA.Delete
            Set ssetA = ThisDrawing.SelectionSets.Add(iSSetName)
            Err.Clear
        End If
        On Error GoTo 0
        Set Aset = ssetA
    End Function
    Function GetItems() As AcadSelectionSet
        Dim mTemp As AcadSelectionSet
        Dim gpCode(3) As Integer
        Dim dataValue(3) As Variant
        Dim groupCode As Variant
        Dim dataCode As Variant
        gpCode(0) = -4
        dataValue(0) = "<and"
        gpCode(1) = 8
        dataValue(1) = ThisDrawing.ActiveLayer.Name
        gpCode(2) = 0
        dataValue(2) = "LINE"
        gpCode(3) = -4
        dataValue(3) = "and>"
        Set mTemp = Aset("LINESUM")
        groupCode = gpCode
        dataCode = dataValue
        ZoomExtents
        a = ThisDrawing.GetVariable("EXTMIN")
        b = ThisDrawing.GetVariable("EXTMAX")
        mTemp.Select acSelectionSetAll, a, b, groupCode, dataCode
        Set GetItems = mTemp
    End Function
        
        
    Sub GetSumofLinesInActiveLayer()
        Dim LineCount As AcadSelectionSet, mCntr&, mTotalLength#
        Set LineCount = GetItems
        LineCount.Highlight True
        For mCntr = 0 To LineCount.Count - 1
             mTotalLength = mTotalLength + LineCount(mCntr).Length
        Next
        MsgBox mTotalLength
        LineCount.Highlight False
        LineCount.Delete
        Set LineCount = Nothing
        ThisDrawing.Regen acActiveViewport
    End Sub
    Last edited by Bob Phillips; 01-02-2015 at 03:15 AM. Reason: Added code tags

  3. #3
    VBAX Regular
    Joined
    Dec 2013
    Posts
    11
    Location
    just replace "LINE" with "LWPOLYLINE" in GetItems() function

  4. #4
    Thank you Very much,

    It working fine in simple drawing
    But when I apply it on my actual complex drawing it give me wrong length (Program count of lines is larger then actual count!?)

    If you say I can send you my Actual Drawing.

  5. #5
    Moderator VBAX Master Tommy's Avatar
    Joined
    May 2004
    Location
    Houston, TX
    Posts
    1,184
    Location
    I have acad 2000i.

  6. #6
    VBAX Regular Mdos568's Avatar
    Joined
    Mar 2017
    Location
    Sydney
    Posts
    6
    Location
    There are several additional routines

  7. #7

    How would this code be modified to collect length values for each line segement

    Quote Originally Posted by Mdos568 View Post
    There are several additional routines
    Thank you all for posting. This is pretty close to what I am looking for but...

    instead of summing the total length of all lines on the current layer. How would this code be modified to display (or read in to variables) length values for each line segment on the current layer?

    Thank you in advance!

  8. #8
    VBAX Regular
    Joined
    Dec 2013
    Posts
    11
    Location
    Quote Originally Posted by onelinediag View Post
    Thank you all for posting. This is pretty close to what I am looking for but...

    instead of summing the total length of all lines on the current layer. How would this code be modified to display (or read in to variables) length values for each line segment on the current layer?

    Thank you in advance!

    you only need a slight change in the GetSumofLinesInActiveLayer() loop, which I would then rename after GetLenghtsOfLinesInActiveLayer():

    Sub GetLenghtsOfLinesInActiveLayer()
        Dim mCntr As Long
        With GetItems
            ReDim lineLengths(0 To .Count - 1) As Double
            For mCntr = 0 To .Count - 1
                lineLengths(mCntr) = .Item(mCntr).Length
            Next
            .Delete
        End With
        ThisDrawing.Regen acActiveViewport
        
        'a loop to show what lenghts have been stored in lineLengths() array
        Dim lineLength As Variant
        For Each lineLength In lineLengths
            MsgBox lineLength
        Next
    End Sub
    after which you get all current layer line lengths stored in lineLengths() array

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •