Калькулятор посмотрел, да, много чего сделано! но поздно посмотрел...
Вот мое первое приближение:
Option Explicit
Private Sub UIButtonControl1_Click()
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, pFT2 As IFeature
Dim pArea As IArea, pCurve As ICurve
Dim dTotalArea As Double, dTotLen As Double
Set pFeatureLayer = pEnumLayer.Next
Do Until (pFeatureLayer Is Nothing)
If (pFeatureLayer.FeatureClass.ShapeType = esriGeometryPolygon Or pFeatureLayer.FeatureClass.ShapeType = esriGeometryPolyline) 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)
If TypeOf pFeature.Shape.SpatialReference Is IGeographicCoordinateSystem Then
If (pFeatureLayer.FeatureClass.ShapeType = esriGeometryPolygon) Then
Set pArea = FeatureProj(pFeature)
dTotalArea = dTotalArea + pArea.Area
End If
If (pFeatureLayer.FeatureClass.ShapeType = esriGeometryPolyline) Then
Set pCurve = FeatureProj(pFeature)
dTotLen = dTotLen + pCurve.Length
End If
End If
Set pFeature = pFeatureCursor.NextFeature
Loop
End If
End If
Set pFeatureLayer = pEnumLayer.Next
Loop
MsgBox "Общая длина, М = " & CStr(dTotLen) & vbCrLf & "Общая площадь, м2 = " & CStr(dTotalArea)
End Sub
Function FeatureProj(pFeat As IFeature) As IGeometry
Dim pSpatialReferenceEnv As SpatialReferenceEnvironment
Set pSpatialReferenceEnv = New SpatialReferenceEnvironment
Dim pFromSR As ISpatialReference
Set pFromSR = pSpatialReferenceEnv.CreateGeographicCoordinateSystem(esriSRGeoCS_WGS1984)
Dim pToSR As ISpatialReference
'Set pToSR = pSpatialReferenceEnv.CreateProjectedCoordinateSystem(esriSRProjCS_WGS1984UTM_42N)
Set pToSR = pSpatialReferenceEnv.CreateProjectedCoordinateSystem(GetPCS(pFeat.Shape.Envelope))
Dim pGeo As IGeometry
Set pGeo = pFeat.ShapeCopy
pGeo.Project pToSR
Set FeatureProj = pGeo
End Function
Function GetPCS(env As IEnvelope) As Long
Dim pp As IPoint, ar As IArea
Set ar = env
Set pp = ar.Centroid
Dim d As Double, ai As Long, rl As Long
' 32600 - esriSRProjCS_WGS1984UTM N
' 32700 - esriSRProjCS_WGS1984UTM S
d = pp.X / 6
ai = Round(d)
rl = ai + IIf(pp.Y > 0, 32600, 32700) + 30
GetPCS = rl
End Function
есть ошибка миллиметровая, не пойму почему!?