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
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