Tester un point dans un polygone VBARésolu

Question

Bonjour à tous, au risque de poser une question qui a déjà été posé pour d'autres langages, j'aimerais savoir si quelqu'un sait comment savoir si un point (en l'occurrence des centaines de points) se trouve à l'intérieur d'un polygone (coordonnées connues). Explication: je suis obligé d'extraire un rectangle de coordonnées et à l'intérieur je n'ai besoin que de certaines coordonnées déterminé par un polygone, le fichier contient des milliers de lignes... J'avais trouvé un début de réponse avec un membre (us_30) mais son poste remonte à 6 ans et je n'arrive pas à faire tourner son code (ci-dessous), si vous avez un peu de temps à me consacrer, merci !! Option Explicit Function Inregion(ByVal MatX As Range, ByVal MatY As Range, ByVal X As Double, ByVal Y As Double) 'Renvoi 1 si (X,Y) se trouve dans la Région fermée défini par MatX et MatY 'Renvoi 0 si extérieur à la région 'Renvoi -1 si sur la frontière 'Tailles matrices Dim L As Long, L2 As Long, C As Long, C2 As Long L = MatX.Rows.Count L2 = MatY.Rows.Count C = MatX.Columns.Count C2 = MatY.Columns.Count 'Erreur de taille If C > 1 Or C2 > 1 Then Inregion = "#COLONNE!": Exit Function If L <> L2 Then Inregion = "#LIGNE!": Exit Function 'Paramètres Dim t As Long, nb As Double, D As Double Dim x1 As Double, x2 As Double, x3 As Double, Y1 As Double, Y2 As Double 'compte le nb de coupure For t = 1 To L - 1 x1 = MatX.Cells(t) Y1 = MatY.Cells(t) x2 = MatX.Cells(t + 1) Y2 = MatY.Cells(t + 1) 'Le point se trouve-t-il sur un segment verticale If ((x1 = x2) And (x1 = X)) And ((Y1 <= Y And Y < Y2) Or (Y1 >= Y And Y > Y2)) Then Inregion = -1 Exit Function End If 'Le point se trouve-t-il entre le segment [(X1,Y1);(X2,Y2)[ ? If (x1 <= X And X < x2) Or (x1 >= X And X > x2) Then 'Calcul distance entre le segment et le point D = Y - Y1 + (Y1 - Y2) * (x1 - X) / (x1 - x2) 'Test distance D If D = 0 Then 'Sur frontière Inregion = -1 Exit Function ElseIf D > 0 Then 'point coupe le segment nb = nb + 1 If X = x1 Then 'a l'aplomb du départ d'un segment x3 = MatX(t - 1) If t = 1 Then x3 = MatX(L) If (x3 < X And x2 < X) Or (x3 > X And x2 > X) Then nb = nb + 1 End If End If End If Next t 'Renvoi vrai (=1) si pair ou faux (=0) si impair Inregion = nb And 1 End Function End Function EDIT: Ajout de la coloration syntaxique.

ucfoutu · Accepted Answer

Bon ...
Partie de pêche terminée (bredouille !!!!)
Je vais me venger ici de ma déconfiture à la pêche :
Dans un module, ce code :
Public Type POINT    x As Long    y As LongEnd TypePublic mon_point As POINTPublic Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As LongPublic Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function PtInRegion Lib "gdi32" (ByVal hrgn As Long, ByVal x As Long, ByVal y As Long) As LongPublic mon_polygone() As POINTPublic Const ALTERNATE = 1Public Const WINDING = 2Public Const BLACKBRUSH = 4Public hrgn As LongPublic Function est_dedans(hrgn As Long, mon_point As POINT) As Boolean If PtInRegion(hrgn, mon_point.x, mon_point.y) > 0 Then est_dedans = TrueEnd Function

Un bouton de commande sur une feuille Excel ou sur un Userform (peu importe) avec ce code :
Private Sub CommandButton1_Click()    Dim nb_pointes As Long, hBrush As Long, ma_region As Long    ' Nous allons ici définir notre polygone par    ' le nombre de ses sommets et leurs coordonnées    nb_pointes = 5    ReDim mon_polygone(1 To nb_pointes) As POINT    mon_polygone(1).x = 452    mon_polygone(1).y = 358    mon_polygone(2).x = 60    mon_polygone(2).y = 27    mon_polygone(3).x = 110    mon_polygone(3).y = 300    mon_polygone(4).x = 257    mon_polygone(4).y = 60    mon_polygone(5).x = 18    mon_polygone(5).y = 180    ' créons maintenant la région de ce polygone    ma_region = CreatePolygonRgn(mon_polygone(1), nb_pointes, WINDING)    '''''''''    'deux petits tests/exemples avec deux points    mon_point.x = 80: mon_point.y = 65    MsgBox "le point de coordonnées " & mon_point.x & "," & mon_point.y & " est-il dedans ? ===>> " & est_dedans(ma_region, mon_point)    mon_point.x = 63: mon_point.y = 141    MsgBox "le point de coordonnées " & mon_point.x & "," & mon_point.y & " est-il dedans ? ===>> " & est_dedans(ma_region, mon_point)    DeleteObject ma_regionEnd Sub
Pour info : voilà l'image du polygone ainsi traité (je l'ai fait bien biscornu, non ?):


Bon ... J'ai un peu bâclé mon code, mais il est sans faille aucune

Précision : 
1) toutes les coordonnées (celles du point à comparer et celles des sommets du polygone) doivent bien évidemment être définies avec la même unité. Que ce soit en pixels, points, ou autres, peu importe, mais toujours la même unité.
2) les coordonnées doivent toutes être relatives au même angle supérieur de référence. Ce peut être par rapport au point 0,0 de la feuille, ou au point 0,0 d'un userform, ou au point 0,0 de l'écran. Cette "référence" doit bien évidemment être la même, tant pour le point à comparer que pour les sommets du polygone.
Je ne sais pas encore ce que tu traites exactement. Si tu dois faire des transpositions d'unités, je t'y aiderai également.
Voilà voilà ===>> ni le moindre calcul, ni la moindre boucle
Bonne nuit

Freuleu · Answer

PS: On parle de coordonnées en 2D (X,Y)

CGSI3 · Answer

Bonjour Freuleu, Pour t aider voici des liens et une fonction écrite en vb.net ( a adapter au vba ) ( Vector2 étant juste une structure similaire au PointF avec X et Y comme attributs ) http://erich.realtimerendering.com/ptinpoly/ http://paulbourke.net/geometry/pointlineplane/ Je pense qu'il faut que la liste de points qui forme l'enveloppe du polygone soit énuméré dans le sens horaire pour que la fonction si dessous fonctionne. '''

''' Indique si un point se situe dans un polygone '''

''' Liste de points (enveloppe) ''' Point a tester Public Shared Function InsidePolygon(ByRef Polygon As List(Of Vector2), ByRef P As Vector2) As Boolean Dim i As Integer, xinters As Double, counter As Integer = 0 Dim p1 As Vector2, p2 As Vector2, n As Integer = Polygon.Count p1 = Polygon(0) For i = 1 To n p2 = Polygon(i Mod n) If P.Y > Min(p1.Y, p2.Y) Then If P.Y <= Max(p1.Y, p2.Y) Then If P.X <= Max(p1.X, p2.X) Then If p1.Y <> p2.Y Then xinters = (P.Y - p1.Y) * (p2.X - p1.X) / (p2.Y - p1.Y) + p1.X If p1.X = p2.X OrElse P.X <= xinters Then counter += 1 End If End If End If End If End If p1 = p2 Next Return (counter Mod 2 <> 0) End Function Je pense ( je ne suis pas sur , ... vieux souvenir ... ) que cette fonction s'appuie sur le sens horaire que possède un point par rapport a un segment. '''

''' Indique si les points A B et C sont disposé en sens Horaire (2D) '''

''' Point[A] ''' Point[B] ''' Point[C] Public Shared Function SensHoraire2DFast(ByRef A As Vector2, ByRef B As Vector2, ByRef C As Vector2) As Boolean Dim SignSurface As Double = A.X * (B.Y - C.Y) + B.X * (C.Y - A.Y) + C.X * (A.Y - B.Y) Return (SignSurface < 0) 'Surface=0 => pts alignés End Function Tu énumère chaque segment et tu test ainsi le sens horaire pour savoir de quel coté se situe le point a tester. De souvenir c'est la façon la plus rapide, tu remarquera qu'il n'y a pas d'appel aux fonctions trigonométriques, et le moins possible de / (divisions) . Indique nous si cela fonctionne. Bonne Prog CGSI3 --

ucfoutu · Answer

Bonjour,
Hé bé !
Une "intromission" dans une première discussion ouverte sous VB.Net et avec une proposition de code sous VBA/Excel à transposer en VB.Net...
et maintenant : une nouvelle discussion ouverte sous VBA/Excel avec une proposition de code sous VB.Net, à transposer en VBA !
Il y a là comme ... comment dirais-je ... un petit "malaise" !

Freuleu · Answer

Ce n'est pas un coup monté je le jure !! ;)

ucfoutu · Answer

Bon,
 Je vous laisse d'abord continuer avec vos différentes méthodes de calcul (elles présentent toutes des inconvénients et des cas particuliers), car vos démarches m'intéressent.
Ce n'est qu'à la fin, que j'interviendrai personnellement à nouveau, SANS LE MOINDRE CALCUL, ni la moindre boucle.
Je ne sais pas à quelle heure j'aurai terminé ma partie de pêche de nuit. Selon l'heure, je m'y mettrai, à ce petit problème, soit cette nuit, soit demain matin.
A plus
 
________________________
Réponse exacte ? => "REPONSE ACCEPTEE" facilitera les recherches.
Pas d'aide en ligne installée ? => ne comptez pas sur moi pour simplement répéter son contenu. Je n'interviend

ucfoutu · Answer

Ah ! Avec Mac ?
C'est foutu, alors ! (VBA/Excel est déjà très "limité" avec Mac, par rapport à Windows.... Et gdi32 est de surcroît une librairie de Windows). Alors ...

Freuleu · Answer

Les coordonnées sont toutes connues, celles du polygone sont les 9000... et les points à tester sont les autres. Une feuille coordonnées sommets dans laquelle je vais choisir le n° des sommets voulus puis une autre feuille avec les coordonnées de points à tester pour savoir s'ils sont dans le polygone.
Le changement principal est dans le fait d'utiliser des listes de coordonnées établies sans taper les coordonnées dans le code afin de ne pas avoir besoin de toucher au code à chaque usage. Je peux sûrement trouver dans le forum comment faire cela mais comment ou à quel niveau je l'intègre dans ton code...?

Whismeril · Answer

Bonjour, ce que tu décris (MNT, interception de polygone, de sommets, etc..) sont des outils de logiels appelés Système d'Information Géographique.
Il en existe des gratuits.

De plus cela nécessite des notions de géodésie, et quand tu écris Coordonnées Géographiques (latitude entre -90° et 90°, longitudes entre 0 et 360° ou -180° 180°) et que tu donnes comme exemple 25 2497656.25 1114589.25, je pense qu'il t'en manque un peu.

Peut etre devrait tu regarder par là avant de réinventer l'Amérique.

ucfoutu · Answer

Je ne peux que te répéter ce que je t'ai déjà dit :
La détermination des coordonnées des sommets est une autre question (et donc une autre discussion, totalement distincte de la première).
Il te faut bien comprendre que nous ne traitons pas ton application, mais, dans une discussion : une seule des difficultés que tu rencontres dans le cours de ton développement. Cette difficulté doit être spécifique et parfaitement ISOLEE.
L' "assemblage", ensuite, des solutions trouvées pour résoudre tel point (soulevé dans telle discussion), puis tel autre point (soulevé dans telle autre discussion) , t'appartient totalement.

ucfoutu · Answer

Bon ...
J'ai promis quelque-chose par mon message de à 18:35 :
Pour mémoire :
Non : je ne vois pas la télévision en code. Pour une simple raison : je ne la regarde pas du tout (MDR).
Allez, si tu aimes les images, je vais faire en sorte de mettre mon code en image/démo. Cela va être un peu plus dur du fait que ni Excel, ni VBA, n'offrent nativement pas de quoi dessiner, d'une part, et que, d'autre part, pour ce faire je ne vais pas échapper à des transpositions d'unité.
Mais je vais y arriver, tu vas voir ... (après ma partie de pêche, en espérant ne pas revenir encore bredouille ce soir...). Et cela te donnera probablement quelques idées supplémentaires (va savoir ..)
Comme j'ai eu plus haut l'occasion de l'exposer,  peu importent les unités des valeurs, pourvu qu'elles soient les mêmes. Ce qui ne pose donc aucun problème lorsque l'on  ne travaille qu'avec des valeurs (les 2 fonctions utilisées de l'Api de Windows travailleront sur des valeurs de pixels, tant en ce qui concerne les coordonnées des sommets que celles du point à traiter)
Si l'on veut par contre "imager" la chose, une transposition d'unités s'impose. Dans la demo qui va suivre, le curseur que nous allons déplacer a, lui, ses coordonnées en points (VBA !). Il va falloir transformer ces coordonnées en pixels (pour comparer des carottes avec des carottes) puisque l'on veut "visualiser graphiquement".
le coefficient k de correction (transposition de 1  point en pixels) a été ici défini à 1,333333. Je n'ai pas voulu encombrer plus encore avec le calcul précis de ce coefficient. J'ai montré comment faire très précisément cette transposition dans le source que j'ai déposé ici ===>>
http://codes-sources.commentcamarche.net/source/54196-dimensions-graphiques-vba-equivalents-de-scalex-scaley-twipsperpixelx-twipsperpixely-textwidth-et-textheight-de-vb6
1,333333 correspond à la plus grande majorité des machines (15 twips par pixel horizontalement et 15 twips par pixel verticalement). Nous allons donc utiliser 1,333333 ici (vous ne ferez le calcul exact (mon lien/source) que si très exceptionnellement nécessaire)
A partir de là, on a le choix, soit de transformer en points le coordonnées des sommets, soit de transformer en pixels celles du point à examiner.  J'ai choisi de transposer les coordonnées du point.
On y va :
sur un userform : un label nommé label1
ce code :
Private Type COORD    X As Long    Y As LongEnd TypePrivate Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As LongPrivate Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As Any, ByVal nCount As Long) As LongPrivate Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hrgn As Long, ByVal hBrush As Long) As LongPrivate Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function PtInRegion Lib "gdi32" (ByVal hrgn As Long, ByVal X As Long, ByVal Y As Long) As LongPrivate Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongConst ALTERNATE = 1Const WINDING = 2Const BLACKBRUSH = 4Private monhwnd As Long, monhdc As Long, hrgn As Long, numcoords As IntegerPrivate poly() As COORDPrivate Sub UserForm_Activate()    ' aucun importance (juuste pour disposer plus agréablement |    Me.Width = 400 '                                           |    Me.Height = 200 '                                          |    Label1.Move 300, 50, 20, 20 '                              |    Label1.Caption = "" '                                      |    Label1.BackColor = 0 '                                     |    '----------------------------------------------------------        'Pour dessiner sur le userform, j'ai besoin de son hdc    ' pour avoir ce hdc, j'ai besoin du hwnd de ce userform    ' et donc        monhwnd = FindWindow(vbNullString, Me.Caption)    monhdc = GetDC(monhwnd)        numcoords = 6    ReDim poly(1 To numcoords)    poly(1).X = 20    poly(1).Y = 30    poly(2).X = 60    poly(2).Y = 47    poly(3).X = 100    poly(3).Y = 50    poly(4).X = 150    poly(4).Y = 80    poly(5).X = 160    poly(5).Y = 40    poly(6).X = 170    poly(6).Y = 20    DoEvents        hrgn = CreatePolygonRgn(poly(1), numcoords, 1)        ' voilà ce qui v a maintenant dessiner le polygone sur le userform    hBrush = GetStockObject(BLACKBRUSH)    Polygon monhdc, poly(1), numcoords 'End SubPrivate Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)   Label1.BackColor = PtInRegion(hrgn, X * 1.333333, Y * 1.333333) * vbRedEnd Sub

Promenez maintenant le curseur sur le userform. Observer comment varie la couleur du label selon que le curseur est dans le polygone ou à l'extérieur.
"zouli", non ?
Oublions maintenant la représentation, graphique en inhibant(en les mettant en commentaires) les deux lignes de code :
 hBrush = GetStockObject(BLACKBRUSH)  Polygon monhdc, poly(1), numcoords 
Et refaisons l'expérience ==>> graphique présent ou pas, le résultat est bien entendu le même (mais sans "constat visuel", tout simplement) 
Bonne nuit
________________________

Nul ne saurait valablement coder ce qu'il ne saurait exposer clairement.

Tester un point dans un polygone VBA

11 réponses

Votre réponse

Discussions similaires