Trying to work out bugs in VBA code for Xacto Section tools

BarryGuidry — Sat, 11 Dec 2021 18:58:01 GMT

I am getting a vba error when running the Xacto Section tutorial. Error is when prompted to add the new view frame (below; line 9 that an object is required). Have no idea what the "arcid.pagelayout_newmap" is doing here, but cannot figure out what to change it to work. From what I understand this should be pointing to the toolbar.

Private Sub cmdYes_Click()
    
  'add a new data frame

    Dim pCommandBars As ICommandBars
    Set pCommandBars = ThisDocument.CommandBars

    Dim pCommandItem As ICommandItem
    Set pCommandItem = pCommandBars.Find(arcID.pagelayout_newmap)

    pCommandItem.Execute
    
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
    
    Dim pMap As IMap
    Set pMap = pMxDoc.FocusMap
    pMap.Name = Form1.txtXsecName & " Profile"
    
    Dim pLayer As ILayer
    Dim pFLayer As IFeatureLayer
    
    'open the workspace where the new shapefiles are located
    Dim pWorkspaceFactory As IWorkspaceFactory
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Dim pWorkspace As IWorkspace
    Set pWorkspace = pWorkspaceFactory.OpenFromFile(Form1.txtWorkspace.value, 0)
    Dim pFeatureWS As IFeatureWorkspace
    Set pFeatureWS = pWorkspace
    
    'make a list of the shapefiles to be added
    Dim XsecName As String
    XsecName = Form1.txtXsecName.value

    Dim colNewShapes As Collection
    Set colNewShapes = New Collection
    
    If Form1.cbGrid.value = True Then
        colNewShapes.Add XsecName & "_GridLine"
    End If
    
    If Form1.ListBox1.ListCount >= 1 Then
        For h = 0 To Form1.ListBox1.ListCount - 1
            colNewShapes.Add XsecName & "_" & Form1.ListBox1.List(h, 1)
        Next h
    End If
    
    If Form1.cbProfile = True Then
        colNewShapes.Add XsecName & "_profile"
    End If
    
    If Form1.cbDepthData.value = True And QuitWellln = False Then
        colNewShapes.Add XsecName & "_wellln"
    End If

    If Form1.cbWells.value = True And QuitPts = False Then
        If frmPoints.cbExtrude = True Then
            colNewShapes.Add XsecName & "_depths"
        End If
        If Form1.cbGeoPhys.value = True Then
            colNewShapes.Add XsecName & "_geophys"
        End If
        colNewShapes.Add XsecName & "_wellpt"
        

    End If
    
    If Form1.cbGeoContacts = True Then        'add the shapefile to the map
        colNewShapes.Add XsecName & "_geopts"
    End If
    
    Dim pFClass1000 As IFeatureClass
    
    For i = 1 To colNewShapes.Count
        Set pFClass1000 = pFeatureWS.OpenFeatureClass(colNewShapes.Item(i))
        Set pFLayer = New FeatureLayer
        Set pFLayer.FeatureClass = pFClass1000
        Set pLayer = pFLayer
        pLayer.Name = pFClass1000.AliasName
        pMap.AddLayer pLayer
    Next i
    

    Dim j As Integer
    For i = 1 To pMap.LayerCount
        Set pLayer = pMap.Layer(i - 1)
        j = i - 1
        If pLayer.Name = Form1.txtXsecName.value & "_profile" Then
            If Form1.cbGeoContacts.value = True Then
                Call Module1.Render("Abbrev", j)
                Call frmDataFrame.LabelLines(pLayer.Name, "[Abbrev]", 0, 6)
            End If
        ElseIf pLayer.Name = Form1.txtXsecName.value & "_wellln" Then
            Call Module1.Render("Geo", j)
            Call frmDataFrame.LabelLines(pLayer.Name, "[Geo]", 7, 0)
        
        ElseIf pLayer.Name = Form1.txtXsecName.value & "_geopts" Then
            Call frmDataFrame.RenderPoints("Diamond 1", j)
            
        ElseIf pLayer.Name = Form1.txtXsecName.value & "_wellpt" Then
            Call frmDataFrame.RenderPoints("Cross 1", j)
            Call frmDataFrame.RotateField
            Call frmDataFrame.LabelWells
        End If
    Next i

    frmDataFrame.Hide
End Sub

Re: Trying to work out bugs in VBA code for Xacto Section tools

DavidPetrey1 — Wed, 09 Jan 2013 06:23:05 GMT

The code adds a new Data Frame to ArcMap. It works fine on my PC. It may be worth doing this process manually before clicking the 'Yes' button, then remove this code and starting from the line of code 'Dim pMxDoc As IMxDocument' instead.

David
simplyGIS Ltd. Making GIS simple.
www.simplygis.co.uk/GISTraining.html

topic Re: Trying to work out bugs in VBA code for Xacto Section tools in 3D Questions

Trying to work out bugs in VBA code for Xacto Section tools

Re: Trying to work out bugs in VBA code for Xacto Section tools