Runtime error

[h.rouvoet]

Hi all,

I have a problem with my function;

My routine lets the user pick an object on screen.

A first failure in selecting an object (The user picks anywhere on the screen), the routine displayes an message box.

A second failure in selecting an object generates a runtime error.
<"Method 'GetSubEntity' of object 'IAcadUtility' failed">

How do i solve this problem?

Here is the VBA-Code:

>Public Sub Fase_Enkel()
>On Error GoTo Fout
>UserForm1.Hide
>Fase = "L1"
>
>If UserForm1.OptionButton5.Value = True Then
> Fase = "L2"
>End If
>If UserForm1.OptionButton6.Value = True Then
> Fase = "L3"
>End If
>
>SELECTEER:
>ThisDrawing.Utility.GetSubEntity objEnt, varPnt, vbCr & "Selecteer een tekst: ", varData
>
>If objEnt.ObjectName = "AcDbAttribute" Then
> Set objAttr = objEnt
> objAttr.TextString = Fase
> Haal_Fase
> GoTo SELECTEER
>End If
>If objEnt.ObjectName = "AcDbText" Or objEnt.ObjectName = "AcDbMtext" Then
> objEnt.TextString = Fase
> objEnt.Update
> Haal_Fase
> GoTo SELECTEER
>End If
>
>Fout:
> If MsgBox("Er is geen tekst geselecteerd. Verder gaan met selecteren?", vbYesNo, "Fout") = vbYes Then
> Err.Clear
> GoTo SELECTEER
> End If
>
>EINDE:
>UserForm1.Show
>End Sub

END Code

[RobertB]

Here is a function I use to select a subentity. It allows the operator to use <Enter> to exit the subroutine, so your main code needs to check if the returned object is Nothing and exit quietly.

Option Explicit

Private Function SelectSubEnt(Optional Msg As String = "Select object: ") As AcadEntity
  Dim myMsg As String
  myMsg = vbCrLf & Msg
    
  Dim pickObj As AcadEntity
  Dim pickPt As Variant
  Dim pickMatrix As Variant
  Dim pickContext As Variant
  Dim ErrNo As Integer
  ErrNo = 0
  
  With ThisDrawing
    On Error GoTo CheckErr
    .SetVariable "ErrNo", ErrNo
    .Utility.GetSubEntity pickObj, pickPt, pickMatrix, pickContext, myMsg
  End With
  
  Set SelectSubEnt = pickObj

ExitHere:
  Exit Function
  
CheckErr:
  Debug.Print Err.Description
  If InStr(1, Err.Description, "failed", vbTextCompare) > 0 Then
    ErrNo = CInt(ThisDrawing.GetVariable("ErrNo"))
    If ErrNo = 52 Then
      Err.Clear
      Resume ExitHere
    ElseIf ErrNo = 7 Then
      Err.Clear
      Resume
    End If
  Else
    MsgBox Err.Description
    Resume ExitHere
  End If
End Function

Sub Test()
  Dim myObj As AcadEntity
  Set myObj = SelectSubEnt
  If myObj Is Nothing Then
    MsgBox "User hit <Enter>, exit quietly."
  Else
    MsgBox "Found object: " & myObj.ObjectName
  End If
End Sub

[h.rouvoet]

Thanks Robert,

I could use some bits of your code to modify my routine.
for example:
>SELECT:
>Set objEnt = SelectSubEnt
> If objEnt Is Nothing Then
> GoTo Fout
> End If

Now it works like a dream......