Results 1 to 5 of 5

Thread: VBA data extraction

  1. #1
    Member
    Join Date
    2007-04
    Posts
    31
    Login to Give a bone
    0

    Default VBA data extraction

    HI Guys,
    I have a favor to ask.
    In my drawings i have two distinct layer names (Say "ew" and "ns").
    On these layers i have numerous plain text numbers in 5mm increments which are repeated many times throughout the drawing.
    What i would like to do is be able to start a VBA macro, have it ask the user to select an area by window on the drawing file, and have VBA look up and count the sum of all instances of each number occurring in the selected window.
    Then dump them into an excel spread sheet which i will then manipulate from there.

    An example output would look something like below:

    "NS" Layer Quantities...
    Height 25 30 35 40 45 and so on
    Total 56 33 62 39 50

    "EW" Layer Quantities...
    Height 25 30 35 40 45 and so on
    Total 56 33 62 39 50

    The ouput would require two rows of information. The top number would be the number on the drawing as text item and the lower row would be the total number of times that number appears in the selected area.

    Does anybody have something which will achieve this goal which they are willing to share?

    Thanks in anticipation.
    John B

  2. #2
    Administrator Ed Jobe's Avatar
    Join Date
    2000-11
    Location
    Turlock, CA
    Posts
    6,399
    Login to Give a bone
    0

    Default Re: VBA data extraction

    I doubt it. That's a pretty specific request. However, the tasks are common. You can find code in this forum for filtering text, and linking to xl.
    C:> ED WORKING....

  3. #3
    All AUGI, all the time arshiel88's Avatar
    Join Date
    2005-02
    Location
    Off the Grid
    Posts
    560
    Login to Give a bone
    0

    Default Re: VBA data extraction

    I've got a spare time and I gave it a try.

    Code:
    Sub CountNSEW()
    Open "C:\Count.csv" For Output As #1
    Dim SSetTexts As AcadSelectionSet
    
    On Error Resume Next
    Set SSetTexts = ThisDrawing.SelectionSets.Add("SSET_TEXTS")
        If Err Then
           Set SSetTexts = ThisDrawing.SelectionSets("SSET_TEXTS")
           SSetTexts.Clear
        End If
        
        Dim FilterType(0) As Integer
        Dim FilterData(0) As Variant
            FilterType(0) = 0
            FilterData(0) = "TEXT"
           
    SSetTexts.SelectOnScreen FilterType, FilterData
    Dim NSStrings As String
    Dim EWStrings As String
    Dim xText As AcadText
    For Each xText In SSetTexts
        Ts = xText.TextString
        Select Case xText.Layer
            Case "EW"
                EWStrings = EWStrings & xText.TextString & " "
            Case "NS"
                NSStrings = NSStrings & xText.TextString & " "
        End Select
    Next
    
    Print #1, """NS"" Layer Quantities..."
    Print #1, "25,30,35,40,45,50,55,60" 'and so on
    Print #1, CountStr("25", NSStrings) & "," & CountStr("30", NSStrings) & "," & CountStr("35", NSStrings) _
              & "," & CountStr("40", NSStrings) & "," & CountStr("45", NSStrings) & "," & CountStr("50", NSStrings) _
              & "," & CountStr("55", NSStrings) & "," & CountStr("60", NSStrings) 'and so on
    Print #1,
    Print #1, """EW"" Layer Quantities..."
    Print #1, "25,30,35,40,45,50,55,60" 'and so on
    Print #1, CountStr("25", EWStrings) & "," & CountStr("30", EWStrings) & "," & CountStr("35", EWStrings) _
              & "," & CountStr("40", EWStrings) & "," & CountStr("45", EWStrings) & "," & CountStr("50", EWStrings) _
              & "," & CountStr("55", EWStrings) & "," & CountStr("60", EWStrings) 'and so on
    
    Close #1
    AppID = Shell("C:\Program Files (x86)\Microsoft Office\Office12\EXCEL.EXE C:\Count.csv", 3) 'modify with your excel path
    AppActivate AppID, False
    Application.WindowState = acMin
    End Sub
    
    Function CountStr(StrToCount As String, strToSearch As String) As Integer
    Dim StringsArray As Variant
    StringsArray = Split(strToSearch)
    For i = 0 To UBound(StringsArray)
        If StringsArray(i) = StrToCount Then
            CountStr = CountStr + 1
        End If
    Next
    End Function
    Modify as per your requirements. Good luck.

  4. #4
    Member
    Join Date
    2007-04
    Posts
    31
    Login to Give a bone
    0

    Default Re: VBA data extraction

    arshiel88,
    Thank you for that one thing i should have mentioned is that i do not know specifically what the text numbers in the drawing will be. They could range from 25-2000 in 5mm increments. to include all the variations in the code is the long way around my problem.
    Is there anyway that the search and count can be more generic and rather than specify in the code the text string number to find and count, the vba code will just look at all the text strings and count them.

    Other than that it works quite well

    regards
    John B

  5. #5
    All AUGI, all the time arshiel88's Avatar
    Join Date
    2005-02
    Location
    Off the Grid
    Posts
    560
    Login to Give a bone
    0

    Default Re: VBA data extraction

    Code:
    Sub CountNSEW()
    Open "C:\Count.csv" For Output As #1
    Dim SSetTexts As AcadSelectionSet
    
    On Error Resume Next
    Set SSetTexts = ThisDrawing.SelectionSets.Add("SSET_TEXTS")
        If Err Then
           Set SSetTexts = ThisDrawing.SelectionSets("SSET_TEXTS")
           SSetTexts.Clear
        End If
        
        Dim FilterType(0) As Integer
        Dim FilterData(0) As Variant
            FilterType(0) = 0
            FilterData(0) = "TEXT"
           
    SSetTexts.SelectOnScreen FilterType, FilterData
    Dim NSStrings As String
    Dim EWStrings As String
    Dim xText As AcadText
    For Each xText In SSetTexts
        Ts = xText.TextString
        Select Case xText.Layer
            Case "EW"
                EWStrings = EWStrings & xText.TextString & " "
            Case "NS"
                NSStrings = NSStrings & xText.TextString & " "
        End Select
    Next
    Dim iStr As String
    Dim QuantitiesStr As String
    Dim i As Integer
    Print #1, """NS"" Layer Quantities..."
    For i = 25 To 2000 Step 5
        iStr = CStr(i)
        If InStr(1, NSStrings, iStr) Then
            Print #1, i & ",";
            QuantitiesStr = QuantitiesStr & CountStr(CStr(i), NSStrings) & ","
        End If
    Next i
    QuantitiesStr = Left(QuantitiesStr, Len(QuantitiesStr) - 1)
    Print #1,
    Print #1, QuantitiesStr
    Print #1,
    Print #1, """EW"" Layer Quantities..."
    
    QuantitiesStr = ""
    For i = 25 To 2000 Step 5
        iStr = CStr(i)
        If InStr(1, EWStrings, iStr) Then
            Print #1, i & ",";
            QuantitiesStr = QuantitiesStr & CountStr(iStr, EWStrings) & ","
        End If
    Next i
    QuantitiesStr = Left(QuantitiesStr, Len(QuantitiesStr) - 1)
    Print #1,
    Print #1, QuantitiesStr
    
    Close #1
    AppID = Shell("C:\Program Files (x86)\Microsoft Office\Office12\EXCEL.EXE C:\Count.csv", 3) 'modify with your excel path
    AppActivate AppID, False
    Application.WindowState = acMin
    End Sub
    
    Function CountStr(StrToCount As String, strToSearch As String) As Integer
    Dim StringsArray As Variant
    StringsArray = Split(strToSearch)
    For i = 0 To UBound(StringsArray)
        If StringsArray(i) = StrToCount Then
            CountStr = CountStr + 1
        End If
    Next
    End Function

    Remove the If Instr...End If lines if you want to list all sizes.

Similar Threads

  1. UCS and Data Extraction
    By CADdancer in forum AutoCAD General
    Replies: 15
    Last Post: 2018-09-28, 12:16 PM
  2. Replies: 1
    Last Post: 2015-04-29, 01:18 PM
  3. Two way data extraction
    By j_washbourne28 in forum AutoCAD Tables
    Replies: 1
    Last Post: 2014-03-24, 01:28 PM
  4. Data extraction
    By paulof in forum AutoLISP
    Replies: 0
    Last Post: 2011-11-29, 06:45 PM
  5. Data Extraction
    By matt.wagner in forum AutoCAD LT - Wish List
    Replies: 7
    Last Post: 2009-04-27, 02:02 AM

Posting Permissions

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