lawrenceh

Moulding two VBA Modules

Discussion created by lawrenceh on Jun 25, 2010
Hi

I am trying to mould two VBA software modules together. Both have been writing by other people. Module 1 works well. It scans through all the layers and when it finds a field, in the case FID, and returns its value.

Module 2 returns with co-ordinates of a shape in a layer.

I am trying to get the co-ordinates of a shape from Module 2 to be returned in Module 1 but I can???t change Module 2 to work within Module 1.

Can anyone help me with this?

Thanks in advance,

Lawrence



'======================================================
'Module 1
'======================================================

Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)
    Dim pMxDoc As IMxDocument
    Dim pActiveView As IActiveView
    Dim pPoint As IPoint
    Dim pFeature As IFeature
    Set pMxDoc = thisdocument
    Set pActiveView = pMxDoc.FocusMap
    'Create a search point
    Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
    'Pass the point to the FindFeature function along with the Map and search tolerance
    Set pFeature = FindFeature(pMxDoc.SearchTolerance, pPoint, pMxDoc.FocusMap)
    'Message box the feature ID and feature class alias name
   
   
    If Not pFeature Is Nothing Then

    MsgBox pFeature.Value(pFeature.Fields.FindField("FID"))
    MsgBox ---the coordinates from Module 2---
   
    End If
   
    Set pFeature = Nothing
    Set pPoint = Nothing
    Set pActiveView = Nothing
    Set pMxDoc = Nothing
End Sub

Private Function FindFeature(SearchTol As Double, pPoint As IPoint, pMap As IMap) As IFeature
   
    Dim pEnvelope As IEnvelope
    Dim pSpatialFilter As ISpatialFilter
    Dim pEnumLayer As IEnumLayer
    Dim pFeatureLayer As IFeatureLayer
    Dim pFeatureClass As IFeatureClass
    Dim pFeatureCursor As IFeatureCursor
    Dim pFeature As IFeature
    Dim ShapeFieldName As String
    Dim pLayer As ILayer
   
    If pMap.LayerCount = 0 Then Exit Function
   
    'Expand the points envelope to give better search results
    Set pEnvelope = pPoint.Envelope
    pEnvelope.Expand SearchTol, SearchTol, False
   
    'Create a new spatial filter and use the new envelope as the geometry
    Set pSpatialFilter = New SpatialFilter
    Set pSpatialFilter.Geometry = pEnvelope
    pSpatialFilter.SpatialRel = esriSpatialRelIntersects
   
    'Search each selectable feature layer for a feature
    'Return the first feature found
    Set pEnumLayer = pMap.Layers
    pEnumLayer.Reset

    Do While Not pLayer Is Nothing
    'Only search the selectable layers
        If TypeOf pLayer Is FeatureLayer Then
            Set pFeatureLayer = pLayer
              If pFeatureLayer.Selectable Then
                ShapeFieldName = pFeatureLayer.FeatureClass.ShapeFieldName
                Set pSpatialFilter.OutputSpatialReference(ShapeFieldName) = pMap.SpatialReference
                pSpatialFilter.GeometryField = pFeatureLayer.FeatureClass.ShapeFieldName
                Set pFeatureClass = pFeatureLayer.FeatureClass
                Set pFeatureCursor = pFeatureClass.Search(pSpatialFilter, False)  'Do the search
                Set pFeature = pFeatureCursor.NextFeature  'Get the first feature
                If Not pFeature Is Nothing Then
                    If Not pFeature.Fields.FindField("Name") = -1 Then
                        strName = pFeature.Value(pFeature.Fields.FindField("Name"))
                    End If
                    Set FindFeature = pFeature  'Exit if feature is valid
                    Exit Do
                End If
            End If
        End If
        Set pLayer = pEnumLayer.Next
    Loop
   
    Set pLayer = Nothing
    Set pEnvelope = Nothing
    Set pFeatureLayer = Nothing
    Set pSpatialFilter = Nothing
    Set pFeatureCursor = Nothing
    Set pFeatureClass = Nothing
    ShapeFieldName = ""
    Set pMap = Nothing
    Set pEnumLayer = Nothing
End Function

'======================================================
'Module 2
'======================================================

  Dim pWF As IWorkspaceFactory
    Set pWF = New ShapefileWorkspaceFactory
   
    Dim pWs As IFeatureWorkspace
    Set pWs = pWF.OpenFromFile("c:\layer", 0)

    Dim pInputFc As IFeatureClass
    Set pInputFc = pWs.OpenFeatureClass("fault")
   
    Dim pFeatureClass As IFeatureClass
    Dim pFeatureCursor As IFeatureCursor
    Dim pFeature As IFeature
    Dim pPolyline As IPolyline
    Dim startpointX, startpointY, endpointX, endpointY As Double
    Dim newpoint As IPoint
   
    Set pPolyline = New Polyline
    Set newpoint = New Point
    Set pFeatureClass = pInputFc
    Set pFeatureCursor = pFeatureClass.Search(Nothing, False)
    Set pFeature = pFeatureCursor.NextFeature
    Set pPolyline = pFeature.Shape
   
    startpointX = pPolyline.FromPoint.x
    startpointY = pPolyline.FromPoint.y
   
    pPolyline.QueryPoint esriExtendTangentAtFrom, 0.01, True, newpoint

Outcomes