pickerm

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

Discussion created by pickerm on May 27, 2010
Latest reply on May 28, 2010 by gamnsig
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

Outcomes