Le portail francophone de la géomatique

MapX ne sait que calculer des surfaces sphériques (méthode area).  Pour
calculer une surface carthésienne, il faut écrire soi-même le code, mais
ce n'est pas très compliqué (Cf les posts sur ce sujet d'il y a qq semaines)

Michel Wurtz
MAP/SG/SM/SDSI/CERIT/DIG

Martin,

C'est pas évident de calculer la surface d'un feature. le feature est composé d'iles et de trou. Ci-dessous un ensemble de fonctions qui font le job. C'est pas simple car je n'ai pas trouvé de méthode qui pouvait déterminer si un n-ième polygone constituant un feature est ile ou trou.

la seule façon que j'ai trouvé est de calculer le nombre de fois que le n-ièmeploygone est à l'intérieur des autres poolygones. Si le nombre est impair c'est une ile (ajoputer la surface). Si le nombre est pair c'est un trou. Il faut alors retirer la surface au total.

Si quelqu'un a plus simple, merci de le partager et le signaler par un post. Je laisse le code ci-dessous car j'aurais aimé le trouver sur le net... ca peut toujours servir à la communauté.


Bon courage ;-)
Olivier Guénard

**************************************************************************
Private Sub Command1_Click()
    'Ce sub est provoqué par un clic sur button1
    'Appel de la fonction de calcul de surface cartésienne
    '---------------------------------------------------------------
    Dim l As MapXLib.Layer  'layer
    Dim f As MapXLib.Feature 'feature lu

    'Chargement du layer de test
    Map1.Layers.RemoveAll
    Set l = Map1.Layers.Add(App.Path & "\a.tab")
   
       
    'Utilisation du système de coordonnées du layer (influe la lecture de xy)
    Map1.AreaUnit = miUnitSquareMeter
    Map1.DisplayCoordSys = l.CoordSys
    Map1.NumericCoordSys = l.CoordSys
   
       
    Dim m%, a#
    'Pour chaque feature...
    For m = 1 To l.AllFeatures.Count
        Set f = l.AllFeatures.Item(m) 'lecture du feature
        If f.Type = miFeatureTypeRegion Then
       
            a = f.Area  'Toujours SPHERIQUE!!!!
            Text1.Text = Text1.Text & vbCrLf & "Objet " & m & " Surface Shérique=" & a & "m²"
       
            a = MeasureCartesian(f)
            Text1.Text = Text1.Text & vbCrLf & "Objet " & m & " Surface cartésienne=" & a & "m²"
   
           
        End If
        Set f = Nothing 'libération de l'objet
    Next
   
   
   
End Sub



Function MeasureCartesian(Fea As MapXLib.Feature, Optional iserr As Boolean, Optional erreur As String) As Double

   'Calcul de la surface cartésienne d'un feature
   'auteur : o. guenard

    Dim retour As Double, nbpp%, kk, k, m, inside As Boolean, xx#, yy#, s#
    Dim x() As Double, y() As Double, stot As Double
    Dim pts As MapXLib.Points
    Dim insid() As Integer 'tableau comptant le nombre de fois que l'objet est à l'intérieur d'un autre
    Dim f1 As MapXLib.Feature
    Dim f2 As MapXLib.Feature
   
    stot = 0 'surface retournée...
    iserr = False 'vision optimiste...
    On Error GoTo errsurf  'erreur si par exemple calcul d'une surface de ligne ....
   
    '....................................................................
    'Phase 1 : on compte pour chaque polygone de l'objet le nombre de fois
    'que celui-ci est à l'intérieur d'un autre polygone. Dans le cas d'un
    'trou, le nombre sere impair, dans le cas d'une ile, le nombre
    'sera impair...
    '....................................................................
    ReDim insid(Fea.Parts.Count)  'nombre de calcul égale nombre de polygones
    For m = 1 To Fea.Parts.Count
        Set f1 = Map1.FeatureFactory.CreateRegion(Fea.Parts(m))  'n-ième polygone
        For kk = 1 To Fea.Parts.Count
            If kk <> m Then 'inutile de tester unobjetsur lui-même
                Set f2 = Map1.FeatureFactory.CreateRegion(Fea.Parts(kk)) 'kk-ième polygone
                If Map1.FeatureFactory.IntersectionTest(f2, f1, miIntersectEntirelyWithinFeature) Then
                    'f2 dans f1
                    Debug.Print "poly " & m & " dans poly " & kk
                    insid(kk) = insid(kk) + 1 '+1 car à l'intérieur d'un autre plogone...
                End If
           
            End If
        Next
    Next
    Set f1 = Nothing
    Set f2 = Nothing
    '..............................................................................
    'Phase 2 : calcul de chaque surface de polygone et ajout ou retrait à la
    'surface de retour suivant la parité d'inclusion....
    '..............................................................................
    Dim addsurftag As Integer
    stot = 0
    For m = 1 To Fea.Parts.Count
            'Pour chaque polygone de l'objet
            nbpp = Fea.Parts.Item(m).Count
           
            ReDim x(nbpp + 1), y(nbpp + 1)
            Set pts = Fea.Parts.Item(m)
           
            'addsurftag vaut 1 si ile (ajouter la surface) ou -1 si un trou (retirer la surface)
            If insid(m) Mod 2 = 0 Then addsurftag = 1 Else addsurftag = -1
           
            'Calcul de la surface (méthode des trapèzes)
            For k = 1 To nbpp
                Call pts.GetXY(k, xx, yy)
                x(k) = xx
                y(k) = yy
            Next
            x(nbpp + 1) = x(1)
            y(nbpp + 1) = y(1)
            Set pts = Nothing
           
            s = Calcsurf(nbpp + 1, x(), y(), iserr, erreur)
            If iserr Then
                Exit For
            End If
            stot = stot + s * addsurftag   'cumul de la surface = somme(iles)-sommes(trous)
    Next

final:
    On Error GoTo 0
    MeasureCartesian = stot 'retour de la surface
    Exit Function
errsurf:
    'Gestion des erreurs -
    erreur = "Erreur pendant calcul de surface cartésienne" & vbCrLf & Err & ":" & Error$
    iserr = False
    Resume final
   
End Function

Private Function Calcsurf(nb As Integer, x() As Double, y() As Double, Optional iserreur, Optional erreur$) As Double
    'Calcul de la surface d'un polygone
    Dim m As Integer, s As Double
    iserreur = False
    s = 0
    On Error GoTo ErrCalcSurf
    For m = 1 To nb - 1
        s = s + (x(m + 1) - x(m)) * (y(m + 1) + y(m))
    Next
    s = Abs(s / 2)
finErrCalcSurf:
    Calcsurf = s
    On Error GoTo 0
    Exit Function
   
ErrCalcSurf:
    erreur = "Erreur pendant calcul de surface d'un polygone" & vbCrLf & Err & ":" & Error$
    iserreur = True
    Resume finErrCalcSurf
End Function