Quelqu'un a-t'il déjà codé le problème suivant :
J'ai une ligne à l'écran définie pas des segments de droites (suffisamment
rapprochés pour donner l'illusion d'une courbe).
Je veux écrire un texte qui suive une partie de cette courbe.
Cerise sur le gâteau, je souhaite pouvoir sélectionner ce texte et le
déplacer le long de la courbe.
Si quelqu'un a une idée pas trop lourde ?
Quelqu'un a-t'il déjà codé le problème suivant :
J'ai une ligne à l'écran définie pas des segments de droites (suffisamment
rapprochés pour donner l'illusion d'une courbe).
Je veux écrire un texte qui suive une partie de cette courbe.
Cerise sur le gâteau, je souhaite pouvoir sélectionner ce texte et le
déplacer le long de la courbe.
Si quelqu'un a une idée pas trop lourde ?
Quelqu'un a-t'il déjà codé le problème suivant :
J'ai une ligne à l'écran définie pas des segments de droites (suffisamment
rapprochés pour donner l'illusion d'une courbe).
Je veux écrire un texte qui suive une partie de cette courbe.
Cerise sur le gâteau, je souhaite pouvoir sélectionner ce texte et le
déplacer le long de la courbe.
Si quelqu'un a une idée pas trop lourde ?
Re,
En fait, un petit calcul de projection orthogonale du
point sur les segments devrait aider à coller mieux encore
à la courbe.
Voici un petit programme que j'avais fait avec les sources:
http://membres.lycos.fr/jeanmarcn/projorth/projorth.htm
Ceci, plus le code du post précédent, doit mener rapidement
à une jolie solution, pas trop couteuse ni trop compliquée.
--
Jean-marc
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ;
Re,
En fait, un petit calcul de projection orthogonale du
point sur les segments devrait aider à coller mieux encore
à la courbe.
Voici un petit programme que j'avais fait avec les sources:
http://membres.lycos.fr/jeanmarcn/projorth/projorth.htm
Ceci, plus le code du post précédent, doit mener rapidement
à une jolie solution, pas trop couteuse ni trop compliquée.
--
Jean-marc
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ; _no_spam_jean_marc_n2@yahoo.fr
Re,
En fait, un petit calcul de projection orthogonale du
point sur les segments devrait aider à coller mieux encore
à la courbe.
Voici un petit programme que j'avais fait avec les sources:
http://membres.lycos.fr/jeanmarcn/projorth/projorth.htm
Ceci, plus le code du post précédent, doit mener rapidement
à une jolie solution, pas trop couteuse ni trop compliquée.
--
Jean-marc
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ;
"Jean-Marc" a écrit dans le message de
42fd05d1$0$333$
> Re,
>
> En fait, un petit calcul de projection orthogonale du
> point sur les segments devrait aider à coller mieux encore
> à la courbe.
>
> Voici un petit programme que j'avais fait avec les sources:
> http://membres.lycos.fr/jeanmarcn/projorth/projorth.htm
>
> Ceci, plus le code du post précédent, doit mener rapidement
> à une jolie solution, pas trop couteuse ni trop compliquée.
>
> --
Merci beaucoup, je vais me mettre là dessus ce week-end ou alors dans deux
semaines.
Pour les formules mathématiques, pas de problème, les maths c'est ma
(et puis une agrégation dans le domaine permet d'assurer quelques
connaissances en la matière).
Je te tiens au courant.
(Question : au niveau temps d'exécution, ce n'est pas trop long ?)
"Jean-Marc" <NO_SPAM_jean_marc_n2@yahoo.fr> a écrit dans le message de
42fd05d1$0$333$ba620e4c@news.skynet.be...
> Re,
>
> En fait, un petit calcul de projection orthogonale du
> point sur les segments devrait aider à coller mieux encore
> à la courbe.
>
> Voici un petit programme que j'avais fait avec les sources:
> http://membres.lycos.fr/jeanmarcn/projorth/projorth.htm
>
> Ceci, plus le code du post précédent, doit mener rapidement
> à une jolie solution, pas trop couteuse ni trop compliquée.
>
> --
Merci beaucoup, je vais me mettre là dessus ce week-end ou alors dans deux
semaines.
Pour les formules mathématiques, pas de problème, les maths c'est ma
(et puis une agrégation dans le domaine permet d'assurer quelques
connaissances en la matière).
Je te tiens au courant.
(Question : au niveau temps d'exécution, ce n'est pas trop long ?)
"Jean-Marc" a écrit dans le message de
42fd05d1$0$333$
> Re,
>
> En fait, un petit calcul de projection orthogonale du
> point sur les segments devrait aider à coller mieux encore
> à la courbe.
>
> Voici un petit programme que j'avais fait avec les sources:
> http://membres.lycos.fr/jeanmarcn/projorth/projorth.htm
>
> Ceci, plus le code du post précédent, doit mener rapidement
> à une jolie solution, pas trop couteuse ni trop compliquée.
>
> --
Merci beaucoup, je vais me mettre là dessus ce week-end ou alors dans deux
semaines.
Pour les formules mathématiques, pas de problème, les maths c'est ma
(et puis une agrégation dans le domaine permet d'assurer quelques
connaissances en la matière).
Je te tiens au courant.
(Question : au niveau temps d'exécution, ce n'est pas trop long ?)
"Patrice Henrio" a écrit dans le message de
news:
"Jean-Marc" a écrit dans le message de
news:42fd05d1$0$333$
> Re,
>
> En fait, un petit calcul de projection orthogonale du
> point sur les segments devrait aider à coller mieux encore
> à la courbe.
>
> Voici un petit programme que j'avais fait avec les sources:
> http://membres.lycos.fr/jeanmarcn/projorth/projorth.htm
>
> Ceci, plus le code du post précédent, doit mener rapidement
> à une jolie solution, pas trop couteuse ni trop compliquée.
>
> --
Hello,Merci beaucoup, je vais me mettre là dessus ce week-end ou alors dans
deux
semaines.
Pour les formules mathématiques, pas de problème, les maths c'est ma
passion(et puis une agrégation dans le domaine permet d'assurer quelques
connaissances en la matière).
Oui, il est sur que ça aide :-) Tu devrais donc sans mal identifier ce qui
ne va pas dans mes calculs de tangeante!Je te tiens au courant.
C'est gentil, je suis curieux de voir le résultat fini.(Question : au niveau temps d'exécution, ce n'est pas trop long ?)
Non, c'est assez rapide, pour ce que j'en ai essayé tout au moins. Ca
dépendra de combien de textes tu devras afficher, et il sera toujours
temps d'optimiser une fois une méthode bien propre trouvée.
--
Jean-marc
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ;
"Patrice Henrio" <patrice.henrio@laposte.net> a écrit dans le message de
news:ef4xMA5nFHA.2772@TK2MSFTNGP10.phx.gbl...
"Jean-Marc" <NO_SPAM_jean_marc_n2@yahoo.fr> a écrit dans le message de
news:
42fd05d1$0$333$ba620e4c@news.skynet.be...
> Re,
>
> En fait, un petit calcul de projection orthogonale du
> point sur les segments devrait aider à coller mieux encore
> à la courbe.
>
> Voici un petit programme que j'avais fait avec les sources:
> http://membres.lycos.fr/jeanmarcn/projorth/projorth.htm
>
> Ceci, plus le code du post précédent, doit mener rapidement
> à une jolie solution, pas trop couteuse ni trop compliquée.
>
> --
Hello,
Merci beaucoup, je vais me mettre là dessus ce week-end ou alors dans
deux
semaines.
Pour les formules mathématiques, pas de problème, les maths c'est ma
passion
(et puis une agrégation dans le domaine permet d'assurer quelques
connaissances en la matière).
Oui, il est sur que ça aide :-) Tu devrais donc sans mal identifier ce qui
ne va pas dans mes calculs de tangeante!
Je te tiens au courant.
C'est gentil, je suis curieux de voir le résultat fini.
(Question : au niveau temps d'exécution, ce n'est pas trop long ?)
Non, c'est assez rapide, pour ce que j'en ai essayé tout au moins. Ca
dépendra de combien de textes tu devras afficher, et il sera toujours
temps d'optimiser une fois une méthode bien propre trouvée.
--
Jean-marc
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ; _no_spam_jean_marc_n2@yahoo.fr
"Patrice Henrio" a écrit dans le message de
news:
"Jean-Marc" a écrit dans le message de
news:42fd05d1$0$333$
> Re,
>
> En fait, un petit calcul de projection orthogonale du
> point sur les segments devrait aider à coller mieux encore
> à la courbe.
>
> Voici un petit programme que j'avais fait avec les sources:
> http://membres.lycos.fr/jeanmarcn/projorth/projorth.htm
>
> Ceci, plus le code du post précédent, doit mener rapidement
> à une jolie solution, pas trop couteuse ni trop compliquée.
>
> --
Hello,Merci beaucoup, je vais me mettre là dessus ce week-end ou alors dans
deux
semaines.
Pour les formules mathématiques, pas de problème, les maths c'est ma
passion(et puis une agrégation dans le domaine permet d'assurer quelques
connaissances en la matière).
Oui, il est sur que ça aide :-) Tu devrais donc sans mal identifier ce qui
ne va pas dans mes calculs de tangeante!Je te tiens au courant.
C'est gentil, je suis curieux de voir le résultat fini.(Question : au niveau temps d'exécution, ce n'est pas trop long ?)
Non, c'est assez rapide, pour ce que j'en ai essayé tout au moins. Ca
dépendra de combien de textes tu devras afficher, et il sera toujours
temps d'optimiser une fois une méthode bien propre trouvée.
--
Jean-marc
"There are only 10 kind of people
those who understand binary and those who don't."
mailto: remove '_no_spam_' ;
Bon je travaille sur ton exemple depuis 5 heures et je crois que le
est un peu plus compliqué que prévu. Je te dis où j'en suis.
Tout d'abord une petite faute de signe sans gravité liée au fait que les
ordonnées sur l'écran vont du haut en bas alors que nos habitudes sont de
bas en haut.
Pour écrire le texte le long de la ligne il faut d'abord trouver le plus
proche segment du début du texte. Pour cela j'utilise ta fonction un peu
modifiée :
'Calcule la distance de A à (BC)
Private Function DistancePointDroite(A As Tpoint, B As Tpoint, C As
As Double
DistancePointDroite = Abs((C.Y - B.Y) * A.X + (B.X - C.X) * A.Y + (C.X
B.Y - B.X * C.Y)) / Sqr((C.Y - B.Y) ^ 2 + (B.X - C.X) ^ 2)
End Function
'Cette fonction renvoie le segment le plus proche du début du texte
Private Function PremierSegment(X As Single, Y As Single) As Long
Dim DAB As Double, DAM As Double, DBM As Double, I As Long, M As Tpoint
Dim D As Long, DMIN As Long
DMIN = 100000 'cela suffit pour mes besoins
'Le point M est le point courant dont on cherche le segment le plus
proche
M.X = X
M.Y = Y
For I = 1 To nbp - 1 'On cherche des segments dont [Tp(I),Tp(I+1)]
'la distance AB²
DAB = (tp(I + 1).X - tp(I).X) ^ 2 + (tp(I + 1).Y - tp(I).Y) ^ 2
'La distance BM ²
DBM = (tp(I + 1).X - X) ^ 2 + (tp(I + 1).Y - Y) ^ 2
'La distance AM²
DAM = (tp(I).X - X) ^ 2 + (tp(I).Y - Y) ^ 2
'On ne teste la proximité que si le point M est dans la bande
perpendiculaire au segment et de même largeur
'tu peux vérifier sur un dessin que cela marche (enfin je ne l'ai
pas formellement démontré)
If DAM > DBM Then HorsBande = ((DAB + DBM) < DAM) Else HorsBande
If Not HorsBande Then
D = DistancePointDroite(M, tp(I), tp(I + 1))
If D < DMIN Then
DMIN = D
PremierSegment = I
End If
End If
Next I
End Function
Mais pour les points suivants, comme on a un sens d'écriture (gauche à
droite, donc sens des aiguilles d'une montre), il faut définir un sens de
parcours de la ligne qui soit compatible.
Cela tombe bien c'est justement ce que j'ai fait pour mon projet.
Ensuite il faut regarder le segment le plus proche dans le sens de
l'écriture (il ne faut pas reparcourir tout le tableau).
Mais cela ne suffit pas non plus qu'est-ce que cela devient si un
est à la jointure entre deux segments
Si la largeur du caractère couvre plusieurs segments
Tu vois que le problème est loin d'être résolu.
Un peu plus tard dans la soirée
L'exemple suivant montre bien où se trouve le noed du problème
Tu traces deux sements l'un horizontal et l'autre à la suite à 45 degrés
vers le haut, tu places un point en dessous du segment horizontal mais un
peu plus loin que son extrémité de droite. Normallement on s'attend à ce
le segment le plus proche soit celui qui est incliné mais ton calcul
celui qui est horizontal et c'est bien en effet le plus proche.
D'où l'intérêt de la bande.
Le problème c'est quand le point est dans l'angle mort de deux bandes,
à dire qu'"il n'appartient à aucune des deux bandes consécutives. Mais j'y
travaille
Souhaites-tu continuer cette étude ici où à ton adresse perso ?
Bon je travaille sur ton exemple depuis 5 heures et je crois que le
est un peu plus compliqué que prévu. Je te dis où j'en suis.
Tout d'abord une petite faute de signe sans gravité liée au fait que les
ordonnées sur l'écran vont du haut en bas alors que nos habitudes sont de
bas en haut.
Pour écrire le texte le long de la ligne il faut d'abord trouver le plus
proche segment du début du texte. Pour cela j'utilise ta fonction un peu
modifiée :
'Calcule la distance de A à (BC)
Private Function DistancePointDroite(A As Tpoint, B As Tpoint, C As
As Double
DistancePointDroite = Abs((C.Y - B.Y) * A.X + (B.X - C.X) * A.Y + (C.X
B.Y - B.X * C.Y)) / Sqr((C.Y - B.Y) ^ 2 + (B.X - C.X) ^ 2)
End Function
'Cette fonction renvoie le segment le plus proche du début du texte
Private Function PremierSegment(X As Single, Y As Single) As Long
Dim DAB As Double, DAM As Double, DBM As Double, I As Long, M As Tpoint
Dim D As Long, DMIN As Long
DMIN = 100000 'cela suffit pour mes besoins
'Le point M est le point courant dont on cherche le segment le plus
proche
M.X = X
M.Y = Y
For I = 1 To nbp - 1 'On cherche des segments dont [Tp(I),Tp(I+1)]
'la distance AB²
DAB = (tp(I + 1).X - tp(I).X) ^ 2 + (tp(I + 1).Y - tp(I).Y) ^ 2
'La distance BM ²
DBM = (tp(I + 1).X - X) ^ 2 + (tp(I + 1).Y - Y) ^ 2
'La distance AM²
DAM = (tp(I).X - X) ^ 2 + (tp(I).Y - Y) ^ 2
'On ne teste la proximité que si le point M est dans la bande
perpendiculaire au segment et de même largeur
'tu peux vérifier sur un dessin que cela marche (enfin je ne l'ai
pas formellement démontré)
If DAM > DBM Then HorsBande = ((DAB + DBM) < DAM) Else HorsBande
If Not HorsBande Then
D = DistancePointDroite(M, tp(I), tp(I + 1))
If D < DMIN Then
DMIN = D
PremierSegment = I
End If
End If
Next I
End Function
Mais pour les points suivants, comme on a un sens d'écriture (gauche à
droite, donc sens des aiguilles d'une montre), il faut définir un sens de
parcours de la ligne qui soit compatible.
Cela tombe bien c'est justement ce que j'ai fait pour mon projet.
Ensuite il faut regarder le segment le plus proche dans le sens de
l'écriture (il ne faut pas reparcourir tout le tableau).
Mais cela ne suffit pas non plus qu'est-ce que cela devient si un
est à la jointure entre deux segments
Si la largeur du caractère couvre plusieurs segments
Tu vois que le problème est loin d'être résolu.
Un peu plus tard dans la soirée
L'exemple suivant montre bien où se trouve le noed du problème
Tu traces deux sements l'un horizontal et l'autre à la suite à 45 degrés
vers le haut, tu places un point en dessous du segment horizontal mais un
peu plus loin que son extrémité de droite. Normallement on s'attend à ce
le segment le plus proche soit celui qui est incliné mais ton calcul
celui qui est horizontal et c'est bien en effet le plus proche.
D'où l'intérêt de la bande.
Le problème c'est quand le point est dans l'angle mort de deux bandes,
à dire qu'"il n'appartient à aucune des deux bandes consécutives. Mais j'y
travaille
Souhaites-tu continuer cette étude ici où à ton adresse perso ?
Bon je travaille sur ton exemple depuis 5 heures et je crois que le
est un peu plus compliqué que prévu. Je te dis où j'en suis.
Tout d'abord une petite faute de signe sans gravité liée au fait que les
ordonnées sur l'écran vont du haut en bas alors que nos habitudes sont de
bas en haut.
Pour écrire le texte le long de la ligne il faut d'abord trouver le plus
proche segment du début du texte. Pour cela j'utilise ta fonction un peu
modifiée :
'Calcule la distance de A à (BC)
Private Function DistancePointDroite(A As Tpoint, B As Tpoint, C As
As Double
DistancePointDroite = Abs((C.Y - B.Y) * A.X + (B.X - C.X) * A.Y + (C.X
B.Y - B.X * C.Y)) / Sqr((C.Y - B.Y) ^ 2 + (B.X - C.X) ^ 2)
End Function
'Cette fonction renvoie le segment le plus proche du début du texte
Private Function PremierSegment(X As Single, Y As Single) As Long
Dim DAB As Double, DAM As Double, DBM As Double, I As Long, M As Tpoint
Dim D As Long, DMIN As Long
DMIN = 100000 'cela suffit pour mes besoins
'Le point M est le point courant dont on cherche le segment le plus
proche
M.X = X
M.Y = Y
For I = 1 To nbp - 1 'On cherche des segments dont [Tp(I),Tp(I+1)]
'la distance AB²
DAB = (tp(I + 1).X - tp(I).X) ^ 2 + (tp(I + 1).Y - tp(I).Y) ^ 2
'La distance BM ²
DBM = (tp(I + 1).X - X) ^ 2 + (tp(I + 1).Y - Y) ^ 2
'La distance AM²
DAM = (tp(I).X - X) ^ 2 + (tp(I).Y - Y) ^ 2
'On ne teste la proximité que si le point M est dans la bande
perpendiculaire au segment et de même largeur
'tu peux vérifier sur un dessin que cela marche (enfin je ne l'ai
pas formellement démontré)
If DAM > DBM Then HorsBande = ((DAB + DBM) < DAM) Else HorsBande
If Not HorsBande Then
D = DistancePointDroite(M, tp(I), tp(I + 1))
If D < DMIN Then
DMIN = D
PremierSegment = I
End If
End If
Next I
End Function
Mais pour les points suivants, comme on a un sens d'écriture (gauche à
droite, donc sens des aiguilles d'une montre), il faut définir un sens de
parcours de la ligne qui soit compatible.
Cela tombe bien c'est justement ce que j'ai fait pour mon projet.
Ensuite il faut regarder le segment le plus proche dans le sens de
l'écriture (il ne faut pas reparcourir tout le tableau).
Mais cela ne suffit pas non plus qu'est-ce que cela devient si un
est à la jointure entre deux segments
Si la largeur du caractère couvre plusieurs segments
Tu vois que le problème est loin d'être résolu.
Un peu plus tard dans la soirée
L'exemple suivant montre bien où se trouve le noed du problème
Tu traces deux sements l'un horizontal et l'autre à la suite à 45 degrés
vers le haut, tu places un point en dessous du segment horizontal mais un
peu plus loin que son extrémité de droite. Normallement on s'attend à ce
le segment le plus proche soit celui qui est incliné mais ton calcul
celui qui est horizontal et c'est bien en effet le plus proche.
D'où l'intérêt de la bande.
Le problème c'est quand le point est dans l'angle mort de deux bandes,
à dire qu'"il n'appartient à aucune des deux bandes consécutives. Mais j'y
travaille
Souhaites-tu continuer cette étude ici où à ton adresse perso ?
Quelqu'un a-t'il déjà codé le problème suivant :
J'ai une ligne à l'écran définie pas des segments de droites (suffisamment
rapprochés pour donner l'illusion d'une courbe).
Je veux écrire un texte qui suive une partie de cette courbe.
Cerise sur le gâteau, je souhaite pouvoir sélectionner ce texte et le
déplacer le long de la courbe.
Si quelqu'un a une idée pas trop lourde ?
Pour l'instant je me suis contenté de réécrire le texte en mode dessin et
considéré ce dessin comme une courbe puis je l'ai intégré au dessin de la
courbe de départ.
Avantage : tous les calculs préliminaires se font dans Excel, ensuite je
charge les résultats (texte + courbe) dans un fichier de points. Ca je sais
faire.
Inconvénient : mon texte est figé à un endroit de la courbe et n'est donc
pas dynamique.
Peut-être faudrait-il que je développe un ocx ?
Quelqu'un a-t'il déjà codé le problème suivant :
J'ai une ligne à l'écran définie pas des segments de droites (suffisamment
rapprochés pour donner l'illusion d'une courbe).
Je veux écrire un texte qui suive une partie de cette courbe.
Cerise sur le gâteau, je souhaite pouvoir sélectionner ce texte et le
déplacer le long de la courbe.
Si quelqu'un a une idée pas trop lourde ?
Pour l'instant je me suis contenté de réécrire le texte en mode dessin et
considéré ce dessin comme une courbe puis je l'ai intégré au dessin de la
courbe de départ.
Avantage : tous les calculs préliminaires se font dans Excel, ensuite je
charge les résultats (texte + courbe) dans un fichier de points. Ca je sais
faire.
Inconvénient : mon texte est figé à un endroit de la courbe et n'est donc
pas dynamique.
Peut-être faudrait-il que je développe un ocx ?
Quelqu'un a-t'il déjà codé le problème suivant :
J'ai une ligne à l'écran définie pas des segments de droites (suffisamment
rapprochés pour donner l'illusion d'une courbe).
Je veux écrire un texte qui suive une partie de cette courbe.
Cerise sur le gâteau, je souhaite pouvoir sélectionner ce texte et le
déplacer le long de la courbe.
Si quelqu'un a une idée pas trop lourde ?
Pour l'instant je me suis contenté de réécrire le texte en mode dessin et
considéré ce dessin comme une courbe puis je l'ai intégré au dessin de la
courbe de départ.
Avantage : tous les calculs préliminaires se font dans Excel, ensuite je
charge les résultats (texte + courbe) dans un fichier de points. Ca je sais
faire.
Inconvénient : mon texte est figé à un endroit de la courbe et n'est donc
pas dynamique.
Peut-être faudrait-il que je développe un ocx ?
Salut à tous,
j'ai une "autre" solution, plus générale.
j'ai Un module de classe qui gère le DC d'un picturebox par les API et
permet de travailler dans un système de coordonnées réelles (metrique), et
entre autre de tracer une courbe et de tracer un texte selon un point
d'attache et un angle donné.
A partir de là
pour tout x tu connais y=F(x) pour tracer le texte (déplacement)
et l'angle est la tangente à F au point X.
A+
Christophe
Patrice Henrio a écrit :Quelqu'un a-t'il déjà codé le problème suivant :
J'ai une ligne à l'écran définie pas des segments de droites
(suffisamment rapprochés pour donner l'illusion d'une courbe).
Je veux écrire un texte qui suive une partie de cette courbe.
Cerise sur le gâteau, je souhaite pouvoir sélectionner ce texte et le
déplacer le long de la courbe.
Si quelqu'un a une idée pas trop lourde ?
Pour l'instant je me suis contenté de réécrire le texte en mode dessin et
considéré ce dessin comme une courbe puis je l'ai intégré au dessin de la
courbe de départ.
Avantage : tous les calculs préliminaires se font dans Excel, ensuite je
charge les résultats (texte + courbe) dans un fichier de points. Ca je
sais faire.
Inconvénient : mon texte est figé à un endroit de la courbe et n'est donc
pas dynamique.
Peut-être faudrait-il que je développe un ocx ?
Salut à tous,
j'ai une "autre" solution, plus générale.
j'ai Un module de classe qui gère le DC d'un picturebox par les API et
permet de travailler dans un système de coordonnées réelles (metrique), et
entre autre de tracer une courbe et de tracer un texte selon un point
d'attache et un angle donné.
A partir de là
pour tout x tu connais y=F(x) pour tracer le texte (déplacement)
et l'angle est la tangente à F au point X.
A+
Christophe
Patrice Henrio a écrit :
Quelqu'un a-t'il déjà codé le problème suivant :
J'ai une ligne à l'écran définie pas des segments de droites
(suffisamment rapprochés pour donner l'illusion d'une courbe).
Je veux écrire un texte qui suive une partie de cette courbe.
Cerise sur le gâteau, je souhaite pouvoir sélectionner ce texte et le
déplacer le long de la courbe.
Si quelqu'un a une idée pas trop lourde ?
Pour l'instant je me suis contenté de réécrire le texte en mode dessin et
considéré ce dessin comme une courbe puis je l'ai intégré au dessin de la
courbe de départ.
Avantage : tous les calculs préliminaires se font dans Excel, ensuite je
charge les résultats (texte + courbe) dans un fichier de points. Ca je
sais faire.
Inconvénient : mon texte est figé à un endroit de la courbe et n'est donc
pas dynamique.
Peut-être faudrait-il que je développe un ocx ?
Salut à tous,
j'ai une "autre" solution, plus générale.
j'ai Un module de classe qui gère le DC d'un picturebox par les API et
permet de travailler dans un système de coordonnées réelles (metrique), et
entre autre de tracer une courbe et de tracer un texte selon un point
d'attache et un angle donné.
A partir de là
pour tout x tu connais y=F(x) pour tracer le texte (déplacement)
et l'angle est la tangente à F au point X.
A+
Christophe
Patrice Henrio a écrit :Quelqu'un a-t'il déjà codé le problème suivant :
J'ai une ligne à l'écran définie pas des segments de droites
(suffisamment rapprochés pour donner l'illusion d'une courbe).
Je veux écrire un texte qui suive une partie de cette courbe.
Cerise sur le gâteau, je souhaite pouvoir sélectionner ce texte et le
déplacer le long de la courbe.
Si quelqu'un a une idée pas trop lourde ?
Pour l'instant je me suis contenté de réécrire le texte en mode dessin et
considéré ce dessin comme une courbe puis je l'ai intégré au dessin de la
courbe de départ.
Avantage : tous les calculs préliminaires se font dans Excel, ensuite je
charge les résultats (texte + courbe) dans un fichier de points. Ca je
sais faire.
Inconvénient : mon texte est figé à un endroit de la courbe et n'est donc
pas dynamique.
Peut-être faudrait-il que je développe un ocx ?
Est-ce que l'angle est le même pour chaque lettre (écriture du mot en une
fois) ou dépend de chaque lettre ?
Peut-on voir de quoi il retourne ?
Merci.
Est-ce que l'angle est le même pour chaque lettre (écriture du mot en une
fois) ou dépend de chaque lettre ?
Peut-on voir de quoi il retourne ?
Merci.
Est-ce que l'angle est le même pour chaque lettre (écriture du mot en une
fois) ou dépend de chaque lettre ?
Peut-on voir de quoi il retourne ?
Merci.
Patrice Henrio a écrit :Est-ce que l'angle est le même pour chaque lettre (écriture du mot en une
fois) ou dépend de chaque lettre ?
Peut-on voir de quoi il retourne ?
Merci.
Bonjour,
En fait la methode de la classe prend en argument un string donc tu peux
gérer ton mot en n caractères à toi de voir, ci-joint un exemple
d'utilisation de la classe.
NB: prendre garde à mettre scalemode à pixel pour picture1.
Désolé c'est pas trop commenté mais tu devrais t'en sortir.
Si tu as des questions n'hésites pas.
A+
Christophe
'****************
'form1, picture1 (picturebox), command1 (command button
'****************
Private mdc As metricDC
Private Sub Command1_Click()
Dim Io As Long
Dim dX As Double
Dim i&
Dim x As Double
Dim y As Double
mdc.zoomReel -5, -5, 5, 5
mdc.linereal -10, 0, mdc.Espacereelright, 0, RGB(0, 0, 0)
mdc.linereal 0, -10, 0, mdc.Espacereeltop, RGB(0, 0, 0)
mdc.writetext "0rigine (0,0)", 0.2, -0.7, 0.7, 0, 0, True
dX = mdc.DefiniPasReal
x = mdc.Espacereelleft
Do While x < mdc.Espacereelright
y = Sin(x)
mdc.DessinePointFonction x, y, RGB(0, 255, 0)
y = Tan(x)
mdc.DessinePointFonction x, y, RGB(255, 0, 0)
x = x + dX
Loop
mdc.Cercle 0, 0, 1, RGB(0, 0, 255)
End Sub
Private Sub Form_Load()
Set mdc = New metricDC
mdc.Init Picture1
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set mdc = Nothing
End Sub
'**************************************
Option Explicit
'---------------------------------------------------------------------------------------
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
'---------------------------------------------------------------------------------------
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private m_hwnd As Long
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hdc
As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect,
ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long, lppt
As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal
nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long,
lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal x1
As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
Set mPicture = Picture1
mPicture.ScaleMode = 3
espaceclient
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
mWinOrgX = 0
mWinOrgY = 0
mxT = 0
myT = 0
mEchelle = 1 / 1000
InitEspace
zoomReel 0, 0, 1000, 1000
End Sub
Public Function InitEspace()
Dim pt As POINTAPI
setmetrique
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc, MaxlogPoint(0), 1)
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
exitmetrique
End Function
Public Sub setmetrique()
m_savedDC& = SaveDC&(mPicture.hdc)
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
mypoint)
End Sub
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
Public Sub PeriphReel(x As Single, y As Single)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 1)
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
Dim pt As POINTAPI
Dim p As POINTGEO
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
setmetrique
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc, MaxlogPoint(0), 1)
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
p = LtoR(pt)
mespacereel.Left = p.x
mespacereel.Bottom = p.y
p = LtoR(MaxlogPoint(0))
mespacereel.Right = p.x
mespacereel.Top = p.y
exitmetrique
End Sub
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
Private Function LtoR(p As POINTAPI) As POINTGEO
If mEchelle = 0 Then Exit Function
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
If (x2 - x1) > (y2 - y1) Then
zoomXReel x1, y1, x2, y2
Exit Sub
Else
zoomYReel x1, y1, x2, y2
Exit Sub
End If
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional Mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, Mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional Mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, Mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc, ap(1).x, ap(1).y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'---------------------------------------------------------------------------------------
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
'---------------------------------------------------------------------------------------
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'---------------------------------------------------------------------------------------
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
'---------------------------------------------------------------------------------------
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'---------------------------------------------------------------------------------------
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + taille
p.y = y + taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get echelle() As Double
echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
Public Function DefiniValPixel(AxeX As Boolean) As Double
setmetrique
ReDim lpPoint(2)
ReDim mlpgeo(2)
lpPoint(0).x = 0
lpPoint(0).y = 0
lpPoint(1).x = 1
lpPoint(1).y = 0
lpPoint(2).x = 0
lpPoint(2).y = 1
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 3)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mlpgeo(2) = LtoR(lpPoint(2))
exitmetrique
If AxeX Then
DefiniValPixel = Sqr((mlpgeo(1).x - mlpgeo(0).x) ^ 2 + (mlpgeo(1).y -
mlpgeo(0).y) ^ 2)
Else
DefiniValPixel = Sqr((mlpgeo(2).x - mlpgeo(0).x) ^ 2 + (mlpgeo(2).y -
mlpgeo(0).y) ^ 2)
End If
End Function
Public Property Get hwnd() As Long
hwnd = mPicture.hwnd
End Property
Public Sub zoomYReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = mYlogique / ((mlpgeo(1).y - mlpgeo(0).y) * 10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub zoomXReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = mXlogique / ((mlpgeo(1).x - mlpgeo(0).x) * 10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Cercle(x1 As Double, y1 As Double, rayon As Double, couleur As
Long)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
Dim r As RECTGEO
r.Bottom = mespacereel.Bottom
r.Left = mespacereel.Left
r.Right = mespacereel.Right
r.Top = mespacereel.Top
p1.x = x1
p1.y = y1
If PinRealRegion(p1, r) Then
If (r.Right - r.Left) < rayon Or (r.Top - r.Bottom) < rayon Then
Exit Sub
End If
Else
Exit Sub
End If
p1.x = x1 - rayon
p2.x = x1 + rayon
p1.y = y1 - rayon
p2.y = y1 + rayon
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
dummy& = Ellipse(mPicture.hdc, ap1.x, ap1.y, ap2.x, ap2.y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Sub pointreal(x As Double, y As Double, couleur As Long)
Dim p1 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
p1.x = x
p1.y = y
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x + 100, ap1.y)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x - 100, ap1.y)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x, ap1.y + 100)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x, ap1.y - 100)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Sub CadreReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim ap As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap)
dummy& = LineTo(mPicture.hdc, ap2.x, ap1.y)
dummy& = LineTo(mPicture.hdc, ap2.x, ap2.y)
dummy& = LineTo(mPicture.hdc, ap1.x, ap2.y)
dummy& = LineTo(mPicture.hdc, ap1.x, ap1.y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Sub DessineCadreSelect(x1 As Double, y1 As Double)
Dim p1 As POINTGEO
Dim ap1 As POINTAPI
Dim ap As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
p1.x = x1
p1.y = y1
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, RGB(0, 0, 255))
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
dummy& = MoveToEx&(mPicture.hdc, ap1.x - 100, ap1.y - 100, ap)
dummy& = LineTo(mPicture.hdc, ap1.x - 100, ap1.y + 100)
dummy& = LineTo(mPicture.hdc, ap1.x + 100, ap1.y + 100)
dummy& = LineTo(mPicture.hdc, ap1.x + 100, ap1.y - 100)
dummy& = LineTo(mPicture.hdc, ap1.x - 100, ap1.y - 100)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Property Get Lastbottomtext() As Variant
Lastbottomtext = mespaceText.Bottom
End Property
Public Property Get Lastlefttext() As Variant
Lastlefttext = mespaceText.Left
End Property
Public Property Get Lasttoptext() As Variant
Lasttoptext = mespaceText.Top
End Property
Public Property Get Lastrighttext() As Variant
Lastrighttext = mespaceText.Right
End Property
Public Sub rectanglereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim lpPoint(3) As POINTAPI
Dim OldPen&, UsePen&
Dim oldbrush&, usebrush&
Dim dummy&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
usebrush& = CreateSolidBrush(couleur)
oldbrush = SelectObject(mPicture.hdc, usebrush&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
lpPoint(0).x = ap1.x
lpPoint(0).y = ap1.y
lpPoint(1).x = ap2.x
lpPoint(1).y = ap1.y
lpPoint(2).x = ap2.x
lpPoint(2).y = ap2.y
lpPoint(3).x = ap1.x
lpPoint(3).y = ap2.y
dummy& = Polygon(mPicture.hdc, lpPoint(0), 4) 'Rectangle(mpicture.hdc,
ap1.x, ap1.y, ap2.x, ap2.y)
UsePen& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
usebrush& = SelectObject(mPicture.hdc, oldbrush)
dummy& = DeleteObject(usebrush)
exitmetrique
End Sub
Public Function CLS()
mPicture.CLS
End Function
Patrice Henrio a écrit :
Est-ce que l'angle est le même pour chaque lettre (écriture du mot en une
fois) ou dépend de chaque lettre ?
Peut-on voir de quoi il retourne ?
Merci.
Bonjour,
En fait la methode de la classe prend en argument un string donc tu peux
gérer ton mot en n caractères à toi de voir, ci-joint un exemple
d'utilisation de la classe.
NB: prendre garde à mettre scalemode à pixel pour picture1.
Désolé c'est pas trop commenté mais tu devrais t'en sortir.
Si tu as des questions n'hésites pas.
A+
Christophe
'****************
'form1, picture1 (picturebox), command1 (command button
'****************
Private mdc As metricDC
Private Sub Command1_Click()
Dim Io As Long
Dim dX As Double
Dim i&
Dim x As Double
Dim y As Double
mdc.zoomReel -5, -5, 5, 5
mdc.linereal -10, 0, mdc.Espacereelright, 0, RGB(0, 0, 0)
mdc.linereal 0, -10, 0, mdc.Espacereeltop, RGB(0, 0, 0)
mdc.writetext "0rigine (0,0)", 0.2, -0.7, 0.7, 0, 0, True
dX = mdc.DefiniPasReal
x = mdc.Espacereelleft
Do While x < mdc.Espacereelright
y = Sin(x)
mdc.DessinePointFonction x, y, RGB(0, 255, 0)
y = Tan(x)
mdc.DessinePointFonction x, y, RGB(255, 0, 0)
x = x + dX
Loop
mdc.Cercle 0, 0, 1, RGB(0, 0, 255)
End Sub
Private Sub Form_Load()
Set mdc = New metricDC
mdc.Init Picture1
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set mdc = Nothing
End Sub
'**************************************
Option Explicit
'---------------------------------------------------------------------------------------
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
'---------------------------------------------------------------------------------------
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private m_hwnd As Long
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hdc
As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect,
ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long, lppt
As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal
nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long,
lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal x1
As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
Set mPicture = Picture1
mPicture.ScaleMode = 3
espaceclient
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
mWinOrgX = 0
mWinOrgY = 0
mxT = 0
myT = 0
mEchelle = 1 / 1000
InitEspace
zoomReel 0, 0, 1000, 1000
End Sub
Public Function InitEspace()
Dim pt As POINTAPI
setmetrique
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc, MaxlogPoint(0), 1)
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
exitmetrique
End Function
Public Sub setmetrique()
m_savedDC& = SaveDC&(mPicture.hdc)
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
mypoint)
End Sub
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
Public Sub PeriphReel(x As Single, y As Single)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 1)
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
Dim pt As POINTAPI
Dim p As POINTGEO
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
setmetrique
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc, MaxlogPoint(0), 1)
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
p = LtoR(pt)
mespacereel.Left = p.x
mespacereel.Bottom = p.y
p = LtoR(MaxlogPoint(0))
mespacereel.Right = p.x
mespacereel.Top = p.y
exitmetrique
End Sub
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
Private Function LtoR(p As POINTAPI) As POINTGEO
If mEchelle = 0 Then Exit Function
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
If (x2 - x1) > (y2 - y1) Then
zoomXReel x1, y1, x2, y2
Exit Sub
Else
zoomYReel x1, y1, x2, y2
Exit Sub
End If
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional Mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, Mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional Mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, Mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc, ap(1).x, ap(1).y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'---------------------------------------------------------------------------------------
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
'---------------------------------------------------------------------------------------
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'---------------------------------------------------------------------------------------
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
'---------------------------------------------------------------------------------------
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'---------------------------------------------------------------------------------------
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + taille
p.y = y + taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get echelle() As Double
echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
Public Function DefiniValPixel(AxeX As Boolean) As Double
setmetrique
ReDim lpPoint(2)
ReDim mlpgeo(2)
lpPoint(0).x = 0
lpPoint(0).y = 0
lpPoint(1).x = 1
lpPoint(1).y = 0
lpPoint(2).x = 0
lpPoint(2).y = 1
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 3)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mlpgeo(2) = LtoR(lpPoint(2))
exitmetrique
If AxeX Then
DefiniValPixel = Sqr((mlpgeo(1).x - mlpgeo(0).x) ^ 2 + (mlpgeo(1).y -
mlpgeo(0).y) ^ 2)
Else
DefiniValPixel = Sqr((mlpgeo(2).x - mlpgeo(0).x) ^ 2 + (mlpgeo(2).y -
mlpgeo(0).y) ^ 2)
End If
End Function
Public Property Get hwnd() As Long
hwnd = mPicture.hwnd
End Property
Public Sub zoomYReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = mYlogique / ((mlpgeo(1).y - mlpgeo(0).y) * 10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub zoomXReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = mXlogique / ((mlpgeo(1).x - mlpgeo(0).x) * 10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Cercle(x1 As Double, y1 As Double, rayon As Double, couleur As
Long)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
Dim r As RECTGEO
r.Bottom = mespacereel.Bottom
r.Left = mespacereel.Left
r.Right = mespacereel.Right
r.Top = mespacereel.Top
p1.x = x1
p1.y = y1
If PinRealRegion(p1, r) Then
If (r.Right - r.Left) < rayon Or (r.Top - r.Bottom) < rayon Then
Exit Sub
End If
Else
Exit Sub
End If
p1.x = x1 - rayon
p2.x = x1 + rayon
p1.y = y1 - rayon
p2.y = y1 + rayon
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
dummy& = Ellipse(mPicture.hdc, ap1.x, ap1.y, ap2.x, ap2.y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Sub pointreal(x As Double, y As Double, couleur As Long)
Dim p1 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
p1.x = x
p1.y = y
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x + 100, ap1.y)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x - 100, ap1.y)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x, ap1.y + 100)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x, ap1.y - 100)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Sub CadreReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim ap As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap)
dummy& = LineTo(mPicture.hdc, ap2.x, ap1.y)
dummy& = LineTo(mPicture.hdc, ap2.x, ap2.y)
dummy& = LineTo(mPicture.hdc, ap1.x, ap2.y)
dummy& = LineTo(mPicture.hdc, ap1.x, ap1.y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Sub DessineCadreSelect(x1 As Double, y1 As Double)
Dim p1 As POINTGEO
Dim ap1 As POINTAPI
Dim ap As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
p1.x = x1
p1.y = y1
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, RGB(0, 0, 255))
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
dummy& = MoveToEx&(mPicture.hdc, ap1.x - 100, ap1.y - 100, ap)
dummy& = LineTo(mPicture.hdc, ap1.x - 100, ap1.y + 100)
dummy& = LineTo(mPicture.hdc, ap1.x + 100, ap1.y + 100)
dummy& = LineTo(mPicture.hdc, ap1.x + 100, ap1.y - 100)
dummy& = LineTo(mPicture.hdc, ap1.x - 100, ap1.y - 100)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Property Get Lastbottomtext() As Variant
Lastbottomtext = mespaceText.Bottom
End Property
Public Property Get Lastlefttext() As Variant
Lastlefttext = mespaceText.Left
End Property
Public Property Get Lasttoptext() As Variant
Lasttoptext = mespaceText.Top
End Property
Public Property Get Lastrighttext() As Variant
Lastrighttext = mespaceText.Right
End Property
Public Sub rectanglereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim lpPoint(3) As POINTAPI
Dim OldPen&, UsePen&
Dim oldbrush&, usebrush&
Dim dummy&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
usebrush& = CreateSolidBrush(couleur)
oldbrush = SelectObject(mPicture.hdc, usebrush&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
lpPoint(0).x = ap1.x
lpPoint(0).y = ap1.y
lpPoint(1).x = ap2.x
lpPoint(1).y = ap1.y
lpPoint(2).x = ap2.x
lpPoint(2).y = ap2.y
lpPoint(3).x = ap1.x
lpPoint(3).y = ap2.y
dummy& = Polygon(mPicture.hdc, lpPoint(0), 4) 'Rectangle(mpicture.hdc,
ap1.x, ap1.y, ap2.x, ap2.y)
UsePen& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
usebrush& = SelectObject(mPicture.hdc, oldbrush)
dummy& = DeleteObject(usebrush)
exitmetrique
End Sub
Public Function CLS()
mPicture.CLS
End Function
Patrice Henrio a écrit :Est-ce que l'angle est le même pour chaque lettre (écriture du mot en une
fois) ou dépend de chaque lettre ?
Peut-on voir de quoi il retourne ?
Merci.
Bonjour,
En fait la methode de la classe prend en argument un string donc tu peux
gérer ton mot en n caractères à toi de voir, ci-joint un exemple
d'utilisation de la classe.
NB: prendre garde à mettre scalemode à pixel pour picture1.
Désolé c'est pas trop commenté mais tu devrais t'en sortir.
Si tu as des questions n'hésites pas.
A+
Christophe
'****************
'form1, picture1 (picturebox), command1 (command button
'****************
Private mdc As metricDC
Private Sub Command1_Click()
Dim Io As Long
Dim dX As Double
Dim i&
Dim x As Double
Dim y As Double
mdc.zoomReel -5, -5, 5, 5
mdc.linereal -10, 0, mdc.Espacereelright, 0, RGB(0, 0, 0)
mdc.linereal 0, -10, 0, mdc.Espacereeltop, RGB(0, 0, 0)
mdc.writetext "0rigine (0,0)", 0.2, -0.7, 0.7, 0, 0, True
dX = mdc.DefiniPasReal
x = mdc.Espacereelleft
Do While x < mdc.Espacereelright
y = Sin(x)
mdc.DessinePointFonction x, y, RGB(0, 255, 0)
y = Tan(x)
mdc.DessinePointFonction x, y, RGB(255, 0, 0)
x = x + dX
Loop
mdc.Cercle 0, 0, 1, RGB(0, 0, 255)
End Sub
Private Sub Form_Load()
Set mdc = New metricDC
mdc.Init Picture1
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set mdc = Nothing
End Sub
'**************************************
Option Explicit
'---------------------------------------------------------------------------------------
' Module : metricDC
' DateTime : 17/11/02 17:51
' Author : VERGON Christophe
' Purpose : Gestion des pictureBox en mode metrique
' How to use PictureBox in Metric Mode with API
'call init sub to start
'---------------------------------------------------------------------------------------
Const PS_SOLID& = 0
Const PS_DOT& = 2
Const PS_DASH& = 1
Const PS_DASHDOT& = 3
Const PS_DASHDOTDOT& = 4
Const MM_HIMETRIC& = 3
Const FIXED_PITCH = 1
Const TA_NOUPDATECP = 0
Const TA_UPDATECP = 1
Const TA_LEFT = 0
Const TA_RIGHT = 2
Const TA_CENTER = 6
Const TA_TOP = 0
Const TA_BOTTOM = 8
Const TA_BASELINE = 24
Const LF_FACESIZE = 32
Private Const SYSTEM_FONT& = 13
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private m_hwnd As Long
Private Declare Function CreateFontIndirect& Lib "gdi32" Alias
"CreateFontIndirectA" (lpLogFont As LOGFONT)
Private Declare Function GetTextFace& Lib "gdi32" Alias "GetTextFaceA"
(ByVal hdc As Long, ByVal nCount As Long, ByVal lpFacename As String)
Private Declare Function GetTextMetrics& Lib "gdi32" Alias
"GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC)
Private Declare Function GetTextExtentPoint32& Lib "gdi32" Alias
"GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal
cbString As Long, lpSize As Size)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hdc
As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal
nCount As Long)
Private Declare Function SetTextAlign& Lib "gdi32" (ByVal hdc As Long,
ByVal wFlags As Long)
Private Declare Function DrawText& Lib "user32" Alias "DrawTextA" (ByVal
hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As Rect,
ByVal wFormat As Long)
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type POINTGEO
x As Double
y As Double
End Type
Private Type RECTGEO
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'**********************************
Private mMousepointer As Integer
'** Function Declarations:
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As
Long)
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long,
ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function LineTo& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long)
Private Declare Function MoveToEx& Lib "gdi32" (ByVal hdc As Long, ByVal x
As Long, ByVal y As Long, lpPoint As POINTAPI)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function PolylineTo& Lib "gdi32" (ByVal hdc As Long, lppt
As POINTAPI, ByVal cCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function DPtoLP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function LPtoDP& Lib "gdi32" (ByVal hdc As Long, lpPoint
As POINTAPI, ByVal nCount As Long)
Private Declare Function SetMapMode& Lib "gdi32" (ByVal hdc As Long, ByVal
nMapMode As Long)
Private Declare Function SetViewportOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function SetWindowOrgEx& Lib "gdi32" (ByVal hdc As Long,
ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI)
Private Declare Function RestoreDC& Lib "gdi32" (ByVal hdc As Long, ByVal
nSavedDC As Long)
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd As Long,
lpRect As Rect)
Private Declare Function GetStockObject& Lib "gdi32" (ByVal nIndex As
Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long)
Private Declare Function SaveDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function Rectangle& Lib "gdi32" (ByVal hdc As Long, ByVal
x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA"
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any)
Private Declare Function SetPixelV& Lib "gdi32" (ByVal hdc As Long, ByVal
x As Long, ByVal y As Long, ByVal crColor As Long)
Private Declare Function Ellipse& Lib "gdi32" (ByVal hdc As Long, ByVal x1
As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function CreateRectRgn& Lib "gdi32" (ByVal x1 As Long,
ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long)
Private Declare Function SelectClipRgn& Lib "gdi32" (ByVal hdc As Long,
ByVal hRgn As Long)
Private Declare Function SetROP2& Lib "gdi32" (ByVal hdc As Long, ByVal
nDrawMode As Long)
Private Declare Function GetROP2& Lib "gdi32" (ByVal hdc As Long)
Private Const R2_COPYPEN& = 13
Private mrectdessin As Rect
Private mypoint As POINTAPI
Private MyGeoPoint As POINTGEO
Private mespacereel As RECTGEO
Private mDimensionEspaceLogique
Private mYlog As Long
Private mXlog As Long
Private mYlogique As Long
Private mXlogique As Long
Private mX As Double
Private mY As Double
Private mXph As Long
Private mYph As Long
Private mxT As Double
Private myT As Double
Private mEchelle As Double
Private mViewOrgX As Long
Private mviewOrgY As Long
Private mWinOrgX As Long
Private mWinOrgY As Long
Private m_savedDC&
Private mrectText As Rect
Private mespaceText As RECTGEO
Private MaxlogPoint() As POINTAPI
Private lpPoint() As POINTAPI
Private mlpgeo() As POINTGEO
Private dummy&
Private mPicture As PictureBox
Public Sub Init(Picture1 As PictureBox)
Dim pt As POINTAPI
Set mPicture = Picture1
mPicture.ScaleMode = 3
espaceclient
mViewOrgX = 0&
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
mWinOrgX = 0
mWinOrgY = 0
mxT = 0
myT = 0
mEchelle = 1 / 1000
InitEspace
zoomReel 0, 0, 1000, 1000
End Sub
Public Function InitEspace()
Dim pt As POINTAPI
setmetrique
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc, MaxlogPoint(0), 1)
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
MyGeoPoint = LtoR(MaxlogPoint(0))
mespacereel.Right = MyGeoPoint.x
mespacereel.Top = MyGeoPoint.y
MyGeoPoint = LtoR(pt)
mespacereel.Bottom = MyGeoPoint.x
mespacereel.Left = MyGeoPoint.y
exitmetrique
End Function
Public Sub setmetrique()
m_savedDC& = SaveDC&(mPicture.hdc)
dummy& = SetMapMode&(mPicture.hdc, MM_HIMETRIC)
dummy& = SetViewportOrgEx&(mPicture.hdc, mViewOrgX, mviewOrgY,
mypoint)
dummy& = SetWindowOrgEx&(mPicture.hdc, mWinOrgX, mWinOrgY,
mypoint)
End Sub
Public Sub exitmetrique()
m_savedDC& = RestoreDC(mPicture.hdc, m_savedDC&)
End Sub
Public Sub PeriphReel(x As Single, y As Single)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = CLng(x)
lpPoint(0).y = CLng(y)
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 1)
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
'retour dc à vb
exitmetrique
End Sub
Public Sub ReelPeriph(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
dummy& = LPtoDP(mPicture.hdc, lpPoint(0), 1)
mXph = lpPoint(0).x
mYph = lpPoint(0).y
exitmetrique
End Sub
Public Sub ReelLogiq(x As Double, y As Double)
setmetrique
ReDim mlpgeo(0)
mlpgeo(0).x = x
mlpgeo(0).y = y
ReDim lpPoint(0)
lpPoint(0) = RtoL(mlpgeo(0))
mXlog = lpPoint(0).x
mYlog = lpPoint(0).y
exitmetrique
End Sub
Public Sub LogiqToReel(x As Long, y As Long)
setmetrique
ReDim lpPoint(0)
ReDim mlpgeo(0)
lpPoint(0).x = x
lpPoint(0).y = y
mlpgeo(0) = LtoR(lpPoint(0))
mX = mlpgeo(0).x
mY = mlpgeo(0).y
exitmetrique
End Sub
Public Sub espaceclient()
Dim dummy&
Dim pt As POINTAPI
Dim p As POINTGEO
dummy& = GetClientRect&(mPicture.hwnd, mrectdessin)
mviewOrgY = mrectdessin.Bottom - mrectdessin.Top
setmetrique
ReDim MaxlogPoint(0)
MaxlogPoint(0).x = mrectdessin.Right
MaxlogPoint(0).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc, MaxlogPoint(0), 1)
pt.x = 0: pt.y = 0
mYlogique = MaxlogPoint(0).y
mXlogique = MaxlogPoint(0).x
mDimensionEspaceLogique = DistanceAPI(pt, MaxlogPoint(0))
p = LtoR(pt)
mespacereel.Left = p.x
mespacereel.Bottom = p.y
p = LtoR(MaxlogPoint(0))
mespacereel.Right = p.x
mespacereel.Top = p.y
exitmetrique
End Sub
Private Function RtoL(p As POINTGEO) As POINTAPI
Dim x As Long, y As Long
Dim x1 As Double, y1 As Double
x1 = ((p.x - mxT) * 10 ^ 5 * mEchelle)
y1 = ((p.y - myT) * 10 ^ 5 * mEchelle)
On Error Resume Next
Err.Clear
x = CLng(x1)
If Err.Number = 6 Then
x = -32765
Err.Clear
End If
y = CLng(y1)
If Err.Number = 6 Then
y = -32765
Err.Clear
End If
On Error GoTo 0
If p.x < mxT Then
RtoL.x = -32765
x = -32765
End If
If p.y < myT Then
RtoL.y = -32765
y = -32765
End If
If x > 32765 Then
RtoL.x = 32765
Else
RtoL.x = x
End If
If y > 32765 Then
RtoL.y = 32765
Else
RtoL.y = y
End If
'RtoL.x = x
'RtoL.y = y
End Function
Private Function LtoR(p As POINTAPI) As POINTGEO
If mEchelle = 0 Then Exit Function
LtoR.x = p.x / (mEchelle * 10 ^ 5) + mxT
LtoR.y = p.y / (mEchelle * 10 ^ 5) + myT
End Function
Public Sub zoomPh(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
If mlpgeo(0).x < mlpgeo(1).x Then
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
Else
mespacereel.Left = mlpgeo(1).x
mespacereel.Right = mlpgeo(0).x
End If
If mlpgeo(0).y < mlpgeo(1).y Then
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
Else
mespacereel.Bottom = mlpgeo(1).y
mespacereel.Top = mlpgeo(0).y
End If
mEchelle = mDimensionEspaceLogique / (DistanceGEO(mlpgeo(0),
mlpgeo(1)) * 10 ^ 5)
mxT = mespacereel.Left
myT = mespacereel.Bottom
lpPoint(1).x = mrectdessin.Right
lpPoint(1).y = mrectdessin.Top
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 2)
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Right = mlpgeo(1).x
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Offset(x1 As Single, y1 As Single, x2 As Single, y2 As Single)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
lpPoint(1).x = CLng(x2)
lpPoint(1).y = CLng(y2)
lpPoint(0).x = CLng(x1)
lpPoint(0).y = CLng(y1)
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 2)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Bottom = mespacereel.Bottom + (mlpgeo(0).y - mlpgeo(1).y)
mespacereel.Left = mespacereel.Left + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Right = mespacereel.Right + (mlpgeo(0).x - mlpgeo(1).x)
mespacereel.Top = mespacereel.Top + (mlpgeo(0).y - mlpgeo(1).y)
mxT = mespacereel.Left
myT = mespacereel.Bottom
exitmetrique
End Sub
Public Sub OffsetReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
mespacereel.Bottom = mespacereel.Bottom + (y1 - y2)
mespacereel.Left = mespacereel.Left + (x1 - x2)
mespacereel.Right = mespacereel.Right + (x1 - x2)
mespacereel.Top = mespacereel.Top + (y1 - y2)
mxT = mespacereel.Left
myT = mespacereel.Bottom
End Sub
Public Sub zoomReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
If x1 = 0 And x2 = 0 And y1 = 0 And y2 = 0 Then Exit Sub
If (x2 - x1) > (y2 - y1) Then
zoomXReel x1, y1, x2, y2
Exit Sub
Else
zoomYReel x1, y1, x2, y2
Exit Sub
End If
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = DimensionEspaceLogique / (DistanceGEO(mlpgeo(0), mlpgeo(1)) *
10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub linereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long, Optional Mode As Long = 13)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
oldmode = SetROP2(mPicture.hdc, Mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap1)
dummy& = LineTo(mPicture.hdc, ap2.x, ap2.y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
Public Sub linepheriph(x1 As Single, y1 As Single, x2 As Single, y2 As
Single, couleur As Long, Optional Mode As Long = 13)
Dim ap(1) As POINTAPI
Dim OldPen&
Dim UsePen&
Dim dummy&
Dim oldmode&
ap(0).x = CLng(x1)
ap(0).y = CLng(y1)
ap(1).x = CLng(x2)
ap(1).y = CLng(y2)
setmetrique
oldmode = SetROP2(mPicture.hdc, Mode)
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
dummy& = DPtoLP(mPicture.hdc, ap(0), 2)
'Debug.Print "Xd " & Str(ap1.x) & " Yd " & Str(ap1.Y)
dummy& = MoveToEx&(mPicture.hdc, ap(0).x, ap(0).y, ap(0))
dummy& = LineTo(mPicture.hdc, ap(1).x, ap(1).y)
'Debug.Print "Xf " & Str(ap2.x) & " Yf " & Str(ap2.Y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
dummy& = SetROP2(mPicture.hdc, oldmode)
exitmetrique
End Sub
'---------------------------------------------------------------------------------------
' Procedure : DefiniCompteur
' DateTime : 18/09/03 11:49
' Author : VERGON Christophe
' Purpose : valeur min des x=0 calcul valeur max
'---------------------------------------------------------------------------------------
'
Public Function DefiniCompteur() As Long
Dim p1 As POINTGEO
Dim p As POINTAPI
p1.x = mespacereel.Right
p1.y = mespacereel.Bottom
p = RtoL(p1)
DefiniCompteur = p.x
End Function
'---------------------------------------------------------------------------------------
' Procedure : DefiniPasReal
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : Valeur de l'increment en x en fonction du zoom
'---------------------------------------------------------------------------------------
'
Public Function DefiniPasReal() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa1 As POINTAPI
Dim pa2 As POINTAPI
setmetrique
pa1.x = 0
pa2.x = 1
p1 = LtoR(pa1)
p2 = LtoR(pa2)
DefiniPasReal = p2.x - p1.x
exitmetrique
End Function
Public Function PixelScreen() As Double
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim pa(1) As POINTAPI
Dim dummy&
setmetrique
pa(0).x = 0
pa(0).y = 0
pa(1).x = 1
pa(1).y = 0
dummy& = DPtoLP(mPicture.hdc, pa(0), 2)
p1 = LtoR(pa(0))
p2 = LtoR(pa(1))
PixelScreen = p2.x - p1.x
exitmetrique
End Function
'---------------------------------------------------------------------------------------
' Procedure : DessinePointFonction
' DateTime : 18/09/03 11:50
' Author : VERGON Christophe
' Purpose : dessine le point réel P dans le DC avec la couleur Color
'---------------------------------------------------------------------------------------
'
Public Sub DessinePointFonction(x As Double, y As Double, Color As Long)
Dim p1 As POINTAPI
Dim p As POINTGEO
p.x = x
p.y = y
p1 = RtoL(p)
setmetrique
dummy& = SetPixelV(mPicture.hdc, p1.x, p1.y, Color)
exitmetrique
End Sub
Private Function DistanceGEO(p1 As POINTGEO, p2 As POINTGEO) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceGEO = Sqr(x * x + y * y)
End Function
Private Function DistanceAPI(p1 As POINTAPI, p2 As POINTAPI) As Double
Dim x, y As Double
x = p2.x - p1.x
y = p2.y - p1.y
DistanceAPI = Sqr(x * x + y * y)
End Function
Private Function PinRealRegion(p As POINTGEO, rgn As RECTGEO) As Boolean
Dim t As Double
If rgn.Left > rgn.Right Then
t = rgn.Left
rgn.Left = rgn.Right
rgn.Right = t
End If
If rgn.Bottom > rgn.Top Then
t = rgn.Bottom
rgn.Bottom = rgn.Top
rgn.Top = t
End If
If p.x < rgn.Left Then
PinRealRegion = False
Exit Function
Else
If p.x > rgn.Right Then
PinRealRegion = False
Exit Function
Else
If p.y < rgn.Bottom Then
PinRealRegion = False
Exit Function
Else
If p.y > rgn.Top Then
PinRealRegion = False
Exit Function
Else
PinRealRegion = True
End If
End If
End If
End If
End Function
Public Sub Refresh()
mPicture.Refresh
End Sub
Public Function writetext(MyText As String, x As Double, y As Double,
taille As Double, align As Long, angle As Double, affiche As Boolean)
Dim lf As LOGFONT
Dim oldfont&
Dim alignorigin&
Dim newfont&
Dim di&
Dim pointattache As POINTAPI
Dim pointlog As POINTAPI
Dim p As POINTGEO
Dim SI As Size
setmetrique
p.x = x
p.y = y
pointattache = RtoL(p)
p.x = x + taille
p.y = y + taille
pointlog = RtoL(p)
'Police logique courante par selection police systeme
oldfont& = SelectObject(mPicture.hdc, GetStockObject(0))
di& = GetObjectAPI(oldfont&, Len(lf), lf)
'rétablit la police de départ
di& = SelectObject(mPicture.hdc, oldfont&)
'stocke l'alignement d'origine
Select Case align
Case 0
alignorigin& = SetTextAlign(mPicture.hdc, TA_LEFT Or TA_BOTTOM Or
TA_UPDATECP)
Case 1
alignorigin& = SetTextAlign(mPicture.hdc, TA_RIGHT Or TA_BOTTOM Or
TA_UPDATECP)
Case 2
alignorigin& = SetTextAlign(mPicture.hdc, TA_CENTER Or TA_BOTTOM Or
TA_UPDATECP)
End Select
lf.lfHeight = pointlog.y - pointattache.y
lf.lfEscapement = -1 * Round(angle * 10, 0)
newfont& = CreateFontIndirect(lf)
oldfont& = SelectObject(mPicture.hdc, newfont&)
di& = GetTextExtentPoint32(mPicture.hdc, MyText, Len(MyText), SI)
mrectText.Bottom = pointattache.y
mrectText.Top = mrectText.Bottom + SI.cy
mrectText.Left = pointattache.x - SI.cx / 2
mrectText.Right = mrectText.Left + SI.cx
ConvertEspaceText
If affiche Then
di& = MoveToEx&(mPicture.hdc, pointattache.x, pointattache.y, pointlog)
di& = TextOut(mPicture.hdc, 0, 0, MyText, Len(MyText))
End If
di& = SelectObject(mPicture.hdc, oldfont&)
DeleteObject (newfont&)
exitmetrique
End Function
Public Property Get Espacereeltop() As Double
Espacereeltop = mespacereel.Top
End Property
Private Sub ConvertEspaceText()
Dim p As POINTGEO
Dim PL As POINTAPI
'doit etre appelé par une foncvtion ayant effectué setmetrique
PL.x = mrectText.Left
PL.y = mrectText.Bottom
p = LtoR(PL)
mespaceText.Left = p.x
mespaceText.Bottom = p.y
PL.x = mrectText.Right
PL.y = mrectText.Top
p = LtoR(PL)
mespaceText.Right = p.x
mespaceText.Top = p.y
End Sub
Public Property Get Espacereelleft() As Double
Espacereelleft = mespacereel.Left
End Property
Public Property Get Espacereelright() As Double
Espacereelright = mespacereel.Right
End Property
Public Property Get Espacereelbottom() As Double
Espacereelbottom = mespacereel.Bottom
End Property
Public Property Get echelle() As Double
echelle = mEchelle
End Property
Public Property Get xT() As Double
xT = mxT
End Property
Public Property Get yT() As Double
yT = myT
End Property
Public Property Get DimensionEspaceLogique() As Long
DimensionEspaceLogique = mDimensionEspaceLogique
End Property
Public Property Let DimensionEspaceLogique(ByVal vNewValue As Long)
mDimensionEspaceLogique = vNewValue 'DimensionEspaceLogique
End Property
Public Property Get Xencours() As Double
Xencours = mX
End Property
Public Property Get Yencours() As Double
Yencours = mY
End Property
Public Property Get XencoursPh() As Long
XencoursPh = mXph
End Property
Public Property Get yencoursph() As Double
yencoursph = mYph
End Property
Public Property Get XencoursLog() As Double
XencoursLog = mXlog
End Property
Public Property Get YencoursLog() As Double
YencoursLog = mYlog
End Property
Private Sub Class_Terminate()
Set mPicture = Nothing
End Sub
Public Property Get hdc() As Long
hdc = mPicture.hdc
End Property
Public Property Get Mousepointer() As Integer
Mousepointer = mPicture.Mousepointer
End Property
Public Property Let Mousepointer(ByVal Mousepointer As Integer)
mPicture.Mousepointer = Mousepointer
End Property
Public Function DefiniValPixel(AxeX As Boolean) As Double
setmetrique
ReDim lpPoint(2)
ReDim mlpgeo(2)
lpPoint(0).x = 0
lpPoint(0).y = 0
lpPoint(1).x = 1
lpPoint(1).y = 0
lpPoint(2).x = 0
lpPoint(2).y = 1
dummy& = DPtoLP(mPicture.hdc, lpPoint(0), 3)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mlpgeo(2) = LtoR(lpPoint(2))
exitmetrique
If AxeX Then
DefiniValPixel = Sqr((mlpgeo(1).x - mlpgeo(0).x) ^ 2 + (mlpgeo(1).y -
mlpgeo(0).y) ^ 2)
Else
DefiniValPixel = Sqr((mlpgeo(2).x - mlpgeo(0).x) ^ 2 + (mlpgeo(2).y -
mlpgeo(0).y) ^ 2)
End If
End Function
Public Property Get hwnd() As Long
hwnd = mPicture.hwnd
End Property
Public Sub zoomYReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = mYlogique / ((mlpgeo(1).y - mlpgeo(0).y) * 10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub zoomXReel(x1 As Double, y1 As Double, x2 As Double, y2 As
Double)
espaceclient
setmetrique
ReDim lpPoint(1)
ReDim mlpgeo(1)
mlpgeo(0).x = mespacereel.Left
mlpgeo(1).x = mespacereel.Right
mlpgeo(0).y = mespacereel.Bottom
mlpgeo(1).y = mespacereel.Top
lpPoint(0) = RtoL(mlpgeo(0))
lpPoint(1) = RtoL(mlpgeo(1))
ReDim mlpgeo(1)
mlpgeo(0).x = x1
mlpgeo(1).x = x2
mlpgeo(0).y = y1
mlpgeo(1).y = y2
mxT = x1
myT = y1
mEchelle = mXlogique / ((mlpgeo(1).x - mlpgeo(0).x) * 10 ^ 5)
mlpgeo(0) = LtoR(lpPoint(0))
mlpgeo(1) = LtoR(lpPoint(1))
mespacereel.Left = mlpgeo(0).x
mespacereel.Right = mlpgeo(1).x
mespacereel.Bottom = mlpgeo(0).y
mespacereel.Top = mlpgeo(1).y
exitmetrique
End Sub
Public Sub Cercle(x1 As Double, y1 As Double, rayon As Double, couleur As
Long)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
Dim r As RECTGEO
r.Bottom = mespacereel.Bottom
r.Left = mespacereel.Left
r.Right = mespacereel.Right
r.Top = mespacereel.Top
p1.x = x1
p1.y = y1
If PinRealRegion(p1, r) Then
If (r.Right - r.Left) < rayon Or (r.Top - r.Bottom) < rayon Then
Exit Sub
End If
Else
Exit Sub
End If
p1.x = x1 - rayon
p2.x = x1 + rayon
p1.y = y1 - rayon
p2.y = y1 + rayon
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
dummy& = Ellipse(mPicture.hdc, ap1.x, ap1.y, ap2.x, ap2.y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Sub pointreal(x As Double, y As Double, couleur As Long)
Dim p1 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
p1.x = x
p1.y = y
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x + 100, ap1.y)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x - 100, ap1.y)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x, ap1.y + 100)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap2)
dummy& = LineTo(mPicture.hdc, ap1.x, ap1.y - 100)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Sub CadreReal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim ap As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
dummy& = MoveToEx&(mPicture.hdc, ap1.x, ap1.y, ap)
dummy& = LineTo(mPicture.hdc, ap2.x, ap1.y)
dummy& = LineTo(mPicture.hdc, ap2.x, ap2.y)
dummy& = LineTo(mPicture.hdc, ap1.x, ap2.y)
dummy& = LineTo(mPicture.hdc, ap1.x, ap1.y)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Sub DessineCadreSelect(x1 As Double, y1 As Double)
Dim p1 As POINTGEO
Dim ap1 As POINTAPI
Dim ap As POINTAPI
Dim OldPen&, UsePen&
Dim dummy&
p1.x = x1
p1.y = y1
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, RGB(0, 0, 255))
OldPen& = SelectObject(mPicture.hdc, UsePen&)
ap1 = RtoL(p1)
dummy& = MoveToEx&(mPicture.hdc, ap1.x - 100, ap1.y - 100, ap)
dummy& = LineTo(mPicture.hdc, ap1.x - 100, ap1.y + 100)
dummy& = LineTo(mPicture.hdc, ap1.x + 100, ap1.y + 100)
dummy& = LineTo(mPicture.hdc, ap1.x + 100, ap1.y - 100)
dummy& = LineTo(mPicture.hdc, ap1.x - 100, ap1.y - 100)
dummy& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
exitmetrique
End Sub
Public Property Get Lastbottomtext() As Variant
Lastbottomtext = mespaceText.Bottom
End Property
Public Property Get Lastlefttext() As Variant
Lastlefttext = mespaceText.Left
End Property
Public Property Get Lasttoptext() As Variant
Lasttoptext = mespaceText.Top
End Property
Public Property Get Lastrighttext() As Variant
Lastrighttext = mespaceText.Right
End Property
Public Sub rectanglereal(x1 As Double, y1 As Double, x2 As Double, y2 As
Double, couleur As Long)
Dim p1 As POINTGEO
Dim p2 As POINTGEO
Dim ap1 As POINTAPI
Dim ap2 As POINTAPI
Dim lpPoint(3) As POINTAPI
Dim OldPen&, UsePen&
Dim oldbrush&, usebrush&
Dim dummy&
p1.x = x1
p1.y = y1
p2.x = x2
p2.y = y2
setmetrique
UsePen& = CreatePen(PS_SOLID, 1, couleur)
OldPen& = SelectObject(mPicture.hdc, UsePen&)
usebrush& = CreateSolidBrush(couleur)
oldbrush = SelectObject(mPicture.hdc, usebrush&)
ap1 = RtoL(p1)
ap2 = RtoL(p2)
lpPoint(0).x = ap1.x
lpPoint(0).y = ap1.y
lpPoint(1).x = ap2.x
lpPoint(1).y = ap1.y
lpPoint(2).x = ap2.x
lpPoint(2).y = ap2.y
lpPoint(3).x = ap1.x
lpPoint(3).y = ap2.y
dummy& = Polygon(mPicture.hdc, lpPoint(0), 4) 'Rectangle(mpicture.hdc,
ap1.x, ap1.y, ap2.x, ap2.y)
UsePen& = SelectObject(mPicture.hdc, OldPen&)
dummy& = DeleteObject(UsePen&)
usebrush& = SelectObject(mPicture.hdc, oldbrush)
dummy& = DeleteObject(usebrush)
exitmetrique
End Sub
Public Function CLS()
mPicture.CLS
End Function
