ConstructCircle - Run-time error '424' Object required. How to fix it?

MarAlcaraz1 · ‎11-22-2011

Hi everybody!

Could someone help me with this error? Well, in general, with the whole code, because it returns me different errors. The firs one is about the line pConstCArc.ConstrutCircle. I'd like to convert points from a table to polygons in a feature class.

Thanks in advance for helping me to learn more about ArcObjects!

Private Sub InterpretationTubes_Click()

Dim pSxDoc As ISxDocument
Set pSxDoc = ThisDocument

Dim pScene As IScene
Set pScene = pSxDoc.Scene

Dim i As Integer
For i = 0 To pScene.LayerCount - 1
    If pScene.Layer(i).Name = "InterpretationTubes" Then
    Dim pOutLayer As IFeatureLayer
    Set pOutLayer = pScene.Layer(i)
    End If
Next

Dim pFeatClass As IFeatureClass
Set pFeatClass = pOutLayer.FeatureClass

Dim pStandaloneTC As IStandaloneTableCollection
Set pStandaloneTC = pSxDoc.Scene

Dim pStandaloneT As IStandaloneTable
Set pStandaloneT = pStandaloneTC.StandaloneTable(0)

Dim lng_X, lng_Y, lng_Elevation, lng_SubUnits, lng_Top_Depth, lng_Bottom_Depth As Long

      lng_X = pStandaloneT.Table.FindField("X")
      lng_Y = pStandaloneT.Table.FindField("Y")
      lng_Elevation = pStandaloneT.Table.FindField("Elevation")
      lng_SubUnits = pStandaloneT.Table.FindField("SubUnits")
      lng_Top_Depth = pStandaloneT.Table.FindField("Top_Depth")
      lng_Bottom_Depth = pStandaloneT.Table.FindField("Bottom_Depth")
      If (lng_X < 0) Or (lng_Y < 0) Or (lng_Elevation < 0) Or (lng_SubUnits < 0) Or (lng_Top_Depth < 0) Or (lng_Bottom_Depth < 0) Then
        MsgBox "Could not find specified Fields"
        Exit Sub
      End If

Dim pCur As ICursor
Set pCur = pStandaloneT.Table.Search(Nothing, True)

Dim pRow As IRow
Set pRow = pCur.NextRow

Do While Not pRow Is Nothing

    Dim pPointBot As IPoint
    Set pPointBot = New Point

    pPointBot.x = pRow.Value(lng_X)
    pPointBot.y = pRow.Value(lng_Y)
    pPointBot.Z = pRow.Value(lng_Elevation) - pRow.Value(lng_Bottom_Depth)

    Dim pFeature As IFeature
    Set pFeature = pFeatClass.CreateFeature

    Dim pConstCArc As IConstructCircularArc
    Set pConstCArc = New CircularArc

   pConstrCArc.ConstructCircle pPointBot, 5, True    Error run-time 424: Object required

    Dim pSegCol As ISegmentCollection
    Set pSegCol = New Ring
    pSegCol.AddSegment pConstCArc

    Dim pGeoCol As IGeometryCollection
    Set pGeoCol = New Polygon
    pGeoCol.AddGeometry pConstArc

    Set pFeature.Shape = pGeoCol

    Dim pZAware As IZAware
    Set pZAware = pFeature.Shape
    pZAware.ZAware = True

    pFeature.Value(3) = pRow.Value(lng_SubUnits)
    pFeature.Value(4) = pRow.Value(lng_Bottom_Depth) - pRow.Value(lng_Top_Depth)
    pFeature.Store

    Set pRow = pCur.NextRow

    Loop

    pSxDoc.UpdateContents

    pSxDoc.Scene.SceneGraph.Invalidate pOutLayer, True, True
    pSxDoc.Scene.SceneGraph.RefreshViewers

End Sub

MarAlcaraz1 · ‎11-23-2011

And why is this not valid? It returns the same error on this third line...

Dim pIZ As IZ
Set pIZ = pPolygon
pIZ.SetConstantZ pRow.Value(lng_Elevation) - pRow.Value(lng_Bottom_Depth)

NeilClemmons · ‎11-23-2011

Where is this at in your code?

MarAlcaraz1 · ‎11-23-2011

Thanks Neil, I wrote it just above the declaration of pZAware, and it didn't work. I changed it just after pZAware and... IT WORKS!!!! Thank you Neil, I'm so grateful than I even considered send you an iberic ham.

I would like to share the right code with everybody:

Private Sub InterpretationTubes_Click()

Dim pSxDoc As ISxDocument
Set pSxDoc = ThisDocument

Dim pScene As IScene
Set pScene = pSxDoc.Scene

Dim i As Integer
For i = 0 To pScene.LayerCount - 1
If pScene.Layer(i).Name = "InterpretationTubes" Then
Dim pOutLayer As IFeatureLayer
Set pOutLayer = pScene.Layer(i)
End If
Next

Dim pFeatClass As IFeatureClass
Set pFeatClass = pOutLayer.FeatureClass

Dim pStandaloneTC As IStandaloneTableCollection
Set pStandaloneTC = pSxDoc.Scene

Dim pStandaloneT As IStandaloneTable
Set pStandaloneT = pStandaloneTC.StandaloneTable(0)

Dim lng_X, lng_Y, lng_Elevation, lng_SubUnits, lng_Top_Depth, lng_Bottom_Depth As Long

lng_X = pStandaloneT.Table.FindField("X")
lng_Y = pStandaloneT.Table.FindField("Y")
lng_Elevation = pStandaloneT.Table.FindField("Elevation")
lng_SubUnits = pStandaloneT.Table.FindField("SubUnits")
lng_Top_Depth = pStandaloneT.Table.FindField("Top_Depth")
lng_Bottom_Depth = pStandaloneT.Table.FindField("Bottom_Depth")
If (lng_X < 0) Or (lng_Y < 0) Or (lng_Elevation < 0) Or (lng_SubUnits < 0) Or (lng_Top_Depth < 0) Or (lng_Bottom_Depth < 0) Then
MsgBox "Could not find specified Fields"
Exit Sub
End If

Dim pCur As ICursor
Set pCur = pStandaloneT.Table.Search(Nothing, True)

Dim pRow As IRow
Set pRow = pCur.NextRow

Do While Not pRow Is Nothing

Dim pPointBot As IPoint
Set pPointBot = New Point

pPointBot.x = pRow.Value(lng_X)
pPointBot.y = pRow.Value(lng_Y)
pPointBot.Z = pRow.Value(lng_Elevation) - pRow.Value(lng_Bottom_Depth)

Dim pConstrCArc As IConstructCircularArc
Set pConstrCArc = New CircularArc

pConstrCArc.ConstructCircle pPointBot, 10, True

Dim pSegCol As ISegmentCollection
Set pSegCol = New Ring
pSegCol.AddSegment pConstrCArc

Dim pGeoCol As IGeometryCollection
Set pGeoCol = New polygon
pGeoCol.AddGeometry pSegCol

Dim pFeature As IFeature
Set pFeature = pFeatClass.CreateFeature

Dim pPolygon As IPolygon
Set pPolygon = pGeoCol

Dim pZAwarePoly As IZAware
Set pZAwarePoly = pPolygon
pZAwarePoly.ZAware = True

Dim pIZ As IZ
Set pIZ = pPolygon
pIZ.SetConstantZ (pRow.Value(lng_Elevation) - pRow.Value(lng_Bottom_Depth))

Set pFeature.Shape = pPolygon

pFeature.Value(3) = pRow.Value(lng_SubUnits)
pFeature.Value(4) = pRow.Value(lng_Bottom_Depth) - pRow.Value(lng_Top_Depth)
pFeature.Store

Set pRow = pCur.NextRow

Loop

pSxDoc.UpdateContents

pSxDoc.Scene.SceneGraph.Invalidate pOutLayer, True, True
pSxDoc.Scene.SceneGraph.RefreshViewers

End Sub