Consulting

Results 1 to 8 of 8

Thread: Calculate total length?

  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 
    
    
    Formatting tags added by mark007
    Last edited by xld; 01-02-2015 at 03:15 AM. Reason: Added code tags

  3. #3
    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.

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

  5. #5
    just replace "LINE" with "LWPOLYLINE" in GetItems() function

  6. #6
    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
    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 
    
    
    Formatting tags added by mark007
    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
  •