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