Loupe optique

Soyez le premier à donner votre avis sur cette source.

Vue 9 343 fois - Téléchargée 926 fois

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!

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

Codes Sources

A voir également

Ajouter un commentaire Commentaires
Messages postés
395
Date d'inscription
jeudi 26 août 2004
Statut
Membre
Dernière intervention
19 juin 2009
1
pour tes remarque sur les vidéo et le graphisme : JE SUIS NUL en graphisme alors si tume le fait ok sinon ! tant pis , mais je suis entrai de récolté tout les capture vidéo de SGA ou l'on voie leur ordi , ya plus qu'a (je pense prendre quand même deux a trois bon mois pour fair tout ca !!)
Messages postés
395
Date d'inscription
jeudi 26 août 2004
Statut
Membre
Dernière intervention
19 juin 2009
1
pour le super interface de SG1 je te conseil : www.SGSim.com
il ont fais un truc super en flash
Moi je bosse sur altantis!

Pour les glyph faut aller sur membres.lycos.fr/sgapc Car le zip est trops volumineux pour CS

voila , bonne continuation
Messages postés
1488
Date d'inscription
mercredi 5 février 2003
Statut
Membre
Dernière intervention
3 décembre 2007
24
LOL, Clair!!!
Je me bats aussi contre les copyrights alors que toutes mes sources en sont bourrées!!!
Mais... tu sais ce qu'on dit Nico... Faites c'que j'dis et pas c'que fait ;-) mdr

En fait, pour la loupe, j'avais pas fait gaffe que j'avais mis tout le code ici!!!

Oh, dès que j'aurais le temps je mettrais à jour toutes mes sources d'un coup pi je rajouterais également toutes celles qui trainnent dans mes fonds de tiroirs qui sont plus fun que les classiques de CS...

Dit, au fait SG1, j'ai toujours pas pu téléchargé ton zip avec les glyphs!!! Il est pourri... CRC... !!! Donc, a l'occase, stp, met à jour ce file... j'ai hate de voir ça!

Ceci dit, je me demande si t'es un assez bon fan pour avoir reproduit exactement l'interface que le QG de SG1 utilise ??? Il me semble que non !!! ;-\

Ceci dit, je suis toujours convinqu qu'il faut utiliser une gif ou, tout du moins, une anime graphique (bitmap et pas vectorielle) pour l'ouverture/fermeture de la porte et qu'il faut lui ajouter aussi son bouclier (pour pas que les méchants virus du C++ ne passe dans nos gentils PC pur VB ;-).

Allez, @++
Signé : un autre fan de cette superbe série déjà hyper culte et novatrice!
Messages postés
395
Date d'inscription
jeudi 26 août 2004
Statut
Membre
Dernière intervention
19 juin 2009
1
et apres tu dis que mon code est trops long et qu'il faut pas le mettre :( lol !!

Le créateur de la Stargate sur vbfrance !!
Messages postés
1488
Date d'inscription
mercredi 5 février 2003
Statut
Membre
Dernière intervention
3 décembre 2007
24
Ca fait plaisir de ne pas être le seul dans ce cas... :-)
Afficher les 14 commentaires

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.