Excel Hints

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 21

Thread: Solved: Read field in AUTOCAD block attribute

  1. #1

    Solved: Read field in AUTOCAD block attribute

    Hi all,

    I have a block-reference with attributereferences.

    One of these references is a calculated field that gives the area of a polyline.

    This is its calculation expression:
    %<\AcObjProp Object(%<\_ObjId 2129748024>%).Area \f "%lu2">%

    where 2129748024 is the ID of the linked polyline.

    I'd like to get the expression above in order to extract the object id number (2129748024). My aim is to get the id number and use it to insert a new attribute into the block that will have a calculated field corresponding to the length of the same polyline.

    Thanks in advance.
    ALe
    Help indigent families: www.bancomadreteresa.org

  2. #2
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Hi ALe, I posted solution on swamp as well
    Here is a quick and dirty code
    [vba]

    <CommandMethod("foo")>
    _
    Public Sub
    GetFieldFromAttribute()

    Dim doc As Document =
    Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveD ocument

    Dim db As Database =
    doc.Database

    Dim ed As Editor = doc.Editor



    Try

    Dim tab As String =
    Autodesk.AutoCAD.ApplicationServices.Application.GetSystemVariable("ctab"). ToString

    Dim blockname As String = ed.GetString(vbLf & "Enter blockname:
    ").StringResult

    Dim opts As PromptSelectionOptions = New
    PromptSelectionOptions

    opts.SingleOnly =
    True

    opts.MessageForRemoval = vbLf & "Select block
    only"

    opts.MessageForAdding = vbLf & "Select single
    block"

    Dim filt As SelectionFilter = New SelectionFilter({New TypedValue(0, "insert"),
    New TypedValue(2, blockname), New TypedValue(410,
    tab)})

    Dim psr As PromptSelectionResult = ed.GetSelection(opts,
    filt)

    If psr.Status <> PromptStatus.OK Then Exit
    Sub

    If psr.Value.Count <> 1 Then Exit
    Sub

    Dim id As ObjectId =
    psr.Value.GetObjectIds(0)

    If id.IsNull Then Exit
    Sub

    Using tr As Transaction =
    db.TransactionManager.StartTransaction()

    Dim obj As DBObject = tr.GetObject(psr.Value.GetObjectIds(0),
    OpenMode.ForRead)

    If TypeOf obj Is BlockReference
    Then

    Dim bref As BlockReference = CType(tr.GetObject(id, OpenMode.ForRead),
    BlockReference)

    Dim attcoll As AttributeCollection =
    bref.AttributeCollection

    Dim att As
    AttributeReference

    For Each aid As ObjectId In
    attcoll

    Dim aobj As DBObject = tr.GetObject(aid,
    OpenMode.ForRead)

    att = TryCast(DirectCast(aobj, AttributeReference),
    AttributeReference)

    If att Is Nothing Then Exit
    Sub

    If att.Tag.Equals("LENGTH", StringComparison.CurrentCultureIgnoreCase)
    Then

    If att.HasFields
    Then

    Dim fld As Field = tr.GetObject(att.GetField(),
    OpenMode.ForRead)

    Dim code As String =
    fld.GetFieldCode

    Dim pos1 As Int32 =
    code.IndexOf("_ObjId")

    Dim pos2 As Integer =
    code.IndexOf(">%")

    Dim leng1 As Integer =
    "_ObjId".Length

    Dim leng2 As Integer =
    ">%".Length

    Dim idstr As String = code.Substring(pos1 + leng1 + 1, pos2 - (pos1 + leng1) -
    1)

    MsgBox("ID from field code: " &
    idstr)

    Dim objId As ObjectId = New ObjectId(New
    IntPtr(Convert.ToInt32(idstr)))

    Dim fieldchild As DBObject = tr.GetObject(objId,
    OpenMode.ForRead)

    If TypeOf fieldchild Is Polyline
    Then

    Dim poly As Polyline = DirectCast(fieldchild,
    Polyline)

    MsgBox("Compare:" & vbLf & "Return from attribute: " &
    att.TextString & vbLf & "Return from Polyline: " &
    poly.Area.ToString)

    End
    If

    Exit
    For

    End
    If

    End
    If

    Next

    End
    If

    End Using

    Catch ex As
    Autodesk.AutoCAD.Runtime.Exception

    ed.WriteMessage(ex.Message + vbLf +
    ex.StackTrace)

    End Try
    End Sub
    [/vba]

  3. #3
    Great Fixo, to tell you the truth I hoped you were around!

    I'll give a try tonight and let you know!

    Thank you
    ALe
    Help indigent families: www.bancomadreteresa.org

  4. #4
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by ALe
    Great Fixo, to tell you the truth I hoped you were around!

    I'll give a try tonight and let you know!

    Thank you
    Sorry I kinda sick a bit and see the forum not too often
    Hope this will be working on your end, just change an attribute tag
    (I used 'LENGTH' i.e.) etc...
    See you

    Oleg

  5. #5
    I hope nothing serious!

    I was curious so I started to run the code, I'm having troubles with formatting.

    I'm supposed to run it via VBA? It seems .NET code
    ALe
    Help indigent families: www.bancomadreteresa.org

  6. #6
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by ALe
    I hope nothing serious!

    I was curious so I started to run the code, I'm having troubles with formatting.

    I'm supposed to run it via VBA?
    My bad this is VB.NET solution, sorry
    I will try to rewrite it on VBA but I' not sure I'll do it
    Wait for tomorrow

    Sorry, buddy

  7. #7
    thank you Oleg, sure I'll wait!
    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
    thank you Oleg, sure I'll wait!
    Unfortunately there are no chances to solve such problem with use of pure VBA methods
    .
    The instruction:
    Keep a file.LSP in a working directory, for example as
    alinks.lsp

    Open drawing
    Go to the menu Tools-> AutoLisp-> Load Application
    Find in a dialogue window the kept file alinks.lsp and specify it
    He will be loaded and carry out all actions automatically

    Then you can open and use my VBA a code

    Good luck!

    [vba]
    Option Explicit

    Public Function ReadTxtFile(fil As String)
    Dim fd As Long
    Dim sline As String
    Dim ar As Variant
    Dim txtColl As New Collection
    fd = FreeFile
    Open fil For Input Access Read Shared As fd
    Do Until EOF(fd)
    Line Input #fd, sline
    ar = Split(sline, ",")
    txtColl.Add ar, CStr(ar(0))
    Loop
    Close fd
    Set ReadTxtFile = txtColl
    End Function

    Public Sub GetObjectsByField()
    Dim oSset As AcadSelectionSet
    Dim blkRef As AcadBlockReference
    Dim attObj As AcadAttributeReference
    Dim attData() As AcadObject
    Dim newVal As String
    Dim fType(1) As Integer
    Dim fData(1) As Variant
    Dim attHandle As String
    Dim k As Integer

    ' declare collection to hold pairs of object Handles
    Dim hndColl As New Collection
    Dim itm As Variant
    'Dim ar() As Variant
    Dim i As Integer, j As Integer
    Dim filename As String
    '.csv file was saved from lisp with the same name:
    filename = ThisDrawing.Path & "\" & Replace(ThisDrawing.Name, "dwg", "csv")
    If Dir(filename) = "" Then '' <-- check if file exist
    MsgBox ("File .csv not found. Run lisp before") '' <-- if not then show message and exit program
    Exit Sub
    End If
    Set hndColl = ReadTxtFile(filename)
    fType(0) = 0: fType(1) = 2
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    fData(0) = "INSERT": fData(1) = "myblock" '' <-- change blockname here
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    For Each oSset In ThisDrawing.SelectionSets
    If oSset.Name = "$Blocks$" Then
    oSset.Delete
    Exit For
    End If
    Next oSset
    Set oSset = ThisDrawing.SelectionSets.Add("$Blocks$") '' <-- any name is admissible
    On Error GoTo 0
    oSset.SelectOnScreen fType, fData
    For Each blkRef In oSset
    attData = blkRef.GetAttributes
    For k = 0 To UBound(attData)
    Set attObj = attData(k)
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    If attObj.TagString = "LENGTH" Then '' <-- change attribute tag here
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'

    '/*====================this code block might be removed ================'
    Dim Xdictionary As AcadDictionary
    Set Xdictionary = attObj.GetExtensionDictionary
    Dim fldObject As Object
    On Error Resume Next
    ' check if attribute has field
    Set fldObject = Xdictionary.GetObject("ACAD_FIELD")
    If Err.Number <> 0 Then
    Err.Clear
    If fldObject Is Nothing Then
    Exit Sub
    End If
    End If
    '======================================================================*/'

    'get attribute Handle property
    attHandle = attObj.handle
    Debug.Print attHandle
    Exit For
    End If
    Next k
    ' try to find object by attribute handle
    Dim foundHandle As String
    foundHandle = ""
    ' loop through collection of pairs to search for associative handle
    For Each itm In hndColl
    If Trim(CStr(itm(0))) = attHandle Then
    foundHandle = Trim(CStr(itm(1)))
    'if found then exit from loop
    Exit For
    End If
    Next itm
    If foundHandle = "" Then Exit Sub
    Dim holderObj As AcadObject
    ' retrive object from drawing usin its handle
    Set holderObj = ThisDrawing.HandleToObject(foundHandle)
    'check on object type, do your stuffs with this object
    If TypeOf holderObj Is AcadLWPolyline Then
    Dim plineObj As AcadLWPolyline
    Set plineObj = holderObj
    '' add some properties to show result ony:
    plineObj.color = acRed
    plineObj.Lineweight = acLnWt050
    ElseIf TypeOf holderObj Is AcadLine Then
    Dim lineObj As AcadLWPolyline
    Set lineObj = holderObj
    '' add some properties to show result ony:
    lineObj.color = acBlue
    lineObj.Lineweight = acLnWt020
    ElseIf TypeOf holderObj Is AcadCircle Then
    Set circObj = holderObj
    '' add some properties to show result ony:
    circObj.color = acMagenta
    circObj.Lineweight = acLnWt020
    '' ElseIf TypeOf holderObj Is AcadBlbla''<--etc...
    End If
    Next blkRef
    '' clean up
    oSset.Delete
    Set oSset = Nothing
    Set hndColl = Nothing
    End Sub

    'Sub test()
    'Dim hndColl As New Collection
    'Dim itm As Variant
    'Dim ar() As Variant
    'Dim i As Integer, j As Integer
    'Dim filename As String
    'filename = ThisDrawing.Path & "\" & Replace(ThisDrawing.Name, "dwg", "csv")
    'If Dir(filename) = "" Then
    'MsgBox ("File .csv not found. Run lisp before")
    'Exit Sub
    'End If
    'Set hndColl = ReadTxtFile(filename)
    'i = 0
    'For Each itm In hndColl
    'Debug.Print itm(0) & vbTab & itm(1)
    'i = i + 1
    'Next itm
    '
    '
    'End Sub
    [/vba]

    here is AutoLisp code
    [vba]
    ;; Open Notepad and save this code say as ALINKS.lsp
    (vl-load-com)
    ;; helper functions
    ;;;(C)2005 Jason Piercey
    ; function to determine if a field
    ; has been applied to an object.
    ; Arguments:
    ; [object] - vla-object
    ; return: vla-object, IAcadObject or nil
    ; Notes:
    ; First stab at doing anything with fields
    ; unsure if this function will cover all
    ; instances that are possible.
    (defun field-p (object / result)
    (if
    (and
    (= :vlax-true (vla-get-hasextensiondictionary object))
    (setq
    result
    (vl-catch-all-apply
    (function
    (lambda ()
    (vla-item
    (vla-getextensiondictionary object)
    "Acad_field")))))
    (not (vl-catch-all-error-p result)) )

    (vla-item result 0)
    )
    )
    ; based on function above
    ; function to get handle
    ; Arguments:
    ; [handle of parent object] - string
    ; return: handle of object, linked by field , string or empty string
    (defun getholder(handle / atobj doc elist field fieldobj flddict holder)
    (setq doc
    (vla-get-activedocument(vlax-get-acad-object)))
    (setq atobj (vlax-ename->vla-object (handent handle)))
    (setq flddict(vl-catch-all-apply
    (function
    (lambda ()
    (vla-item
    (vla-getextensiondictionary atobj)
    "ACAD_FIELD")))))
    (setq fieldobj (vl-catch-all-apply
    (function
    (lambda ()
    (vla-item
    flddict
    "TEXT")))))
    (setq field (vlax-vla-object->ename fieldobj))
    (setq elist (entget field))
    (setq holder (cdr (assoc 5 (entget (cdr (assoc 331(entget (cdr (assoc 360 elist)))))))))
    holder
    )
    ;;============================ main program =============================;;
    (defun C:ALINKS (/ *error* attlist blkname blkobj datafile data_line en filename hdl sset tagname)
    (defun *error* (msg)
    (if datafile (close datafile))
    (if msg (princ (strcat "\nError! " msg)))
    (princ)
    )

    (setq filename (strcat (getvar "dwgprefix")
    (vl-filename-base (getvar "dwgname"))".csv")
    )
    (setq blkname (getstring T "\nEnter block name: "))
    (if (eq blkname "")(progn (exit)(princ)))
    (setq tagname (strcase (getstring T "\nEnter attribute tag: ")))
    (if (eq tagname "")(progn (exit)(princ)))
    (command "._zoom" "_e")
    (prompt "\n\tSelect desired blocks >> ")
    (if
    (setq sset (ssget "X"
    (list
    (cons 0 "INSERT")
    (cons 2 blkname)
    (cons 66 1)
    (cons 410 (getvar "CTAB")))))

    (progn
    (setq datafile (open filename "W"))

    (while (setq en (ssname sset 0))
    (setq blkobj (vlax-ename->vla-object en))
    (setq attlist (vlax-invoke blkobj 'getattributes))
    (foreach attobj attlist
    (if (and (eq (strcase (vla-get-tagstring attobj)) (strcase tagname))(field-p attobj))
    (progn
    (setq data_line (strcat (setq hdl(vla-get-handle attobj)) "," (getholder hdl)))
    (write-line data_line datafile))))
    (ssdel en sset)
    )
    (close datafile)
    )
    )
    (command "._zoom" "_p")
    (alert (strcat "Handle pairs was saved in file:\n" "\"" filename "\"\n( in the same folder )" ))
    (princ)
    )
    (C:ALINKS)
    (prompt "\nLisp code loaded...")
    ;;;(prompt "\nStart command with Alinks")
    (prin1)
    [/vba]

  9. #9
    some troubles.

    1) when I appload alinks.lsp, following the instructions i get this error:

    Comand: appload
    alinks.lsp loaded.
    Comand:
    Enter block name: Etichetta Locale
    Enter attribute tag: CODICE_LOCALE
    ._zoom
    Specificare un angolo della finestra, digitare un fattore di scala (nX o nXP) o
    [Tutto/Centrato/Dinamico/Estensioni/Precedente/scAla/Finestra/Oggetto] <tempo
    reale>: _e
    Comand:
    Select desired blocks >>
    Error! no function definition: VLAX-ENAME->VLA-OBJECT

    2) when i run vba code it seems it can't get Extension Dictionary for the attribute attObj.

    I really hope this is not so difficult to solve. I attach my files if these could be of help.
    Attached Files Attached Files
      To view attachments your post count must be 0 or greater. Your post count is 0 momentarily.
    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
    some troubles.

    1) when I appload alinks.lsp, following the instructions i get this error:

    Comand: appload
    alinks.lsp loaded.
    Comand:
    Enter block name: Etichetta Locale
    Enter attribute tag: CODICE_LOCALE
    ._zoom
    Specificare un angolo della finestra, digitare un fattore di scala (nX o nXP) o
    [Tutto/Centrato/Dinamico/Estensioni/Precedente/scAla/Finestra/Oggetto] <tempo
    reale>: _e
    Comand:
    Select desired blocks >>
    Error! no function definition: VLAX-ENAME->VLA-OBJECT

    2) when i run vba code it seems it can't get Extension Dictionary for the attribute attObj.

    I really hope this is not so difficult to solve. I attach my files if these could be of help.
    Hi Ale
    First you did not copied lisp code completely
    this line at the very top:
    [vba](vl-load-com)[/vba]
    is very important, it will be upload ActiveX dynamic libraries and its functions from AutoCAD program folder
    Secondly, in your drawing I have not found a blocks 'Etichetta locale'
    with attributes CODICE_LOCALE that has fields - every attribute just with
    value of 'XXXX', by this reason the lisp command will be return just empty
    CSV file
    So add a line of code above, populate 1-2 block attribute with fields
    and try again
    Hey, this drawing is very familiar to me, buddy
    Let me know the result after test

  11. #11

    Thumbs up

    Quote Originally Posted by fixo
    Hi Ale
    First you did not copied lisp code completely
    this line at the very top:
    [vba](vl-load-com)[/vba]
    is very important, it will be upload ActiveX dynamic libraries and its functions from AutoCAD program folder
    Secondly, in your drawing I have not found a blocks 'Etichetta locale'
    with attributes CODICE_LOCALE that has fields - every attribute just with
    value of 'XXXX', by this reason the lisp command will be return just empty
    CSV file
    So add a line of code above, populate 1-2 block attribute with fields
    and try again
    Hey, this drawing is very familiar to me, buddy
    Let me know the result after test
    sorry for the first line. now lisp works.

    Also VBA code seems to work!!!!

    Yes the file! it is the only file I had to send you and to test because today i'm not in my office, so I downloaded from my previous post.

    Of course you know it!
    Thank you so much.

    Next Monday I'll try to suit it to my needs.

    Bye
    ALe
    Help indigent families: www.bancomadreteresa.org

  12. #12
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Alright, I'll wating for result
    of testing it on your working drawing
    See you Monday

  13. #13
    here test result: working perfectly!

    I changed the lisp code in order to suit to my needs (the variables "Etichetta Locale" and "Area Stanza" are given by default).

    the strange thing is that the original code works for this line
    [VBA]
    oSset.SelectOnScreen fType, fData
    [/VBA]

    but this update doesn't work
    [VBA]
    oSset.Select acSelectionSetAll, , , fType, fData
    [/VBA]

    and I don't understand why. But this is another issue...

    Thank you Oleg.
    ALe
    Help indigent families: www.bancomadreteresa.org

  14. #14
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by ALe
    here test result: working perfectly!

    I changed the lisp code in order to suit to my needs (the variables "Etichetta Locale" and "Area Stanza" are given by default).

    the strange thing is that the original code works for this line
    [vba]
    oSset.SelectOnScreen fType, fData
    [/vba]

    but this update doesn't work
    [vba]
    oSset.Select acSelectionSetAll, , , fType, fData
    [/vba]

    and I don't understand why. But this is another issue...

    Thank you Oleg.
    You're welcome

    You have to zoom drawing to extents before selection,

    and define selection mode explicitly,

    Something like, i.e.:
    [vba]

    Dim oSset As AcadSelectionSet

    Set oSset = ThisDrawing.SelectionSets.Add("$Plines$")

    ZoomExtents

    Dim mode As Integer

    mode = acSelectionSetAll

    Dim vt(0 To 2) As Integer

    vt(0) = 0: vt(1) = 70: vt(2) = 410

    Dim curTab As Variant

    curTab = ThisDrawing.GetVariable("CTAB")

    oSset.Select mode, , , vt, Array("LWPOLYLINE", 1, CStr(curTab))

    MsgBox "Selected " & oSset.Count & " closed polylines"

    oSset.Delete[/vba]

  15. #15
    I did do ZoomExtents. this is original code (sound it familiar to you? )
    [VBA]
    Dim fType(1) As Integer
    Dim fData(1) As Variant

    fType(0) = 0: fType(1) = 2
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    fData(0) = "INSERT": fData(1) = "Etichetta Locale" '' <-- change blockname here
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    For Each oSset In ThisDrawing.SelectionSets
    If oSset.Name = "$Blocks$" Then
    oSset.Delete
    Exit For
    End If
    Next oSset
    Set oSset = ThisDrawing.SelectionSets.Add("$Blocks$") '' <-- any name is admissible
    On Error GoTo 0

    oSset.SelectOnScreen fType, fData
    [/VBA]

    I Added the following lines instead of the last original sentence
    [VBA]
    Application.ZoomExtents
    oSset.Select acSelectionSetAll, , , fType, fData
    [/VBA]

    The selection gets the blocks but in such a way that is different from the original code...
    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
    I did do ZoomExtents. this is original code (sound it familiar to you? )
    [vba]
    Dim fType(1) As Integer
    Dim fData(1) As Variant

    fType(0) = 0: fType(1) = 2
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    fData(0) = "INSERT": fData(1) = "Etichetta Locale" '' <-- change blockname here
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    For Each oSset In ThisDrawing.SelectionSets
    If oSset.Name = "$Blocks$" Then
    oSset.Delete
    Exit For
    End If
    Next oSset
    Set oSset = ThisDrawing.SelectionSets.Add("$Blocks$") '' <-- any name is admissible
    On Error GoTo 0

    oSset.SelectOnScreen fType, fData
    [/vba]

    I Added the following lines instead of the last original sentence
    [vba]
    Application.ZoomExtents
    oSset.Select acSelectionSetAll, , , fType, fData
    [/vba]

    The selection gets the blocks but in such a way that is different from the original code...
    Try this quick example
    Hope this will make a sense
    [vba]
    Sub Example_CompareSelectionModes()
    Dim oSset As AcadSelectionSet
    Dim fType(1) As Integer
    Dim fData(1) As Variant
    With ThisDrawing.SelectionSets
    While .Count > 0
    .Item(0).Delete
    Wend
    Set oSset = .Add("$Parcels$")
    End With

    fType(0) = 0: fType(1) = 2
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    fData(0) = "INSERT": fData(1) = "Etichetta Locale" '' <-- change blockname here
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    For Each oSset In ThisDrawing.SelectionSets
    If oSset.Name = "$Blocks$" Then
    oSset.Delete
    Exit For
    End If
    Next oSset
    Set oSset = ThisDrawing.SelectionSets.Add("$Blocks$") '' <-- any name is admissible
    On Error GoTo 0
    '' 1st case: Select on screen is means selection in the current layout
    '' so it is no needs to define selection filter with dxf code for current layout

    oSset.SelectOnScreen fType, fData
    MsgBox "First method: " & vbCr & "Selected on screen manually " & oSset.Count & " blocks" & vbCr & _
    "[ that is means in the current LAYOUT ]"
    '' using the same selection for the second method

    oSset.Clear

    '' 2nd case: Select all in the current layout
    '' in this case you have to to define selection filter with dxf code for current layout

    Application.ZoomExtents '<-- always use it before of selection without manual interaction

    Dim mode As Integer

    mode = acSelectionSetAll '<-- define mode explicitly

    Dim curTab As Variant

    curTab = ThisDrawing.GetVariable("CTAB")

    Dim dxfType(2) As Integer
    Dim dxfData(2) As Variant
    dxfType(0) = 0: dxfType(1) = 2: dxfType(2) = 410 '<-- 410 is dxf code for layout name
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    dxfData(0) = "INSERT": dxfData(1) = "Etichetta Locale": dxfData(2) = CStr(curTab) '<-- dxf value for current layout name
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    oSset.Select mode, , , dxfType, dxfData
    MsgBox "Second method: " & vbCr & "Selected using ""acSelectionSetAll"" mode " & oSset.Count & " blocks" & vbCr & _
    "[ in the current LAYOUT ]"
    '' using the same selection for the third method

    oSset.Clear

    '' 3nd case: Select all in the current drawing
    '' no need to define selection filter with dxf code for current layout for you

    Dim dxfTyp(1) As Integer
    Dim dxfDat(1) As Variant
    dxfTyp(0) = 0: dxfTyp(1) = 2
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    dxfDat(0) = "INSERT": dxfDat(1) = "Etichetta Locale"
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
    oSset.Select mode, , , dxfType, dxfData
    MsgBox "Third method: " & vbCr & "Selected using ""acSelectionSetAll"" mode " & oSset.Count & " blocks" & vbCr & _
    "[ in the current DRAWING ]"
    End Sub[/vba]

  17. #17
    thank you very much!

    For each one of the case the number of blocks results the same.

    Running all the code:
    1st case works always.
    2nd case works for some files, not for some others.
    3rd case doesn't work.

    I can't explain why this happens, but it's good for me to work using 1st case.

    Thank you again for your wonderful help!
    ALe
    Help indigent families: www.bancomadreteresa.org

  18. #18
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    Quote Originally Posted by ALe
    thank you very much!

    For each one of the case the number of blocks results the same.

    Running all the code:
    1st case works always.
    2nd case works for some files, not for some others.
    3rd case doesn't work.

    I can't explain why this happens, but it's good for me to work using 1st case.

    Thank you again for your wonderful help!
    Sorry, my bad the very last code must be like this:
    [vba]
    oSset.Select mode, , , dxfTyp, dxfDat
    MsgBox "Third method: " & vbCr & "Selected using ""acSelectionSetAll"" mode " & oSset.Count & " blocks" & vbCr & _
    "[ in the current DRAWING ]"

    [/vba]

  19. #19
    thank you, I had seen it and corrected it.

    Bye!
    ALe
    Help indigent families: www.bancomadreteresa.org

  20. #20
    VBAX Regular fixo's Avatar
    Joined
    Jul 2006
    Location
    Sankt-Petersburg
    Posts
    99
    Location
    You're welcome
    Cheers

Posting Permissions

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