Egyszerű példák - Belépés

Egyszerű példák:
Aktuális térkép kétszeresre nagyítása
Sub MyZoomIn()
    Dim pDoc As IMxDocument
    Dim pEnv As IEnvelope
    Set pDoc = ThisDocument         ' aktuális dokumentum
    Set pEnv = pDoc.ActiveView.Extent   ' aktuális térkép/layout ablak terjedelme
    pEnv.Expand 0.5, 0.5, True      ' terjedelem felezése
    pDoc.ActiveView.Extent = pEnv   ' térkép terjedelmének módosítása
    pDoc.ActiveView.Refresh         ' ablak frissítése
End Sub

Nagyítás a terjedelemre
Public Sub MyZoomExtent()
' eszköz meghívása
    Dim pItem As ICommandItem
    With ThisDocument.CommandBars
        Set pItem = .Find(arcid.PanZoom_FullExtent)    ' létező parancs kikeresése
        If (pItem Is Nothing) Then Exit Sub
        pItem.Execute
    End With
End Sub

Réteg hozzáadása a projekthez
Public Sub AddLayer()
    Dim pWorkspaceFactory As IWorkspaceFactory
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Dim pWorkSpace As IFeatureWorkspace
    Set pWorkSpace = pWorkspaceFactory.OpenFromFile("C:\...\", 0)    ' a megfelő könyvtár nevét be kell írni
    Dim pClass As IFeatureClass
    Set pClass = pWorkSpace.OpenFeatureClass("....")    ' a megfelelő réteg nevét be kell írni
    Dim pLayer As IFeatureLayer
    Set pLayer = New FeatureLayer
    Set pLayer.FeatureClass = pClass
    pLayer.Name = pClass.AliasName
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
    pMxDoc.AddLayer pLayer
    pMxDoc.ActiveView.PartialRefresh esriViewGeography, pLayer, Nothing
End Sub

Szelektált elemek terület összege
Public Sub SumArea()
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
    Dim pUID As New UID
    pUID = "{E156D7E5-22AF-11D3-9F99-00C04F6BC78E}" 'IGeoFeatureLayer IID
    Dim pEnumLayer As IEnumLayer
    Set pEnumLayer = pMxDoc.FocusMap.Layers(pUID, True)
    pEnumLayer.Reset
    Dim pFeatureLayer As IFeatureLayer
    Dim pFeatureSelection As IFeatureSelection
    Dim pFeatureCursor As IFeatureCursor
    Dim pFeature As IFeature
    Dim pArea As IArea
    Dim dTotalArea As Double
    Set pFeatureLayer = pEnumLayer.Next
    Do Until (pFeatureLayer Is Nothing)
        If (pFeatureLayer.FeatureClass.ShapeType = esriGeometryPolygon) Then
            Set pFeatureSelection = pFeatureLayer
            If (pFeatureSelection.SelectionSet.Count <> 0) Then
                pFeatureSelection.SelectionSet.Search Nothing, True, pFeatureCursor
                Set pFeature = pFeatureCursor.NextFeature
                Do Until (pFeature Is Nothing)
                    Set pArea = pFeature.Shape
                    dTotalArea = dTotalArea + pArea.Area
                    Set pFeature = pFeatureCursor.NextFeature
                Loop
            End If
        End If
        Set pFeatureLayer = pEnumLayer.Next
    Loop
    MsgBox "Total Area for selected polygon features = " & CStr(dTotalArea)
End Sub

Téglalapba eső elemek száma
Új CommandTool létrehozása (Tools/Customize, Categories: [UIControls], New UIControl, UIToolControl)

Majd a Mouse Down esemény  a következő:
Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)
    Dim pMxDoc As IMxDocument
    Set pMxDoc = ThisDocument
    Dim pEnv As IEnvelope
    Dim pRubber As IRubberBand
    Set pRubber = New RubberEnvelope
    Dim pActiveView As IActiveView
    Set pActiveView = pMxDoc.FocusMap
    Set pEnv = pRubber.TrackNew(pActiveView.ScreenDisplay, Nothing)
    Dim pSpatialFilter As ISpatialFilter
    Set pSpatialFilter = New SpatialFilter
    Set pSpatialFilter.Geometry = pEnv
    pSpatialFilter.SpatialRel = esriSpatialRelIntersects
    Dim lPoints As Long, lPolygons As Long, lPolylines As Long
    Dim pLayer As IFeatureLayer
    Dim pFeatureCursor As IFeatureCursor
    Dim pFeature As IFeature
    Dim i As Long
    For i = 0 To pMxDoc.FocusMap.LayerCount - 1
        If (TypeOf pMxDoc.FocusMap.Layer(i) Is IGeoFeatureLayer) Then
            Set pLayer = pMxDoc.FocusMap.Layer(i)
            pSpatialFilter.GeometryField = pLayer.FeatureClass.ShapeFieldName
            Set pFeatureCursor = pLayer.Search(pSpatialFilter, True)
            Set pFeature = pFeatureCursor.NextFeature
            Do Until (pFeature Is Nothing)
                Select Case pFeature.Shape.GeometryType
                    Case esriGeometryPoint
                        lPoints = lPoints + 1
                    Case esriGeometryPolyline
                        lPolylines = lPolylines + 1
                    Case esriGeometryPolygon
                        lPolygons = lPolygons + 1
                End Select
                Set pFeature = pFeatureCursor.NextFeature
            Loop
        End If
    Next i
    MsgBox "Features Found:" & vbCrLf & lPoints & " Points " & vbCrLf & _
        lPolylines & " Polylines " & vbCrLf & lPolygons & " Polygons "
End Sub

Keresés és nagyítás egy attribútum értékre
Public Sub SelectMapFeatures()
'   keresés a telek rétek HRSZ oszlopában
    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    Dim pActiveView As IActiveView
    Dim pFeatureLayer As IFeatureLayer
    Dim pFeatureSelection As IFeatureSelection
    Dim pQueryFilter As IQueryFilter
    Dim hrsz As String
    Dim i As Integer
    Dim j As Integer

    Set pMxDoc = Application.Document
    Set pMap = pMxDoc.FocusMap
    Set pActiveView = pMap

    hrsz = InputBox("Keresett HRSZ:", "HRSZ keresés")
    'Find the layer index
    k = -1
    For i = 0 To pMap.LayerCount - 1
        If UCase$(pMap.Layer(i).Name) = "TELEK" And TypeOf pMap.Layer(i) Is IFeatureLayer Then
            k = i
            Exit For
        End If
    Next
    If k = -1 Then
        MsgBox "Nincs telek réteg"
        Exit Sub
    End If
    Set pFeatureLayer = pMap.Layer(k)
    Set pFeatureSelection = pFeatureLayer ' Query Interface
 
    'Create the query filter
    Set pQueryFilter = New QueryFilter
    pQueryFilter.WhereClause = "HRSZ = '" & hrsz & "'"

    'Invalidate only the selection cache
    'Flag the original selection
    pActiveView.PartialRefresh esriViewGeoSelection, Nothing, Nothing
    'Perform the selection
    pFeatureSelection.SelectFeatures pQueryFilter, esriSelectionResultNew, False
 
    'Get the selected features
    Dim pSelSet As ISelectionSet
    Set pSelSet = pFeatureSelection.SelectionSet
    If pSelSet.Count = 0 Then
        MsgBox "Nincs ilyen HRSZ"
        Exit Sub
    End If
   
    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)
   
    Dim x As Double
    Dim y As Double
    dx = pGeom.Envelope.XMax - pGeom.Envelope.XMin
    dy = pGeom.Envelope.YMax - pGeom.Envelope.YMin
    If dx < 50 Or dy < 50 Then
        Dim env As IEnvelope
        Set env = New esriGeometry.Envelope
        x = (pGeom.Envelope.XMin + pGeom.Envelope.XMax) / 2
        y = (pGeom.Envelope.YMin + pGeom.Envelope.YMax) / 2
        env.PutCoords x - 25, y - 25, x + 25, y + 25
        pActiveView.Extent = env
    Else
        pActiveView.Extent = pGeom.Envelope
    End If
    pActiveView.Refresh
 
End Sub
Utolsó módosítás: 2017. március 9., csütörtök, 19:25