Consulting

Results 1 to 16 of 16

Thread: Solved: AUTOCAD - can't find blocks in polylines

  1. #1
    VBAX Mentor ALe's Avatar
    Joined
    Aug 2005
    Location
    Milan
    Posts
    383
    Location

    Solved: AUTOCAD - can't find blocks in polylines

    Hi everybody,

    for the first time I'm using VBA with autocad on dwg files.

    I found on internet a piece of code that is exactly what I was looking for. This sub get all the polylines in the file and extract attributes values from the blocks that stay within each polyline.

    The fact is that the code works only with polylines with a few vertexes, doesn't work with complex lines because it doesn't get the blocks ("Etichetta Locale") staying inside the poly area.

    Any ideas how to fix it? Thanx in advance.

    [vba]
    Sub AnalizzaBlocchiInPolilinea(MyPoly As AcadLWPolyline, NomeP As String, IDP As String, AreaP As Double, PerimP As Double)

    Dim Filtertype(0) As Integer
    Dim Filterdata(0) As Variant
    'Dim Sset As AcadSelectionSet
    Dim element As AcadEntity
    Dim Coord As Variant
    Dim Sset1 As AcadSelectionSet
    Dim element1 As AcadBlockReference
    Dim Punti3D As Variant
    Dim Pigreco As Double
    Pigreco = 4 * Atn(1)
    On Error Resume Next
    If Not IsNull(AcApp.ActiveDocument.SelectionSets.Item("element")) Then
    Set Sset = AcApp.ActiveDocument.SelectionSets.Item("element")
    Sset.Delete
    End If
    Coord = MyPoly.Coordinates
    x = ((UBound(Coord) - 1) / 2) + UBound(Coord)
    ReDim Punti3D(0 To x + 1) As Double
    For I = 0 To UBound(Coord) Step 2
    Punti3D(u) = Coord(I)
    Punti3D(u + 1) = Coord(I + 1)
    u = u + 2
    Punti3D(u) = 0
    u = u + 1
    Next I
    If Not IsNull(AcApp.ActiveDocument.SelectionSets.Item("element1")) Then
    Set Sset1 = AcApp.ActiveDocument.SelectionSets.Item("element1")
    Sset1.Delete
    End If
    Set Sset1 = AcApp.ActiveDocument.SelectionSets.Add("element1")
    Filtertype(0) = 0
    Filterdata(0) = "insert"
    Sset1.SelectByPolygon acSelectionSetCrossingPolygon, Punti3D, Filtertype, Filterdata
    'MsgBox ("selected elements:" & Sset1.Count)

    z = 1

    'AcApp.ActiveDocument.Regen acAllViewports
    For Each element1 In Sset1
    If element1.Name = "Etichetta Locale" Then
    'element1.Highlight True
    'MsgBox ("Object" & z & ":" & element1.Name & vbLf & "Punto inserimento" & vbLf & "x: " & element1.InsertionPoint(0) & vbLf & "y: " & element1.InsertionPoint(1) & vbLf & "Rotazione: " & (element1.Rotation) / Pigreco * 180)
    varattributes = element1.GetAttributes
    End if
    Next

    End sub
    [/vba]
    Last edited by ALe; 11-16-2010 at 05:26 AM. Reason: error

  2. #2
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by ALe
    Hi everybody,

    for the first time I'm using VBA with autocad on dwg files.

    I found on internet a piece of code that is exactly what I was looking for. This sub get all the polylines in the file and extract attributes values from the blocks that stay within each polyline.

    The fact is that the code works only with polylines with a few vertexes, doesn't work with complex lines because it doesn't get the blocks ("Etichetta Locale") staying inside the poly area.

    Any ideas how to fix it? Thanx in advance.

    [vba]
    Sub AnalizzaBlocchiInPolilinea(MyPoly As AcadLWPolyline, NomeP As String, IDP As String, AreaP As Double, PerimP As Double)

    Dim Filtertype(0) As Integer
    Dim Filterdata(0) As Variant
    'Dim Sset As AcadSelectionSet
    Dim element As AcadEntity
    Dim Coord As Variant
    Dim Sset1 As AcadSelectionSet
    Dim element1 As AcadBlockReference
    Dim Punti3D As Variant
    Dim Pigreco As Double
    Pigreco = 4 * Atn(1)
    On Error Resume Next
    If Not IsNull(AcApp.ActiveDocument.SelectionSets.Item("element")) Then
    Set Sset = AcApp.ActiveDocument.SelectionSets.Item("element")
    Sset.Delete
    End If
    Coord = MyPoly.Coordinates
    x = ((UBound(Coord) - 1) / 2) + UBound(Coord)
    ReDim Punti3D(0 To x + 1) As Double
    For I = 0 To UBound(Coord) Step 2
    Punti3D(u) = Coord(I)
    Punti3D(u + 1) = Coord(I + 1)
    u = u + 2
    Punti3D(u) = 0
    u = u + 1
    Next I
    If Not IsNull(AcApp.ActiveDocument.SelectionSets.Item("element1")) Then
    Set Sset1 = AcApp.ActiveDocument.SelectionSets.Item("element1")
    Sset1.Delete
    End If
    Set Sset1 = AcApp.ActiveDocument.SelectionSets.Add("element1")
    Filtertype(0) = 0
    Filterdata(0) = "insert"
    Sset1.SelectByPolygon acSelectionSetCrossingPolygon, Punti3D, Filtertype, Filterdata
    'MsgBox ("selected elements:" & Sset1.Count)

    z = 1

    'AcApp.ActiveDocument.Regen acAllViewports
    For Each element1 In Sset1
    If element1.Name = "Etichetta Locale" Then
    'element1.Highlight True
    'MsgBox ("Object" & z & ":" & element1.Name & vbLf & "Punto inserimento" & vbLf & "x: " & element1.InsertionPoint(0) & vbLf & "y: " & element1.InsertionPoint(1) & vbLf & "Rotazione: " & (element1.Rotation) / Pigreco * 180)
    varattributes = element1.GetAttributes
    End if
    Next

    End sub
    [/vba]
    Try this one instead
    hope this get you started
    Option Explicit
    Sub test()
     Dim objTemp As AcadEntity
        Dim objUtil As AcadUtility
        Dim oPline As AcadLWPolyline
        Dim varPnt As Variant
        Dim varCancel As Variant
        On Error GoTo Err_Control
        Set objUtil = ThisDrawing.Utility
        objUtil.GetEntity objTemp, varPnt, vbCrLf & "Select Contour>>"
        If TypeOf objTemp Is AcadLWPolyline Then
        Set oPline = objTemp
     Call AnalizzaBlocchiInPolilinea(oPline, "Etichetta Locale")
        End If
    Err_Control:
         If Err.Number <> 0 Then
         MsgBox Err.Description
         End If
    End Sub
    Sub AnalizzaBlocchiInPolilinea(MyPoly As AcadLWPolyline, NomeP As String) '' IDP As String, AreaP As Double, PerimP As Double)
     
        Dim Filtertype(1) As Integer
        Dim Filterdata(1) As Variant
       Dim Sset As AcadSelectionSet
        Dim oEnt As AcadEntity
        Dim i, z
        Dim PointsArray As Variant
        Dim Sset1 As AcadSelectionSet
        Dim oBlkRef As AcadBlockReference
        Dim oAttrib As AcadAttributeReference
        Dim Punti3D As Variant
        Dim Pigreco As Double
        Pigreco = 4 * Atn(1)
    '    On Error Resume Next
     
              With ThisDrawing.SelectionSets
                   While .Count > 0
                        .Item(0).Delete
                   Wend
              Set Sset = .Add("$Blocks$")
              End With
     
        PointsArray = MyPoly.Coordinates
        ReDim Punti3D((UBound(PointsArray) + 1) / 2 * 3 - 1) As Double
                            For i = 0 To ((UBound(PointsArray) + 1) / 2) - 1
                                Punti3D(i * 3) = PointsArray(i * 2)
                                Punti3D(i * 3 + 1) = PointsArray(i * 2 + 1)
                                Punti3D(i * 3 + 2) = 0
                            Next
     
        Filtertype(0) = 0: Filtertype(1) = 2
        Filterdata(0) = "insert": Filterdata(1) = NomeP
        Sset.SelectByPolygon acSelectionSetWindowPolygon, Punti3D, Filtertype, Filterdata
         MsgBox ("selected Blocks: " & Sset.Count)
     
        z = 1
        For Each oEnt In Sset
        Set oBlkRef = oEnt
        ThisDrawing.Utility.Prompt vbCr & "Object" & z & ":" & oBlkRef.EffectiveName & vbLf & "Punto inserimento" & vbLf & "x: " & oBlkRef.InsertionPoint(0) & vbLf & "y: " & oBlkRef.InsertionPoint(1) & vbLf & "Rotazione: " & (oBlkRef.Rotation) / Pigreco * 180
                 oBlkRef.Highlight True
                 Dim varAttributes As Variant
     
                varAttributes = oBlkRef.GetAttributes
                For i = 0 To UBound(varAttributes)
               Set oAttrib = varAttributes(i)
               Dim strTag As String
               Dim strValue As String
               strTag = oAttrib.TagString
               strValue = oAttrib.TextString
               ThisDrawing.Utility.Prompt vbCr & "Tag: " & strTag & vbLf & "Value: " & strValue & vbLf
               Next i
               z = z + 1
        Next oEnt
     
    End Sub
    ~'J'~

  3. #3
    VBAX Mentor ALe's Avatar
    Joined
    Aug 2005
    Location
    Milan
    Posts
    383
    Location
    wow!
    I'll give a try and let you know. Thanks
    ALe
    Help indigent families: www.bancomadreteresa.org

  4. #4
    VBAX Mentor ALe's Avatar
    Joined
    Aug 2005
    Location
    Milan
    Posts
    383
    Location
    fixo, your code works.

    The problem I'm facing is that I'm calling the sub from excel, and from excel I can't see the ThisDrawing Object.

    I tried changing "ThisDrawing" with "ActiveDocument". In this case it doesn't work, running the code both in autocad as in excel. How is it possible????

    Is there any way to use the ThisDrawing Object from Excel? Which library the object belongs to?
    ALe
    Help indigent families: www.bancomadreteresa.org

  5. #5
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by ALe
    fixo, your code works.

    The problem I'm facing is that I'm calling the sub from excel, and from excel I can't see the ThisDrawing Object.

    I tried changing "ThisDrawing" with "ActiveDocument". In this case it doesn't work, running the code both in autocad as in excel. How is it possible????

    Is there any way to use the ThisDrawing Object from Excel? Which library the object belongs to?
    Hi, Ale
    Change Thisdrawing on

    AcApp.ActivedDocument like it is in your first post

    Let me know if it's not working as well

  6. #6
    VBAX Mentor ALe's Avatar
    Joined
    Aug 2005
    Location
    Milan
    Posts
    383
    Location
    It's driving me crazy.

    I run the sub test with "ThisDrawing" and it works, with "ActiveDocument" doesn't.

    Here your code updated to my needs, can't find a way to run the sub "RunTruFile".

    [vba]Sub AnalizzaBlocchiInPolilinea(MyPoly As AcadLWPolyline, NomeP As String) '' IDP As String, AreaP As Double, PerimP As Double)

    Dim Filtertype(1) As Integer
    Dim Filterdata(1) As Variant
    Dim Sset As AcadSelectionSet
    Dim oEnt As AcadEntity
    Dim i, z
    Dim PointsArray As Variant
    Dim Sset1 As AcadSelectionSet
    Dim oBlkRef As AcadBlockReference
    Dim oAttrib As AcadAttributeReference
    Dim Punti3D As Variant
    Dim Pigreco As Double
    Pigreco = 4 * Atn(1)
    ' On Error Resume Next

    With ActiveDocument.SelectionSets
    While .Count > 0
    .Item(0).Delete
    Wend
    Set Sset = .Add("$Blocks$")
    End With

    PointsArray = MyPoly.Coordinates
    ReDim Punti3D((UBound(PointsArray) + 1) / 2 * 3 - 1) As Double
    For i = 0 To ((UBound(PointsArray) + 1) / 2) - 1
    Punti3D(i * 3) = PointsArray(i * 2)
    Punti3D(i * 3 + 1) = PointsArray(i * 2 + 1)
    Punti3D(i * 3 + 2) = 0
    Next

    Filtertype(0) = 0: Filtertype(1) = 2
    Filterdata(0) = "insert": Filterdata(1) = NomeP
    Sset.SelectByPolygon acSelectionSetWindowPolygon, Punti3D, Filtertype, Filterdata
    MsgBox ("selected Blocks: " & Sset.Count)

    z = 1
    For Each oEnt In Sset
    Set oBlkRef = oEnt
    ThisDrawing.Utility.Prompt vbCr & "Object" & z & ":" & oBlkRef.EffectiveName & vbLf & "Punto inserimento" & vbLf & "x: " & oBlkRef.InsertionPoint(0) & vbLf & "y: " & oBlkRef.InsertionPoint(1) & vbLf & "Rotazione: " & (oBlkRef.Rotation) / Pigreco * 180
    oBlkRef.Highlight True
    Dim varAttributes As Variant

    varAttributes = oBlkRef.GetAttributes
    For i = 0 To UBound(varAttributes)
    Set oAttrib = varAttributes(i)
    Dim strTag As String
    Dim strValue As String
    strTag = oAttrib.TagString
    strValue = oAttrib.TextString
    ThisDrawing.Utility.Prompt vbCr & "Tag: " & strTag & vbLf & "Value: " & strValue & vbLf
    Next i
    z = z + 1
    Next oEnt
    End Sub

    Sub RunTruFile()
    Dim objSelectionSet As AcadSelectionSet
    Dim intGroupCode(0) As Integer
    Dim varDataCode(0) As Variant
    Dim objAcadPoly As AcadLWPolyline
    Dim lngL As Long
    On Error Resume Next
    'do Lightweight polylines
    intGroupCode(0) = 0
    varDataCode(0) = "LWPolyline"
    ThisDrawing.SelectionSets.Item("Poly").Delete
    If Err Then Err.Clear
    'create a selection of all lightweight polylines
    Set objSelectionSet = ThisDrawing.SelectionSets.Add("Poly")
    objSelectionSet.Select acSelectionSetAll, , , intGroupCode, varDataCode

    'go through each polyline object
    For Each objAcadPoly In objSelectionSet
    If objAcadPoly.Layer = "RM" Then Call AnalizzaBlocchiInPolilinea(objAcadPoly, "Etichetta Locale")
    Next objAcadPoly
    End Sub[/vba]

    I attach the file I'm working with, maybe it's something regarding the file.

    Thank you very much!
    ALe
    Help indigent families: www.bancomadreteresa.org

  7. #7
    VBAX Mentor ALe's Avatar
    Joined
    Aug 2005
    Location
    Milan
    Posts
    383
    Location
    Sorry, I attach also the excel file with code in case you consider it useful
    ALe
    Help indigent families: www.bancomadreteresa.org

  8. #8
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by ALe
    Sorry, I attach also the excel file with code in case you consider it useful
    Ale,sorry, I was busy with my own
    Wait please, I'll back tomorrow only

  9. #9
    VBAX Mentor ALe's Avatar
    Joined
    Aug 2005
    Location
    Milan
    Posts
    383
    Location
    no problem fixo, take your time of course!

    thanks
    ALe
    Help indigent families: www.bancomadreteresa.org

  10. #10
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by ALe
    no problem fixo, take your time of course!

    thanks
    Ale
    Try this module from AutoCAD only
    If this codwill be working good for you tthen
    we could be go further
    ''Attribute VB_Name = "RoomsToCSV"
    Option Explicit
    ' Extractpolylines/ blocks data information to csv file
    ' Rooms must be as closed lwpolylines only
    ' CSV file would be created in the same folder you'll working
    '~~~~~~~~~~~~~~~~~~~~'
    Sub WriteCoorsToTextFile()
    Dim oSset As AcadSelectionSet
    Dim itmSet As AcadSelectionSet
    Dim oPoly As AcadLWPolyline
    Dim oEnt As AcadEntity
    Dim nestEnt As AcadEntity
    Dim oBlkRef As AcadBlockReference
    Dim oAttrib As AcadAttributeReference
    Dim attArr() As AcadAttributeReference
    Dim coordArr As Variant
    Dim ftype(2) As Integer
    Dim fdata(2) As Variant
    Dim dxfCode, dxfValue
    On Error GoTo Something_Wrong_Here
      With ThisDrawing.SelectionSets
                   While .Count > 0
                        .Item(0).Delete
                   Wend
              Set oSset = .Add("$Parcels$")
              End With
     
     
    Dim strFileName As String
    strFileName = ThisDrawing.Name
    ftype(0) = 0
    ftype(1) = 70
    ftype(2) = 8
    fdata(0) = "LWPOLYLINE"
    fdata(1) = 1
    fdata(2) = "RM"
    dxfCode = ftype: dxfValue = fdata
    Dim mode As Integer
    mode = acSelectionSetAll
    oSset.SelectOnScreen dxfCode, dxfValue
    If oSset.Count = 0 Then
    Exit Sub
    End If
    'Dim tmpArr() As Variant
    'Dim i, j, m As Long
    Dim fName, inpStr As String
    Dim fDesc As Integer
    fDesc = FreeFile
    fName = InputBox("Enter file name without extension", "File Name")
    fName = ThisDrawing.Path & "\" & fName & ".csv"
    Open fName For Output As fDesc
    ''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
    Dim filttype(1) As Integer
    ReDim filtdata(1) As Variant
    filttype(0) = 0
    filttype(1) = 2
    filtdata(0) = "INSERT"
    filtdata(1) = "Etichetta Locale"
    dxfCode = filttype: dxfValue = filtdata
    ''~~~~~~~~~~~~~build table headers ~~~~~~~~~~''
    Dim strHeaders As String
    strHeaders = "COD_LOC" & vbTab & "DESTINAZIONE" & vbTab & "CDC" & vbTab & "Tipo_polilinea" & vbTab & "ID_polilinea" & vbTab & "Area" & vbTab & "Perimetro" & vbTab & "Altezza Controsoffitto" & vbTab & "Altezza Soffitto" & vbTab & "Nome_FILE"
    Print #fDesc, strHeaders
    Dim n
    ''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
    For Each oEnt In oSset
    Set oPoly = oEnt
    Dim strOBjName As String
    strOBjName = oPoly.ObjectName
    Dim intId As Long
    intId = oPoly.ObjectID
    Dim dblArea As Double
    dblArea = oPoly.Area
    Dim dblPerim As Double
    dblPerim = oPoly.Length
    coordArr = get_vertices(oPoly)
     Set itmSet = ThisDrawing.SelectionSets.Add("$Room$")
     itmSet.SelectByPolygon acSelectionSetWindowPolygon, coordArr, dxfCode, dxfValue
     
      ''~~~to make sure that just one block inside~~~''
     If itmSet.Count = 1 Then
     Set nestEnt = itmSet.Item(0)
     Set oBlkRef = nestEnt
     
     ''~~~~~~~~~~~~loop through attributes~~~~~~~~''
     attArr = oBlkRef.GetAttributes
     Dim strCodLOc As String
      Dim strDest As String
      Dim strCDC As String
     For n = 0 To UBound(attArr)
     Set oAttrib = attArr(n)
     
    ''~~~~~~~~~~~~~~~~Select Case~~~~~~~~~~~~''
     If UCase(oAttrib.TagString) Like "DESTINAZIONE*" Then '<-- I use "Like" because of Single quotes in Tag name
     strDest = oAttrib.TextString
     ElseIf UCase(oAttrib.TagString) = "CODICE_LOCALE" Then
     strCodLOc = oAttrib.TextString
     ElseIf UCase(oAttrib.TagString) = "CENTRO_COSTO" Then
     strCDC = oAttrib.TextString
     End If
    ''~~~~~~~~~~~~~build tab delimited text line~~~~~~~~~~''
    Dim strText As String
    strText = strCodLOc & vbTab & strDest & vbTab & strCDC & vbTab & strOBjName & vbTab & CStr(intId) & vbTab _
    & Format(dblArea, "0.00") & vbTab & Format(dblPerim, "0.00") & vbTab & "-" & vbTab & "-" & vbTab & strFileName
     Next n
     
    Print #fDesc, strText
    End If ''<--if itmSet.Count=1
    ThisDrawing.SelectionSets.Item("$Room$").Delete
    'itmSet.Delete
    Next oEnt
    Close #fDesc
    ThisDrawing.SelectionSets.Item("$Parcels$").Delete
    MsgBox "Done!"
    Something_Wrong_Here:
    If Err.Number <> 0 Then
    MsgBox Err.Description
    End If
    End Sub
     
    Public Function get_vertices(oPoly As AcadLWPolyline) As Double()
    Dim retCoords  As Variant
    Dim i As Long
    retCoords = oPoly.Coordinates
        ReDim dblArr((UBound(retCoords) + 1) / 2 * 3 - 1) As Double
        For i = 0 To ((UBound(retCoords) + 1) / 2) - 1
            dblArr(i * 3) = retCoords(i * 2)
            dblArr(i * 3 + 1) = retCoords(i * 2 + 1)
            dblArr(i * 3 + 2) = 0
        Next
     
    get_vertices = dblArr
    End Function

  11. #11
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Hi Ale,
    Here is the final project
    This will works just fom AutoCAD only because you can't switch twice
    between Excel and "non-Office" external application without of loosing the focus

    Go this way
    Unzip attached project
    Open AutoCAD
    Type VBALOAD in the command line
    Select decompressed project ALe.dvb
    Click ALt+F11 to open VBA editor
    and change all in References tab to you suit
    (and the Excel file path at the very top of code module too)
    Then type VBARUN to execute
    See result after the message box "Done" would be appears
    Sorry, I can't help further

    ~'J'~

  12. #12
    VBAX Mentor ALe's Avatar
    Joined
    Aug 2005
    Location
    Milan
    Posts
    383
    Location
    it seems to me it works, except for complex polylines.

    Thank you.

    Is there any way to get automatically all the polylines of the drawing instead of prompt?
    ALe
    Help indigent families: www.bancomadreteresa.org

  13. #13
    VBAX Mentor ALe's Avatar
    Joined
    Aug 2005
    Location
    Milan
    Posts
    383
    Location
    It works on 90% of polylines and it's enough for me.

    I eliminated prompt by using "oSset.Select acSelectionSetAll"

    I'm trying to insert the field formula in a new attribute of the block. The formula for the attribute value is:
    "%<\AcObjProp Object(%<\_ObjId 2130239776>%).Area \f "%lu2">%" where ObjId 2130239776 is the poly containing the block.

    It works manually, but I can't do it via VBA. I tried:
    [vba] attArr = oBlkRef.GetAttributes

    attArr(3).TextString = "%<\AcObjProp Object(%<\_ObjId 2130018928>%).Area>% \f " & """ %lu2 &""" & ">%"[/vba]

    but the value of the attribute show an error like "####"
    ALe
    Help indigent families: www.bancomadreteresa.org

  14. #14
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Try this quick example
    Public Sub addField()
    Dim oSset As AcadSelectionSet
    Dim itmSet As AcadSelectionSet
    Dim oPoly As AcadLWPolyline
    Dim oEnt As AcadEntity
    Dim nestEnt As AcadEntity
    Dim n
    Dim pickPt As Variant
    Dim oBlkRef As AcadBlockReference
    Dim oAttrib As AcadAttributeReference
    Dim attArr() As AcadAttributeReference
    Dim id As Long
    ThisDrawing.Utility.GetEntity oEnt, pickPt, vbCr & "Select polyline:"
    If TypeOf oEnt Is AcadLWPolyline Then
    Set oPoly = oEnt
    id = oPoly.ObjectID
    End If
    ThisDrawing.Utility.GetEntity oEnt, pickPt, vbCr & "Select block:"
    If TypeOf oEnt Is AcadBlockReference Then
     Set oBlkRef = oEnt
     ''~~~~~~~~~~~~loop through attributes~~~~~~~~''
     attArr = oBlkRef.GetAttributes
     For n = 0 To UBound(attArr)
     Set oAttrib = attArr(n)
    ''~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
     If UCase(oAttrib.TagString) = "CENTRO_COSTO" Then '<--change attribute  name "CENTRO_COSTO" here on whatever you need
     oAttrib.TextString = "%<\AcObjProp Object(%<\_ObjId " & CStr(id) & ">%).Area \f " & Chr(34) & "%lu2" & Chr(34) & ">%"
     Exit For
     End If
     Next n
    End If
    ThisDrawing.Regen acActiveViewport '<-- this line is important to display fields after changing
    End Sub

  15. #15
    VBAX Mentor ALe's Avatar
    Joined
    Aug 2005
    Location
    Milan
    Posts
    383
    Location
    FIXO I'm really impressed! Thank you so much!
    ALe
    Help indigent families: www.bancomadreteresa.org

  16. #16
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by ALe
    FIXO I'm really impressed! Thank you so much!
    You're welcome
    Happy computing

    ~'J'~

Posting Permissions

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