Select one object using VB

[Jozi68]

I am trying to select one object using vbcode. I am using this at the moment:

 

Set objNEWSS = objDOC.SelectionSets.Add("VBA")

objNEWSS.SelectOnScreen intGroupCode, varGroupValue

 

But now my application waits for me to press enter after I've selected one or more objects. I need my application to continue the moment I click on one object.

Any suggestion will be appreciated.

[SEANT]

Look at the ThisDrawing.Utility.GetEntity method. You will have to create your own filtering mechanism, however. GetEntity does not support groupcode filtering.

[Jozi68]

I've heard that ThisDrawing only works in VBA. I am using VB6.

[SEANT]

Have you tried objDOC.Utility.GetEntity?

[Jozi68]

I get this error: Object does not support this property or method

[SEANT]

That suck's. I no longer have access to VB6, unfortunately, else I'd take a peek.

 

For what it's worth, VB.NET offers a lot more with regard to AutoCAD access.

[Jozi68]

How do you recommend I start learning VB.net?

[SEANT]

Here is an intro video as well as a thread containing some links with useful resources. Incidentally, much of the information referencing C# is directly applicable to VB.NET.

 

 

http://www.cadtutor.net/forum/showthread.php?t=28925

 

http://through-the-interface.typepad.com/through_the_interface/2007/11/devtv-introduct.html

[xsfhlzh]

try this class

use SelectSingleObject function

 
'ClassName:TlsSelectionSet
'Writer:xsfhlzh
Private oSel As AcadSelectionSet
Private mFilter As New TlsResultBuffer
Private sName As String
Private bDeleted As Boolean
Private Function IsNull() As Boolean
    If oSel Is Nothing Then
        IsNull = True
    ElseIf oSel.Count = 0 Then
        IsNull = True
    Else
        IsNull = False
    End If

End Function
Public Sub Init(Optional ByVal Name As String = "TlsSelectionSet", Optional ClearFilter As Boolean = True, Optional Deleted As Boolean = True)
On Error Resume Next

    If ClearFilter Then mFilter.Clear
    bDeleted = Deleted
    If Not oSel Is Nothing Then oSel.Delete
    sName = Name
    ThisDrawing.SelectionSets(sName).Delete
    Set oSel = ThisDrawing.SelectionSets.Add(sName)

End Sub
Private Sub Class_Terminate()
On Error Resume Next

    If bDeleted Then oSel.Delete

End Sub
Public Function ToArray()
On Error Resume Next

    Dim i
    Dim objs() As AcadEntity
    Dim nCount As Integer

    nCount = oSel.Count - 1
    ReDim objs(nCount)

    For i = 0 To nCount
        Set objs(i) = oSel(i)
    Next i

    ToArray = objs

End Function
Public Property Get Count() As Integer
On Error Resume Next
    Count = oSel.Count

End Property
Public Property Get Name() As String
On Error Resume Next
    Name = sName

End Property
Public Property Get Item(ByVal Index) As AcadEntity
On Error Resume Next
    Set Item = oSel(Index)

End Property
Public Property Get Deleted() As Boolean
    Deleted = bDeleted
End Property
Public Property Let Deleted(ByVal Value As Boolean)
    bDeleted = Value
End Property
Public Property Get AcSet() As Variant
On Error Resume Next

    Set AcSet = oSel

End Property
Public Property Set AcSet(Value As Variant)
On Error Resume Next

    Set oSel = Value
    sName = oSel.Name

End Property
Public Sub AddItems(ByVal objs)
On Error Resume Next

    If IsArray(objs) Then
        oSel.AddItems objs
    ElseIf IsObject(objs) Then
        If TypeOf objs Is AcadSelectionSet Then
            Dim temp As New TlsSelectionSet
            temp.Deleted = False
            temp.AcSet = objs
            oSel.AddItems temp.ToArray
        ElseIf TypeOf objs Is TlsSelectionSet Then
            oSel.AddItems objs.ToArray
        Else
            Dim ents(0) As AcadEntity
            Set ents(0) = objs
            oSel.AddItems ents
        End If
    End If

End Sub
Public Sub RemoveItems(ByVal objs)
On Error Resume Next

    If IsArray(objs) Then
        oSel.RemoveItems objs
    ElseIf IsObject(objs) Then
        If TypeOf objs Is AcadSelectionSet Then
            Dim temp As New TlsSelectionSet
            temp.Deleted = False
            temp.AcSet = objs
            oSel.RemoveItems temp.ToArray
        ElseIf TypeOf objs Is TlsSelectionSet Then
            oSel.RemoveItems objs.ToArray
        Else
            Dim ents(0) As AcadEntity
            Set ents(0) = objs
            oSel.RemoveItems ents
        End If
    End If

End Sub
Public Sub Clear()
On Error Resume Next

    Init sName
    oSel.Clear

End Sub
Public Sub Update()
On Error Resume Next

    oSel.Update
End Sub

Public Property Get PickfirstSelectionSet() As AcadSelectionSet
On Error Resume Next
    ThisDrawing.SelectionSets("PICKFIRST").Delete
    Set PickfirstSelectionSet = ThisDrawing.PickfirstSelectionSet

End Property
Public Property Get ActiveSelectionSet() As AcadSelectionSet
On Error Resume Next
    ThisDrawing.SelectionSets("CURRENT").Delete
    Set ActiveSelectionSet = ThisDrawing.ActiveSelectionSet
End Property
Public Sub SelectOnScreen()
On Error Resume Next

    If mFilter.IsNull Then
        oSel.SelectOnScreen
    Else
        oSel.SelectOnScreen mFilter.TypeCodes, mFilter.Datas
    End If

End Sub
Public Sub SelectSingleObject(Optional Prompt As String = "")
On Error GoTo ErrHandle
    Dim obj As AcadEntity, pnt
    If mFilter.IsNull Then
        If Prompt = "" Then
            ThisDrawing.Utility.GetEntity obj, pnt
        Else
            ThisDrawing.Utility.GetEntity obj, pnt, Prompt
        End If
        AddItems obj
    Else
        SelectObject acSelectionSetAll
        Do
            If Prompt = "" Then
                ThisDrawing.Utility.GetEntity obj, pnt
            Else
                ThisDrawing.Utility.GetEntity obj, pnt, Prompt
            End If
            oCount = Count
            RemoveItems obj
            If oCount <> Count Then
                Clear
                AddItems obj
                Exit Do
            End If
        Loop
    End If
    Exit Sub
ErrHandle:
    Clear
End Sub
Public Sub SelectObject(ByVal Mode As AcSelect, Optional ByVal Point1, Optional ByVal Point2)
On Error Resume Next

    If mFilter.IsNull Then
        If IsMissing(Point1) Then
            oSel.Select Mode
        Else
            oSel.Select Mode, Point1, Point2
        End If
    Else
        If IsMissing(Point1) Then
            oSel.Select Mode, , , mFilter.TypeCodes, mFilter.Datas
        Else
            oSel.Select Mode, Point1, Point2, mFilter.TypeCodes, mFilter.Datas
        End If
    End If

End Sub
Public Sub SelectAtPoint(ByVal Point)
On Error Resume Next

    If mFilter.IsNull Then
        oSel.SelectAtPoint Point
    Else
        oSel.SelectAtPoint Point, mFilter.TypeCodes, mFilter.Datas
    End If

End Sub
Public Sub SelectByPolygon(ByVal Mode As AcSelect, Optional ByVal Points)
On Error Resume Next

    If mFilter.IsNull Then
        oSel.SelectByPolygon Mode, Points
    Else
        oSel.SelectByPolygon Mode, Points, mFilter.TypeCodes, mFilter.Datas
    End If

End Sub
Public Property Get Filter() As TlsResultBuffer
On Error Resume Next
    Set Filter = mFilter

    If Err Then
        Set mFilter = New TlsResultBuffer
        Set Filter = mFilter
        Err.Clear
    End If
End Property
Private Function CreatePoint(Optional ByVal x As Double = 0#, Optional ByVal y As Double = 0#, Optional ByVal Z As Double = 0#)

    Dim pnt(2) As Double
    pnt(0) = x: pnt(1) = y: pnt(2) = Z
    CreatePoint = pnt

End Function

[xsfhlzh]

'ClassName:TlsResultBuffer
'Writer:xsfhlzh
Private m_TypeCodes, m_Datas
Private m_Count As Integer
Public Sub SetData(ParamArray Values())
On Error Resume Next
    
     Dim i
     Dim n As Integer
     Dim nCount As Integer
     nCount = (UBound(Values) + 1) / 2 - 1
    
     If nCount = 0 And IsArray(Values(0)) And IsArray(Values(1)) Then
    
        m_TypeCodes = Values(0)
        m_Datas = Values(1)
    
     Else
    
        Dim t() As Integer, d()
        ReDim t(nCount), d(nCount)
        For i = 0 To nCount
            n = i * 2
            t(i) = Values(n)
            d(i) = Values(n + 1)
        Next i
    
        m_TypeCodes = t
        m_Datas = d
    
    End If
    m_Count = UBound(m_TypeCodes) + 1
End Sub
Public Sub AppendData(ParamArray Values())
On Error Resume Next
    Dim m As Integer, n As Integer, nCount As Integer
    nCount = (UBound(Values) + 1) / 2
    n = m_Count + nCount - 1
    ReDim Preserve m_TypeCodes(n), m_Datas(n)
    For i = 0 To nCount - 1
        m = m_Count + i
        n = i * 2
        m_TypeCodes(m) = Values(n)
        m_Datas(m) = Values(n + 1)
    Next i
    m_Count = m_Count + nCount
    
End Sub
Public Sub GetData(ByRef TypeCodes, ByRef Datas)
    TypeCodes = m_TypeCodes
    Datas = m_Datas
End Sub
Public Sub Clear()
    m_TypeCodes = Null
    m_Datas = Null
    
End Sub
Public Property Get TypeCodes() As Variant
    TypeCodes = m_TypeCodes
 
End Property
Public Property Let TypeCodes(ByVal vNewValue As Variant)
    m_TypeCodes = vNewValue
 
End Property
Public Property Get Datas() As Variant
    Datas = m_Datas
    
End Property
Public Property Let Datas(ByVal vNewValue As Variant)
    m_Datas = vNewValue
    
End Property
Public Property Get Count() As Integer
On Error Resume Next
    Count = m_Count
    
End Property
Public Property Get IsNull() As Boolean
    IsNull = (Count = 0)
    
End Property

[Jozi68]

Thanx for your reply xsfhlzh.

Unfortunately I can not use ThisDrawing as I am using VB6.

Looks like I will have to start learning .net

[Jozi68]

OK so now I'm using vb.net. xsfhlzh, I don't really know what to do with all the code you sent me. I just need a user to select a single polyline before my program continues.

[SEANT]

Post #12 of this thread has an example of a selection filtered for just a Polyline.

 

http://www.cadtutor.net/forum/showthread.php?t=29602

[bhargav1987]

I am trying to select one object using vbcode. I am using this at the moment:

 

Set objNEWSS = objDOC.SelectionSets.Add("VBA")

objNEWSS.SelectOnScreen intGroupCode, varGroupValue

 

But now my application waits for me to press enter after I've selected one or more objects. I need my application to continue the moment I click on one object.

Any suggestion will be appreciated.

Is there any possibility to find an nearest line from a point using vba??