Zoom to extent of layer and expand by a factor - VBA

MarlainaPickering

Hi there,

I have created a User Form in VBA which has three combo boxes. The first combo box allows the user to select a layer from the Table of Contents. The second combo box reads the fields within the layer and the user is able to specify the field they would like. And the third combo box lists a unique list of records in the layer selected.

The user is then able to press a command button which applies a definition query which is based on the three combo boxes mentioned above and zooms to the extent of the features that meet the layers definition plus expanding the zoom in factor a bit so you are able to see what is around the layer.

The main issue I am having is the expansion factor isn't quite right. It seems when I press the run command button it executes the definition query fine, but if there are a large number of points it zooms out far too much and if there are only a few points it zooms right in to the points and doesn't apply the expansion factor.

Ideally I would like it to apply the definition query to the layer of interest and zoom into this layer expanding the zoom factor by say 20% (for instance) so the user can see the surrounding map features.

Please see my code below.

Private Sub cmdRun_Click()
      'Sets the definition query specified by the user
        'Zoom to the features that meet the layer definition, features are not selected, just 'defined' in the layer
    Dim pLayer As IDisplayTable
    Dim pFLayerDefinition As IFeatureLayerDefinition
    Set pDoc = ThisDocument
    Set pLayer = pDoc.FocusMap.Layer(Me.cbo1.ListIndex)
    Dim stringA As String
    stringA = UserForm1.cbo2.value + "= '" + UserForm1.cbo3.value + "'"
    Set pFLayerDefinition = pLayer
    pFLayerDefinition.DefinitionExpression = stringA
    Dim pFCur As IFeatureCursor
    Set pFCur = pLayer.SearchDisplayTable(Nothing, False)
    Dim pEnv As IEnvelope
    Dim pFeat As IFeature
    Set pFeat = pFCur.NextFeature
    Do While Not pFeat Is Nothing
        If pEnv Is Nothing Then
            Set pEnv = New Envelope
            Set pEnv = pFeat.Shape.Envelope
            pEnv.Expand 1.04, 1.04, True
        Else
            pEnv.Union pFeat.Shape.Envelope
            pEnv.Expand 1.04, 1.04, True
        End If
        Set pFeat = pFCur.NextFeature
    Loop
    If Not pEnv Is Nothing Then
        pDoc.ActivatedView.Extent = pEnv
        pDoc.ActivatedView.Refresh
    End If
End Sub

Any suggestions on how I can fix this issue would be greatly appreciated!! Please note I am very new to VBA so my code probaly isn't the best.

Thanks so much

m

maxsteinbrenner

I think the problem you may be running into is trying to zoom in on only a part of a layer with a definition query.

The way i have found to zoom to a selected set is to actually do the selection, then zoom to the selected features, then (if necessary) clear the selection so you don't see the features highlighted.

here is some code i have used in the past:

            Dim pMxDoc As IMxDocument
            Set pMxDoc = ThisDocument

            Dim pMap As IMap
            Set pMap = pMxDoc.FocusMap
        
            Dim pLayout As IPageLayout
            Set pLayout = pMxDoc.PageLayout
            
            Dim pActiveView As IActiveView
            Set pActiveView = pMap
            
        'Query for selecting points in zipcode point layer
            Dim strQuery As String
            strQuery = "ZIP" & " = " & value
            
       
        'Set pLayer to PMBC point Layer
            Dim pLayer As IFeatureSelection
            Set pLayer = pMap.Layer(0)

        'Selects points in Selected Zip and turns them Blue
            Dim pFilter As IQueryFilter
            Set pFilter = New QueryFilter

            pFilter.WhereClause = strQuery

            pLayer.SelectFeatures pFilter, esriSelectionResultNew, False

            Dim pBlueColor As IRgbColor
            Set pBlueColor = New RgbColor
            pBlueColor.RGB = RGB(0, 112, 225)

            Set pLayer.SelectionColor = pBlueColor

        'Sets zoom level to selected features of PMBC points
            Dim pLayer3 As IFeatureLayer
            Set pLayer3 = pMap.Layer(0)

            Set pFSel = pLayer3

            Dim pSelSet As ISelectionSet
            Set pSelSet = pFSel.SelectionSet

            Dim pEnumGeom As IEnumGeometry
            Dim pEnumGeomBind As IEnumGeometryBind

            Set pEnumGeom = New EnumFeatureGeometry
            Set pEnumGeomBind = pEnumGeom
            pEnumGeomBind.BindGeometrySource Nothing, pSelSet

            Dim pGeomFactory As IGeometryFactory
            Set pGeomFactory = New GeometryEnvironment

            Dim pGeom As IGeometry
            Set pGeom = pGeomFactory.CreateGeometryFromEnumerator(pEnumGeom)

        'Makes an envelope for selected features to determine proper page layout orientation
            Dim pEnvelope As IEnvelope

            If pFSel.SelectionSet.Count = 1 Then


                Set pEnvelope = pGeom.Envelope

                pEnvelope.XMax = pEnvelope.XMax + 500
                pEnvelope.XMin = pEnvelope.XMin - 500
                pEnvelope.YMax = pEnvelope.YMax + 500
                pEnvelope.YMin = pEnvelope.YMin - 500

            Else
                Set pEnvelope = pGeom.Envelope
                pEnvelope.Expand 1.05, 1.05, True

            End If

                Set pMxDoc.ActiveView = pMap
                pMxDoc.ActiveView.Extent = pEnvelope

        'Determine the envelope ratio (for setting layout)
            Dim intEnvelopeHeight As Integer
            intEnvelopeHeight = pEnvelope.YMax - pEnvelope.YMin

            Dim intEnvelopeWidth As Integer
            intEnvelopeWidth = pEnvelope.XMax - pEnvelope.XMin

                If intEnvelopeHeight > intEnvelopeWidth Then
                    strLayoutType = "Portrait"

                ElseIf intEnvelopeHeight < intEnvelopeWidth Then
                    strLayoutType = "Landscape"

                Else
                    strLayoutType = "Portrait"

                End If

obviously it will need to be modified to work and contains some extra things you don't probably need but it should give you some ideas hopefully, let me know if you have questions.

good luck,

max