Solved: Read field in AUTOCAD block attribute

[ALe]

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.

[fixo]

Hi ALe, I posted solution on swamp as well
Here is a quick and dirty code

 
<CommandMethod("foo")> 
_ 
Public Sub 
    GetFieldFromAttribute() 
     
    Dim doc As Document = 
    Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument 
     
    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 tags courtesy of www.thecodenet.com

[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

[fixo]

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

[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? It seems .NET code

[fixo]

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

[ALe]

thank you Oleg, sure I'll wait!

[fixo]

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!

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 tags courtesy of www.thecodenet.com

here is AutoLisp code

;; 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 tags courtesy of www.thecodenet.com

[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.

[fixo]

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:

(vl-load-com) 

VBA tags courtesy of www.thecodenet.com

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

[ALe]

Quote:   Originally Posted by: fixo Hi Ale First you did not copied lisp code completely this line at the very top: (vl-load-com) VBA tags courtesy of www.thecodenet.com 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

[fixo]

Alright, I'll wating for result
of testing it on your working drawing
See you Monday

[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

oSset.SelectOnScreen fType, fData 

VBA tags courtesy of www.thecodenet.com

but this update doesn't work

oSset.Select acSelectionSetAll, , , fType, fData 

VBA tags courtesy of www.thecodenet.com

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

Thank you Oleg.

[fixo]

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 oSset.SelectOnScreen fType, fData VBA tags courtesy of www.thecodenet.com but this update doesn't work oSset.Select acSelectionSetAll, , , fType, fData VBA tags courtesy of www.thecodenet.com 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.:

 
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 tags courtesy of www.thecodenet.com

[ALe]

I did do ZoomExtents. this is original code (sound it familiar to you? )

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 tags courtesy of www.thecodenet.com

I Added the following lines instead of the last original sentence

Application.ZoomExtents 
oSset.Select acSelectionSetAll, , , fType, fData 

VBA tags courtesy of www.thecodenet.com

The selection gets the blocks but in such a way that is different from the original code...

[fixo]

Quote:   Originally Posted by: ALe I did do ZoomExtents. this is original code (sound it familiar to you? ) 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 tags courtesy of www.thecodenet.com I Added the following lines instead of the last original sentence Application.ZoomExtents oSset.Select acSelectionSetAll, , , fType, fData VBA tags courtesy of www.thecodenet.com 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

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 tags courtesy of www.thecodenet.com

[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!

[fixo]

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:

oSset.Select mode, , , dxfTyp, dxfDat 
MsgBox "Third  method: " & vbCr & "Selected using ""acSelectionSetAll"" mode " & oSset.Count & " blocks" & vbCr & _ 
"[ in the current DRAWING ]" 
 

VBA tags courtesy of www.thecodenet.com

[ALe]

thank you, I had seen it and corrected it.

Bye!

[fixo]

You're welcome
Cheers