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
    VB:
     
    <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 
    
    
    Formatting tags added by mark007

  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!

    VB:
    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
    
    
    Formatting tags added by mark007
    here is AutoLisp code
    VB:
    ;; 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) 
    
    
    Formatting tags added by mark007

  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:
    VB:
    (vl-load-com) 
    
    
    Formatting tags added by mark007
    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:
    VB:
    (vl-load-com) 
    
    
    Formatting tags added by mark007
    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
    VB:
    oSset.SelectOnScreen fType, fData 
    
    
    Formatting tags added by mark007
    but this update doesn't work
    VB:
    oSset.Select acSelectionSetAll, , , fType, fData 
    
    
    Formatting tags added by mark007
    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
    VB:
    oSset.SelectOnScreen fType, fData 
    
    
    Formatting tags added by mark007
    but this update doesn't work
    VB:
    oSset.Select acSelectionSetAll, , , fType, fData 
    
    
    Formatting tags added by mark007
    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.:
    VB:
     
    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 
    
    
    Formatting tags added by mark007

  15. #15
    I did do ZoomExtents. this is original code (sound it familiar to you? )
    VB:
    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 
    
    
    Formatting tags added by mark007
    I Added the following lines instead of the last original sentence
    VB:
    Application.ZoomExtents 
    oSset.Select acSelectionSetAll, , , fType, fData 
    
    
    Formatting tags added by mark007
    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? )
    VB:
    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 
    
    
    Formatting tags added by mark007
    I Added the following lines instead of the last original sentence
    VB:
    Application.ZoomExtents 
    oSset.Select acSelectionSetAll, , , fType, fData 
    
    
    Formatting tags added by mark007
    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
    VB:
    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 
    
    
    Formatting tags added by mark007

  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:
    VB:
    oSset.Select mode, , , [COLOR=red]dxfTyp, dxfDat[/COLOR] 
    MsgBox "Third  method: " & vbCr & "Selected using ""acSelectionSetAll"" mode " & oSset.Count & " blocks" & vbCr & _ 
    "[ in the current DRAWING ]" 
    
    
    Formatting tags added by mark007

  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
  •