Loupe optique
Description
Une loupe "optique" pour les nuls. Le code est hyper commenté afin d'apprendre plein de trucs (mnémoniques, techniques, ...).
Je dis "optique" mais en réalité ce n'est pas tout à fait le cas. Disons plutôt que c'est une loupe informatique avec effet volumique.
Ce prog nécessite une bonne bécane ou alors une bonne dose de patience...
Le tout est dans le zip alors, amusez-vous bien!
Je dis "optique" mais en réalité ce n'est pas tout à fait le cas. Disons plutôt que c'est une loupe informatique avec effet volumique.
Ce prog nécessite une bonne bécane ou alors une bonne dose de patience...
Le tout est dans le zip alors, amusez-vous bien!
Source / Exemple :
'#####################################
'#---------- UTILISATION ----------#
'#####################################
'# Touche "Echape" pour Quitter #
'# Cliquer en maintenant #
'# - le bouton Gauche : Loupe #
'# - le bouton Droit : Sphère #
'#####################################
'# [scsami@yahoo.fr - Freeware 2005] #
'#####################################
'??? COMMENT CA MARCHE ???
'On utilise une fenêtre sans bords (BorderStyle=vbBSNone)
' avec un "PictureBox" DESSUS qui, lui non plus, n'a pas
' de bords. Le PictureBox aura la même taille que celle
' de la fenêtre et donc, on ne verra que le PictureBox
' et non la fenêtre.
'Lorsqu'on déplace la souris en étant sur la fenêtre
' (c.a.d. en fait, sur le PictureBox puisque la fenêtre
' est intégralement recouverte par lui...)
' on récupère les coordonnées absolues (c.a.d. par rapport
' à l'écran et non par rapport à la fenêtre) via l'API
' GetCursorPos, et avec ces coordonnées, on centre la
' fenêtre dessus (uniquement si la souris bouge donc).
'Ensuite, on capture l'image de l'écran et on la place
' comme image de fond de la fenêtre (propriété "Picture"
' de la fenêtre). Le PictureBox cachant la fenêtre,
' l'utilisateur ne verra pas cette image!
'Ensuite, toujours dans cette procédure, on récupère les
' pixels formant une sphère à partir de l'image de la fenêtre et
' on les copient, de manière linéaire, dans le PictureBox.
'Enfin, si on veux une loupe parce que si le bouton de la souris
' est le droit, on dessinera une sphère.
'Le mystère de la déformation réside dans quelque formules
' trigonomériques assez simple si on replace le problème en
' 3D... Mais là, je laisse votre intelligence le décortiquer...
'Déclarations des API (N.B.: Ne rien modifier)
'GetCursorPos permet de récupérer les coordonnées absolues
' de la position de la souris sur l'écran (et non sur la fenêtre)
'Déclaration d'un Type Utilisateur utilisé par l'API
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'GetDC fait référence à l'image affichée actuellement à l'écran.
' c.a.d. l'image obtenue par une capture d'écran.
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'Equivalent de la méthode VB "PaintPicture" mais en plus rapide.
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
'Equivalent à la méthode VB "pset"
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
'Equivalent à la méthode VB "point"
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
'Déclaration d'une variable évitant l'effet de récurrence.
' Permet de ne pas ré-apeller une fonction qui n'est pas
' encore terminée...
Private varAntiRecursif As Boolean
'Déclaration de la constante PI.
Private Const PI As Single = 3.14159265358979
'Fonctions de convertions d'angles :
' Toutes les fonctions trigonométriques du VB
' fonctionnent en radians alors qu'on utilise ici
' les degrés...
' (c.f. MSDN[l'aide du VB] rubrique COS ou SIN)
'Convertie des Radians en Degrés
Private Function RadDeg(ByVal RadAngle As Single) As Single
RadDeg = RadAngle * (180 / PI)
End Function
'Convertie les Degrés en Radians
Private Function DegRad(ByVal DegAngle As Single) As Single
DegRad = DegAngle * (PI / 180)
End Function
'(c.f. MSDN[l'aide du VB] rubrique
' "fonctions mathématiques dérivées")
'ArcSinus (l'inverse du Sinus : renvoie un angle à partir du sinus...)
Private Function ArcSin(ByVal SinVal As Single) As Single
If SinVal = 1 Then
ArcSin = 0 'Corrige l'erreur de division par 0
Else
ArcSin = Atn(SinVal / Sqr(-SinVal * SinVal + 1))
End If
'Affecte le résultat de sortie de/à la fonction
ArcSin = RadDeg(ArcSin)
End Function
'ArcCosinus (l'inverse du Cosinus : renvoie un angle à partir du cosinus...)
Private Function ArcCos(ByVal CosVal As Single) As Single
If CosVal = 1 Then
ArcCos = 0 'Corrige l'erreur de division par 0
Else
ArcCos = Atn(-CosVal / Sqr(-CosVal * CosVal + 1)) + 2 * Atn(1)
End If
'Affecte le résultat de sortie de/à la fonction
ArcCos = RadDeg(ArcCos)
End Function
Private Sub Form_Load()
'####################################
'####################################
'MODIFIEZ ICI LA VALEUR PAR DEFAUT
'DE LA TAILLE DE LA SPHERE
varRayon = 50
' N.B.: Plus il est petit, plus le prog irra vite!
'####################################
'####################################
'Définit par défaut la taille de la fenêtre
' selon le diamètre du cercle (rayon*2) en pixels.
' La taille exterieur des fenêtre est toujours en Twips...
' (N.B.: pixels * 15 = twips)
' (N.B.: "Me" remplace le nom de la fenêtre au cas où
' il changerait d'ici la fin de l'écriture de ce prog.
' Donc, vous pouvez renommer la fenêtre à votre gré...)
Me.Width = (varRayon * 2) * 15
Me.Height = (varRayon * 2) * 15
'On redimensionne le PictureBox pour qu'il ait la même
' taille que la fenêtre.
Picture1.ScaleMode = vbPixels
Picture1.Left = 0
Picture1.Top = 0
Picture1.Width = Me.ScaleWidth
Picture1.Height = Me.ScaleHeight
Me.Show
DoEvents
varAntiRecursif = False
'On initialise manuellement l'affichage
' pour la première fois...
Call Picture1_MouseMove(2, 0, 0, 0)
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'Keycode représente le code de la touche. Pour l'identifier
' on utilise ici des constantes du VB pour se simplifier la vie.
'ATTENTION : Cette procédure ne se lancera que si la propriété
' "KeyPreview" de la fenêtre est "True". Sinon c'est le PictureBox
' qui recevra l'événement...
If KeyCode = vbKeyEscape Then End
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Si aucun bouton n'est enfoncé, on resort
' immédiatement de cette procédure événementielle.
If Button = 0 Then Exit Sub
'Si AntiRecursif est True, la fonction est déjà
' en activité et ne peut être rappelée donc
' on sort de la procédure. Sinon, on l'exécute.
If varAntiRecursif = True Then Exit Sub
'Puisqu'elle vas être exécutée, on active l'anti-récursivité.
varAntiRecursif = True
'Si on bouge, qu'importe le bouton enfoncé,
' on déplace la fenêtre selon la position
' absolue du curseur puis on fait une capture d'écran
'Déclare la variable qui contiendra la position
' absolue de la souris.
'"Static" pour ne pas avoir à la redéclarer
' à chaque fois que cette procédure événementielle
' est exécutée (puisqu'elle est très couramment appelée).
Static MouseScreenPosition As POINTAPI
'On récupère la position absolue de la souris par rapport
' à l'écran en appelant une fonction API. Cette fonction
' retourne "False" si il y a eut une erreur. Sinon, elle
' retourne "True". Si elle revoie "False", on quitte la
' procédure sans traiter l'erreur. Mais on pensera à
' désactiver l'anti-récursivité avant de la quitter.
If GetCursorPos(MouseScreenPosition) = False Then
varAntiRecursif = False
Exit Sub
End If
'Avant de capturer une image il faut cacher la fenêtre
' afin qu'elle n'apparaisse pas dans la capture.
Me.Visible = False
'Il faut laisse à Windows le temps de la masquer. Donc,
' on lui redonne la main durant un instant.
DoEvents
'Maintenant, on capture la portion voulue de l'image
' et on la place comme image d'arrière plan de la fenêtre.
StretchBlt Me.hdc, _
0, 0, _
Me.ScaleWidth, Me.ScaleHeight, _
GetDC(0), _
(Me.Left / 15), (Me.Top / 15), _
Me.ScaleWidth, Me.ScaleHeight, _
vbSrcCopy
'<ICI ON POURRAIT TRAITER LA DISTORTION>
'mais pour voir où elle en est, il vaut mieux,
' pour l'exemple, la mettre après...
'On réaffiche la fenêtre
Me.Visible = True
'On centre la fenêtre sur la souris. Mais attention,
' les valeurs attribuées à la fenêtre doivent être en
' twips alor que les valeurs de la souris sont en pixels.
' (N.B.: "Me" remplace le nom de la fenêtre au cas où
' il changerait d'ici la fin de l'écriture de ce prog.
' Donc, vous pouvez renommer la fenêtre à votre gré...)
Me.Left = (MouseScreenPosition.X * 15) - (Form1.Width / 2)
Me.Top = (MouseScreenPosition.Y * 15) - (Form1.Height / 2)
'MAINTENANT ON APPLIQUE UN DES DEUX EFFETS :
'en fonction du bouton de la souris qui est
'maintenu enfoncé :
'- Bouton Gauche : Effet Loupe
'- Bouton Droite : Effet Sphère
'Initialisations :
Static CentreXduCercle As Single
Static CentreYduCercle As Single
Static RayonDuCercle As Single
Static ScanneX As Single
Static ScanneY As Single
Static RayonDuPoint As Single
Static xx As Single
Static yy As Single
Static NouveauRayonDuPoint As Single
Static Hauteur As Single
Static AngleDeg As Single
Static AngleRad As Single
Static Cosinus As Single
Static CosinusDelAngle As Single
Static SinusDelAngle As Single
Static CouleurRGB As Long
'Le centre du cercle est le pointeur de la souris.
'C.a.d. la moitié de la fenêtre dans les 2 sens...
' Le tout en pixels puisque l'attribut "ScaleMode"
' de la fenêtre l'est aussi.
CentreXduCercle = Me.ScaleWidth / 2
CentreYduCercle = Me.ScaleHeight / 2
RayonDuCercle = CentreXduCercle
'On n'a pas besoin d'effacer le contenu graphique
' du PictureBox puisqu'on repasse dessus.
'Picture1.Cls
'L'ALGORITHME :
'On fait un "scanne" carré de la surface du cercle
' X1 X2 X3 X4
' Y1 1 2 3 4
' Y2 5 6 7 8
' .. . . . . ...
For ScanneY = 1 To (RayonDuCercle * 2)
For ScanneX = 1 To (RayonDuCercle * 2)
'Calcul le rayon qui sépare le point (tt,t) du centre
' du cercle via Pythagore... (cours de 4ème-3ème au collège
' (N.B.: Commun aux 2 modes d'affichage...)
RayonDuPoint = Sqr((Abs(RayonDuCercle - ScanneX) ^ 2) + (Abs(RayonDuCercle - ScanneY) ^ 2))
'Détecte le bouton de la souris qui
' est maintenu afin de déterminer le
' mode d'affichage.
If Button = 2 Then 'Bouton Droit : mode "Sphere"
If RayonDuPoint >= RayonDuCercle Then
'Tous pixels hors du (rayon) cercle.
'On récupère la couleur du pixel arrière
'c.a.d. celui placé dans la fenêtre et ce
'en utilisant l'API correspondant au code VB :
'CouleurRGB = Me.Point(ScanneX - 1, ScanneY - 1)
CouleurRGB = GetPixel(Me.hdc, (ScanneX - 1), (ScanneY - 1))
ElseIf RayonDuPoint = 0 Then
'Cas particulier pour éviter la division par 0
' du calcul du Cosinus quand le point est à la
' verticale du centre.
Hauteur = 255 'Maximum pour les couleurs...
'Génère la couleur RVB(en 24 bits) en nuances de gris (R=V=B)
CouleurRGB = RGB(Hauteur, Hauteur, Hauteur)
Else
'Calcul l'angle de la profondeur du point
'Calcul du cosinus de cet ange
Cosinus = RayonDuPoint / RayonDuCercle
'Transforme le Cosinus en angle
AngleDeg = ArcSin(Cosinus)
'Convertis l'ange en radians
AngleRad = DegRad(AngleDeg)
'Calcul la hauteur...
Hauteur = Abs(255 * Cos(AngleRad))
'Génère la couleur RVB(en 24 bits) en nuances de gris (R=V=B)
CouleurRGB = RGB(Hauteur, Hauteur, Hauteur)
End If
'Affiche le point "ScanneX ; ScanneY" sur le PictureBox
' en utilisant l'API correspondant au code VB :
'Picture1.PSet (ScanneX - 1, ScanneY - 1), CouleurRGB
SetPixel Picture1.hdc, (ScanneX - 1), (ScanneY - 1), CouleurRGB
Else
'Bouton Gauche ou les deux à la fois : mode "Loupe"
If RayonDuPoint > RayonDuCercle Then
'Dans le cas de tous les pixels hors du cercle
xx = ScanneX
yy = ScanneY
ElseIf RayonDuPoint = 0 Then
'Si le rayon du point est 0 (donc, au centre)
xx = CentreXduCercle
yy = CentreYduCercle
Else 'Si le point n'est pas au centre
AngleRad = DegRad(ArcSin(RayonDuPoint / RayonDuCercle))
Hauteur = Abs(Cos(AngleRad))
'Rayon du point dont il faut récupérer la couleur
' selon la déformation de la loupe...
' Il se trouve sur le segment débutant au centre
' du cercle et se terminant sur le périmètre du cercle
' passant (le segment) par le point du Scanne.
' Autrement dit, il se trouve sur le rayon du point
' a une distence du centre relative à la hauteur du même point.
NouveauRayonDuPoint = Abs(RayonDuCercle * (1 - Hauteur))
CosinusDelAngle = ((((CentreXduCercle - RayonDuCercle) _
+ ScanneX) - CentreXduCercle) / RayonDuPoint)
SinusDelAngle = ((((CentreYduCercle - RayonDuCercle) _
+ ScanneY) - CentreYduCercle) / RayonDuPoint)
'Méthode classique du dessin d'un cercle...
xx = CentreXduCercle + (NouveauRayonDuPoint * CosinusDelAngle)
yy = CentreYduCercle + (NouveauRayonDuPoint * SinusDelAngle)
End If
If Fix(RayonDuPoint) = RayonDuCercle - 1 Then
'Dans le cas des pixels du contour du cercle :
CouleurRGB = 0
'N.B.: C'est pour pouvoir voir le cercle si tous
' les pixels ont la même couleur...
Else
'Récupère la couleur de ce point sur le fond de la fenêtre
'en utilisant l'API correspondant au code VB :
'CouleurRGB = Me.Point(xx - 1, yy - 1)
CouleurRGB = GetPixel(Me.hdc, (xx - 1), (yy - 1))
End If
'Affiche le point "ScanneX ; ScanneY" sur le PictureBox
' en utilisant l'API correspondant au code VB :
'Picture1.PSet (ScanneX - 1, ScanneY - 1), CouleurRGB
SetPixel Picture1.hdc, (ScanneX - 1), (ScanneY - 1), CouleurRGB
End If 'Fin du test des boutons
Next ScanneX
Next ScanneY
'Fin du scan
'Avant de quitter la procédure, il ne faut pas
' oublier de désactiver l'anti-récursivité car
' autrement on ne pourra plus rappeler cette procédure!
varAntiRecursif = False
End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.