Hit-Parade .VB Research Center . Compteur
Accueil ~  Code ~  Programmes ~  Api ~  Forum ~  Cours ~  Livres ~  Quiz ~  Annuaire
~ Edito ~
12/03/2006 @ 13:39
Depuis la dernière mise à jour (qui remonte à... oulala plusieurs mois), un petit ménage de printemps s'impose. Ca tombe bien, c'est presque la période.
Au menu, et progressivement sur les jours à venir, rafraîchissement de plusieurs fonctions et procédures, nouvelles APIs et nouveaux programmes.

~ Rechercher ~

  

~ Annuaire VB ~
 Rechercher un site :
  

~ Partenaires ~

Divers : Figures
Permet d'orienter un dessin en calculant les coordonnées utiles, avec des exemples d'animations. Préparez vos planches à dessins! Un didacticiel par Cath.
Origine : Cath
(Consulté 21661 fois.)

L'idée est de permettre à un développeur d'orienter à peu près n'importe quel dessin (sans trop de prise de tête !) grâce à une routine de calcul - RPoint - qui renvoit les coordonnées utiles.
On peut ainsi facilement reproduire des polygones ou des ellipses et les animer. Figures est une démonstration interactive des calculs effectués par la routine RPoint.
RPoint fonctionne avec les paramètres suivants :
Rotation As Single
- Entrée de l'angle en radians
CentreX As Single, CentreY As Single
- Entrée des coordonnées du centre
X1 As Single, Y1 As Single
- Entrée des coordonnées du point auquel s'applique la rotation
X2 As Single, Y2 As Single
- Réponse de RPoint avec les coordonnées obtenues après rotation
Rayon As Single
- Réponse de RPoint avec le rayon du cercle de rotation
Ratio As Single
- Entrer 1 pour une rotation circulaire ou une autre valeur pour une ellipse

Vous trouverez également exemples d'animations giratoires :
- Pulsation en Anim 1
- Croisement d'ellipses en Démo 2
- Roue dentée en Anim 2
- Polygones réguliers en Démo 4
- Texte en étoile...

Figures est un exercice didactique réalisé par Cath. S'il vous a aidé ou agacé, adressez un mail à h.cathelineau@infonie.fr. Merci!

Copie d'écran de la fenêtre RPoints.frm

Cliquer ici pour télécharger le code complet.

' Figures est un exercice didactique réalisé par Cath
' S'il vous a aidé ou agacé, adressez un mail à h.cathelineau@infonie.fr
' Merci!

Private Declare Function GetTickCount& Lib "KERNEL32" ()

Private Declare Function FloodFill& Lib "gdi32" (_
               
ByVal hDestDC&, ByVal X1&, ByVal Y1&, ByVal Couleur&)

Private Sub Cmd_Click(Index As Integer)
Select Case
Index
 
Case 0
   
'Polygone
   
DemoPolygone
 
Case 6
   
Dim Msg As String, LRC As String
    Dim
I As Integer
    For
I = 0 To 10
      Text1(I).BackColor = QBColor(7)
   
Next
   
Text1(11).Visible = False
   
Text1(12).Visible = False
   
LRC = Chr$(13) & Chr$(10)
    Msg = LRC & " A propos de Figures..." & LRC & LRC
    Msg = Msg & " Démonstration des calculs de rotation de la routine RPoint." & LRC & LRC
    Msg = Msg & " - Go : Rotation de trois points paramétrables." & LRC
    Msg = Msg & " - Demo 1 : Polygone quelconque" & LRC
    Msg = Msg & " - Demo 2 : Ellipse" & LRC
    Msg = Msg & " - Demo 3 : Spirale" & LRC
    Msg = Msg & " - Demo 4 : Polygone régulier" & LRC & LRC
    Msg = Msg & " Par Cath" & LRC
    Msg = Msg & " h.cathelineau@infonie.fr" & LRC
    Me.Tag = "APropos"
    Picture1.BackColor = QBColor(15)
    Picture1.Cls
    Picture1.Print Msg
 
Case 7
   
'Animation
   
AnimPolygone
 
Case 1
   
'Test ellipse
   
DemoEllipse
 
Case 8
   
'Engrenage
   
AEngrenage
 
Case 5
   
'Demo Spirale
   
DemoSpirale
 
Case 2
    DemoPoints
   
'Go : Rotation de trois points
 
Case 3
    Picture1.Cls
 
Case 4
    Unload Me
   
End
  Case
9
   
'Texte
   
RTexte
 
Case 11
    RLettres
 
Case 10
    PolygoneRegul
 
Case Else
End Select
End Sub


Private Sub
Form_Activate()
Cmd_Click 6
End Sub

Private Sub
Form_Load()
Left = (Screen.Width - Width) \ 2
Top = (Screen.Height - Height) \ 2
End Sub

Private Sub
Text1_KeyPress(Index As Integer, KeyAscii As Integer)
If
KeyAscii = 13 Then
 
KeyAscii = 0
 
Select Case Me.Tag
   
Case "Démo1": DemoPolygone
   
Case "Démo2": DemoEllipse
   
Case "Démo3": DemoSpirale
   
Case "Anim1": AnimPolygone
   
Case "Anim2": AEngrenage
   
Case "Texte1": RTexte
   
Case "Démo4": PolygoneRegul
   
Case "Texte2": RLettres
   
Case "APropos"
   
Case Else: DemoPoints
 
End Select
End If
End Sub

Public Function
VirguleP$(Chaine As String)
A$ = Chaine
Z& = InStr(A$, ",")
If Z& > 0 Then
 
Mid$(A$, Z&) = "."
End If
VirguleP$ = A$
End Function


Public Sub
RPoint(Rotation As Single, CentreX As Single, CentreY As Single, _
                  X1
As Single, Y1 As Single, X2 As Single, Y2 As Single, _
                  Rayon
As Single, Ratio As Single)
Dim
AngleR As Double, Rapport As Double, PI As Double
Dim
CoteX As Single, CoteY As Single
PI = 3.14159265358979
CoteX = X1 - CentreX
If Ratio > 1 Then CoteX = CoteX * Ratio
CoteY = Y1 - CentreY
If Ratio < 1 Then CoteY = CoteY * (1 / Ratio)
If CoteX = 0 And CoteY = 0 Then
 
Rayon = 0
  X2 = X1
  Y2 = Y1
 
Exit Sub
End If
'Merci Pythagore
Rayon = Sqr(CoteX ^ 2 + CoteY ^ 2)
If CoteX <> 0 Then
 
Rapport = CoteY / CoteX
Else
 
Rapport = PI * 96
End If
AngleR = Atn(Rapport) + Rotation
If CoteX < 0 Or (CoteX = 0 And CoteY < 0) Then
 
AngleR = AngleR + PI
End If
X2 = Cos(AngleR) * Rayon
If Ratio > 1 Then X2 = X2 * (1 / Ratio)
X2 = X2 + CentreX
Y2 = Sin(AngleR) * Rayon
If Ratio < 1 Then Y2 = Y2 * Ratio
Y2 = Y2 + CentreY

End Sub

Public Sub
DemoEllipse()
Dim Plan As PictureBox
Dim Rotation As Single, Rayon As Single
Dim
CentreX As Single, CentreY As Single
Dim
Ecart As Single
Dim
Ratio As Single
Dim
Couleur As Long
Dim
Debut As Single, Fin As Single
Dim
PI As Double
Dim
RepAPI As Long
Dim
I As Integer
For
I = 0 To 9
  Text1(I).BackColor = QBColor(7)
Next
Text1(10).BackColor = vbWhite
Text1(11).Visible =
False
Text1(12).Visible = False
Set
Plan = Picture1
Plan.BackColor = QBColor(0)
Plan.Cls
Me.Tag = "Démo2"
PI = 3.14159265358979

CentreX = 200
CentreY = 170
Couleur = QBColor(Val(Text1(10).Text)
Mod 16)
'Rotation = (Val(VirguleP$(Text1(8).Text)) * PI) / 180
Rayon = 150
Ratio = 0.4

'Debut = PI / 2
'Fin = (3 * PI) / 2
'Fin = PI / 2
'Debut = (3 * PI) / 2
'Fin = PI + (PI / 4)
'Debut = (PI / 2) + (PI / 4)
Debut = 0
Fin = 0

'Plan.Circle (CentreX, CentreY), Rayon0, QBColor(7), , , Ratio0
'Plan.Circle (CentreX, CentreY), Rayon0, QBColor(9), Debut, Fin, Ratio0
Rotation = 0
Ecart = 0
'Plan.FillStyle = 0
'Plan.FillColor = Couleur
For I = 0 To 36
  Plan.Cls
  Rotation = Ecart
  REllipse Plan, CentreX, CentreY, Rayon, Debut, Fin, Ratio, Rotation, Couleur
 
'RepAPI = FloodFill(Plan.hDC, CentreX, CentreY, Couleur)
 
Rotation = (PI * 2) - Ecart
  REllipse Plan, CentreX, CentreY, Rayon, Debut, Fin, Ratio, Rotation, Couleur
  Plan.Refresh
  Retard 30
  Ecart = Ecart + (PI / 48)

Next


Set
Plan = Nothing

End Sub

Public Sub
DemoSpirale()
Dim Plan As PictureBox
Dim Rotation As Single, Rayon As Single, Rayon0 As Single
Dim
CentreX As Single, CentreY As Single
Dim
X1 As Single, Y1 As Single
Dim
X2 As Single, Y2 As Single
Dim
PX0 As Single, PY0 As Single
Dim
PX1 As Single, PY1 As Single
Dim
ACC As Single
Dim
Ratio0 As Single, RatioR As Single
Dim
Couleur As Long
Dim
Angle As Double, PI As Double
Dim
I As Integer
For
I = 0 To 9
  Text1(I).BackColor = QBColor(7)
Next
Text1(8).BackColor = vbWhite
Text1(10).BackColor = vbWhite
Text1(11).Visible =
False
Set
Plan = Picture1
Plan.BackColor = QBColor(0)
Plan.Cls
Plan.DrawWidth = 2
Me.Tag = "Démo3"
PI = 3.14159265358979
CentreX = 200
CentreY = 170
Rotation = (Val(VirguleP$(Text1(8).Text)) * PI) / 180
Rayon0 = 50
Ratio0 = 0.4
RatioR = 1
Couleur = QBColor(Val(Text1(10).Text)
Mod 16)
PX1 = -1
ACC = 0.05
For I = 0 To 2
  Angle = 0
  ACC = ACC + 0.1
 
Do
   
X1 = Cos(Angle) * Rayon0
   
If Ratio0 > 1 Then X1 = X1 * (1 / Ratio0)
    X1 = X1 + CentreX
    Y1 = Sin(Angle) * Rayon0
   
If Ratio0 < 1 Then Y1 = Y1 * Ratio0
    Y1 = Y1 + CentreY
    RPoint Rotation, CentreX, CentreY, X1, Y1, X2, Y2, Rayon, RatioR
   
If PX1 = -1 Then
     
PX0 = X2
      PY0 = Y2
   
Else
     
Plan.Line (X2, Y2)-(PX1, PY1), Couleur
   
End If
   
PX1 = X2
    PY1 = Y2
    Rayon0 = Rayon0 + ACC
   
If Angle = PI * 2 Then
      Exit Do
    End If
   
Angle = Angle + (PI / 100)
   
If Angle > (PI * 2) Then
     
Angle = PI * 2
   
End If
  Loop
Next
Plan.DrawWidth = 1
Set Plan = Nothing

End Sub

Public Sub
DemoPolygone()
Dim Plan As PictureBox
'Modifier pour affecter la variable Plan
'à une PictureBox autre que Picture1
Set Plan = Picture1
Dim Rotation As Single
Dim
CentreX As Single, CentreY As Single
Dim
PTX(3) As Single, PTY(3) As Single
Dim
PTRX(3) As Single, PTRY(3) As Single
Dim
Rayon As Single
Dim
PI As Double
Dim
Couleur As Long
Dim
RepAPI As Long
Dim
I As Integer, J As Integer
For
I = 0 To 1
  Text1(I).BackColor = vbWhite
Next
For
I = 2 To 9
  Text1(I).BackColor = QBColor(7)
Next
Text1(10).BackColor = vbWhite
Text1(11).Visible =
False
Text1(12).Visible = False
PI = 3.14159265358979
'Acquisition des paramètres
Couleur = QBColor(Val(Text1(10).Text) Mod 16)
CentreX = Val(Text1(0).Text)
CentreY = Val(Text1(1).Text)
Plan.BackColor = QBColor(0)
Plan.DrawWidth = 1
Plan.FillStyle = 0
Plan.FillColor = Couleur&
Plan.Cls
Me.Tag = "Démo1"
Rotation = 0
'Coordonnées du polygone
PTX(0) = CentreX + 160
PTY(0) = CentreY
PTX(1) = CentreX + 145
PTY(1) = CentreY - 18
PTX(2) = CentreX + 60
PTY(2) = CentreY
PTX(3) = CentreX + 145
PTY(3) = CentreY + 18
'Reproduire 24 fois la figure
For J = 0 To 23
 
For I = 0 To 3
    RPoint Rotation, CentreX, CentreY, PTX(I), PTY(I), PTRX(I), PTRY(I), Rayon, 1
   
If I > 0 Then
     
Plan.Line (PTRX(I - 1), PTRY(I - 1))-(PTRX(I), PTRY(I)), Couleur
   
End If
    If
I = 3 Then
     
Plan.Line (PTRX(3), PTRY(3))-(PTRX(0), PTRY(0)), Couleur
      RepAPI = FloodFill(Plan.hDC, (PTRX(0) + PTRX(2)) \ 2, _
                          (PTRY(0) + PTRY(2)) \ 2, Couleur&)
   
End If
  Next
I
 
'Retarder l'affichage pour la démonstration
 
Plan.Refresh
  Retard 25
  Rotation = Rotation + (PI / 12)
Next J
Plan.FillStyle = 1
Set Plan = Nothing

End Sub

Public Sub
AnimPolygone()
Dim Plan As PictureBox
Dim Rotation As Single
Dim
CentreX As Single, CentreY As Single
Dim
PTX(3) As Single, PTY(3) As Single
Dim
PTRX(3) As Single, PTRY(3) As Single
Dim
Rayon As Single
Dim
PI As Double
Dim
Couleur As Long, RepAPI As Long
Dim
I As Integer, J As Integer, K As Integer
Dim
EcartX As Integer, EcartY As Integer
For
I = 0 To 9
  Text1(I).BackColor = QBColor(7)
Next
Text1(10).BackColor = vbWhite
Text1(11).Visible =
False
Text1(12).Visible = False
PI = 3.14159265358979
CentreX = Val(Text1(0).Text)
CentreY = Val(Text1(1).Text)
Couleur = QBColor(Val(Text1(10).Text)
Mod 16)
'Modifier pour affecter la variable Plan
'à une PictureBox autre que Picture1
Set Plan = Picture1
Plan.BackColor = QBColor(15)
Plan.DrawWidth = 1
Plan.FillStyle = 0
Plan.FillColor = Couleur
Me.Tag = "Anim1"
'Coordonnées du polygone
PTX(0) = CentreX - 110
PTY(0) = CentreY
PTX(1) = CentreX - 95
PTY(1) = CentreY - 10
PTX(2) = CentreX - 10
PTY(2) = CentreY
PTX(3) = CentreX - 95
PTY(3) = CentreY + 10

For K = 1 To 14
  Retard 50
  Rotation = 0
 
If K < 9 Then
   
EcartX = -10
    EcartY = -1
 
Else
   
EcartX = 10
    EcartY = 1
 
End If
 
Plan.Cls
  PTX(0) = PTX(0) + EcartX
  PTX(1) = PTX(1) + EcartX
  PTY(1) = PTY(1) + EcartY
  PTX(2) = PTX(2) + EcartX
  PTX(3) = PTX(3) + EcartX
  PTY(3) = PTY(3) - EcartY
 
For J = 0 To 23
   
For I = 0 To 3
      RPoint Rotation, CentreX, CentreY, PTX(I), PTY(I), PTRX(I), PTRY(I), Rayon, 0.75
     
If I > 0 Then
       
Plan.Line (PTRX(I - 1), PTRY(I - 1))-(PTRX(I), PTRY(I)), QBColor(7)
     
End If
      If
I = 3 Then
       
Plan.Line (PTRX(3), PTRY(3))-(PTRX(0), PTRY(0)), QBColor(7)
        RepAPI = FloodFill(Plan.hDC, (PTRX(0) + PTRX(2)) \ 2, _
                            (PTRY(0) + PTRY(2)) \ 2, QBColor(7))
     
End If
    Next
I
    Rotation = Rotation + (PI / 12)
 
Next J
Next K
Plan.FillStyle = 1
Set Plan = Nothing

End Sub
Public Sub
Retard(RTD&)
T1& = GetTickCount&
Do
 
DoEvents
  T2& = GetTickCount&
 
If T2& < T1& Or T2& > T1& + RTD& Then Exit Do
Loop
End Sub

Public Sub
AEngrenage()
Dim Plan As PictureBox
Dim Rotation As Single, Rotation2 As Single
Dim
CentreX As Single, CentreY As Single
Dim
PTX(4) As Single, PTY(4) As Single
Dim
PTRX(4) As Single, PTRY(4) As Single
Dim
Rayon As Single, Ratio As Single
Dim
Rayon2 As Single
Dim
PI As Double
Dim
Couleur As Long
Dim
I As Integer, J As Integer, K As Integer
For
I = 0 To 9
  Text1(I).BackColor = QBColor(7)
Next
Text1(10).BackColor = vbWhite
Text1(11).Visible =
False
'PI = 3.141593
PI = 3.14159265358979
Couleur = QBColor(Val(Text1(10).Text)
Mod 16)

'Modifier pour affecter la variable Plan
'à une PictureBox autre que Picture1
Set Plan = Picture1
Plan.BackColor = QBColor(0)
Plan.DrawWidth = 1
Plan.FillStyle = 1
Plan.FillColor = Couleur
Me.Tag = "Anim2"
Plan.Cls
CentreX = 150
CentreY = 170
Rayon = 100
Ratio = 1
'CoordonnéeX du coloriage
X3& = CentreX - Rayon + 12
Y3& = CentreY
'Rayon du cercle intérieur
If Ratio > 1 Then
 
Rayon2 = (Rayon * Ratio) - (20 * Ratio)
Else
 
Rayon2 = Rayon - 20
End If
PTX(0) = CentreX - Rayon
PTY(0) = CentreY
RPoint (3 * PI) / 144, CentreX, CentreY, PTX(0), PTY(0), PTX(1), PTY(1), Rayon, Ratio
RPoint PI / 36, CentreX, CentreY, PTX(0) + 10, PTY(0), PTX(2), PTY(2), Rayon, Ratio
RPoint (7 * PI) / 144, CentreX, CentreY, PTX(0) + 10, PTY(0), PTX(3), PTY(3), Rayon, Ratio
RPoint PI / 18, CentreX, CentreY, PTX(0), PTY(0), PTX(4), PTY(4), Rayon, Ratio
Rotation2 = 0

For K = 1 To 50
  Plan.Cls
  Plan.FillStyle = 1
  Plan.Circle (CentreX, CentreY), Rayon2, Couleur, , , Ratio
  Rotation = Rotation2
 
For I = 1 To 36
   
For J = 0 To 4
      RPoint Rotation, CentreX, CentreY, PTX(J), PTY(J), PTRX(J), PTRY(J), Rayon, Ratio
     
If J > 0 Then
       
Plan.Line (PTRX(J - 1), PTRY(J - 1))-(PTRX(J), PTRY(J)), Couleur
     
End If
    Next
J
    Rotation = Rotation + PI / 18
 
Next I
  Plan.FillStyle = 0
  API& = FloodFill(Plan.hDC, X3&, Y3&, Couleur)
  Retard 50
  Rotation2 = Rotation2 + (PI / 72)
Next K
Plan.FillStyle = 1
Set Plan = Nothing

End Sub

Public Sub
RTexte()
Dim Plan As PictureBox
Dim RTxt As String
Dim
HTxt As Long, WTxt As Long
Dim
I As Integer
Dim
HY As Integer, WX As Integer
Dim
RX As Single, RY As Single
Dim
CX As Single, CY As Single
Dim
CX2 As Single, CY2 As Single
Dim
Rotation As Single, Rayon As Single, Ratio As Single
Dim
Couleur As Long
Dim
PI As Double
PI = 3.14159265358979
Me.Tag = "Texte1"
'Modifier pour affecter la variable Plan
'à une PictureBox autre que Picture1
Set Plan = Picture1
Plan.BackColor = QBColor(15)
Plan.Cls
For I = 0 To 9
  Text1(I).BackColor = QBColor(7)
Next
Text1(10).BackColor = vbWhite
Text1(11).Visible =
True
Text1(12).Visible = False
'Acquisition des paramètres
Couleur = QBColor(Val(Text1(10).Text) Mod 16)
Picture2.ForeColor = Couleur
Picture2.FontBold =
True
Picture2.FontSize = 14
RTxt = Text1(11).Text
If RTxt <> "" Then
 
HTxt = Picture2.TextHeight(RTxt)
  WTxt = Picture2.TextWidth(RTxt)
  Picture2.Height = HTxt
  Picture2.Width = WTxt
  Picture2.Cls
  Picture2.Print RTxt
  CX = -40
  CY = HTxt / 2
  Rotation = 0
 
For I = 0 To 15
   
For HY = 1 To HTxt - 1
     
For WX = 0 To WTxt - 1
       
If Picture2.Point(WX, HY) = Couleur Then
         
RPoint Rotation, CX, CY, CSng(WX), CSng(HY), RX, RY, Rayon, 1
          Plan.PSet (RX + 220, RY + 150), Couleur
       
End If
      Next
WX
   
Next HY
    Plan.Refresh
    Rotation = Rotation + (PI / 8)
 
Next I
End If
Set
Plan = Nothing
End Sub

Public Sub
PolygoneRegul()
Dim Plan As PictureBox
Dim Rotation As Single
Dim
CentreX As Single, CentreY As Single
Dim
RayonP As Single, Ratio As Single
Dim
PI As Double
Dim
RepAPI As Long
Dim
Couleur As Long
Dim
NbCotes As Long
Dim
I As Integer
For
I = 0 To 2
  Text1(I).BackColor = vbWhite
Next
For
I = 3 To 9
  Text1(I).BackColor = QBColor(7)
Next
Text1(10).BackColor = vbWhite
Text1(11).Visible =
False
Text1(12).Visible = True
PI = 3.14159265358979
'Modifier pour affecter la variable Plan
'à une PictureBox autre que Picture1
Set Plan = Picture1
Me.Tag = "Démo4"
'Acquisition des paramètres
CentreX = Val(Text1(0).Text)
CentreY = Val(Text1(1).Text)
RayonP = Val(Text1(2).Text)
Couleur = QBColor(Val(Text1(10).Text)
Mod 16)
NbCotes = Val(Text1(12).Text)
Plan.BackColor = QBColor(0)
Plan.DrawWidth = 1
Plan.FillStyle = 0
Plan.FillColor = Couleur
Plan.Cls
Ratio = 1
If NbCotes > 2 Then
 
'Donner l'angle du point de départ
  '(La formule suivante permet d'obtenir une base inférieure
  'horizontale pour tous les polygones)
 
Rotation = (PI / NbCotes) - PI / 2
  RPolygoneRegulier Plan, Rotation, Ratio, CentreX, CentreY, RayonP, NbCotes, Couleur
  RepAPI = FloodFill(Plan.hDC,
CLng(CentreX), CLng(CentreY), Couleur)
End If
Plan.FillStyle = 1
Set Plan = Nothing
End Sub

Public Sub
RPolygoneRegulier(Plan As PictureBox, Rotation As Single, Ratio As Single, _
                             CentreX
As Single, CentreY As Single, RayonP As Single, _
                             NbCotes
As Long, Couleur As Long)
Dim
I As Integer
Dim
X1 As Single, Y1 As Single
Dim
RX() As Single, RY() As Single
Dim
PI As Double
ReDim
RX(NbCotes), RY(NbCotes)
PI = 3.14159265358979
X1 = CentreX - RayonP
Y1 = CentreY

For I = 1 To NbCotes
 
'Calcul des coordonnées du point RX(I), RY(I)
 
RPoint Rotation, CentreX, CentreY, X1, Y1, RX(I), RY(I), 0, Ratio
 
If I > 1 Then
   
Plan.Line (RX(I - 1), RY(I - 1))-(RX(I), RY(I)), Couleur
 
End If
  If
I = NbCotes Then
   
Plan.Line (RX(I), RY(I))-(RX(1), RY(1)), Couleur
 
End If
 
'Calcul de l'angle du point suivant
 
Rotation = Rotation + ((PI * 2) / NbCotes)
Next I

End Sub

Public Sub
RLettres()
Dim Plan As PictureBox
Dim RTxt As String, Lettre As String
Dim
HTxt As Long, WTxt As Long, WLettre As Long
Dim
I As Integer, J As Integer
Dim
X1 As Single, Y1 As Single
Dim
HY As Integer, WX As Integer
Dim
RX As Single, RY As Single
Dim
CX As Single, CY As Single
Dim
CX2 As Single, CY2 As Single
Dim
Rotation As Single, Rayon As Single, Ratio As Single
Dim
Rotation2 As Single
Dim
Couleur As Long
Dim
PI As Double
PI = 3.14159265358979
Me.Tag = "Texte2"
'Modifier pour affecter la variable Plan
'à une PictureBox autre que Picture1
Set Plan = Picture1
Plan.BackColor = QBColor(15)
Plan.Cls
For I = 0 To 9
  Text1(I).BackColor = QBColor(7)
Next
Text1(10).BackColor = vbWhite
Text1(11).Visible =
True
Text1(12).Visible = False
Couleur = QBColor(Val(Text1(10).Text) Mod 16)
Picture2.ForeColor = Couleur
Picture2.FontSize = 36
Picture2.FontBold =
True
RTxt = Text1(11).Text
HTxt = Picture2.TextHeight(RTxt)
WTxt = Picture2.TextWidth(RTxt)
If RTxt <> "" Then
 
X1 = 80
  Y1 = 150
  Rotation = 0
 
For J = 1 To Len(RTxt)
    Lettre = Mid$(RTxt, J, 1)
    WLettre = Picture2.TextWidth(Lettre) - 1
    Picture2.Height = HTxt
    Picture2.Width = WLettre
    Picture2.Cls
    Picture2.Print Lettre
   
'If J > 1 Then
     
Rotation = Rotation + ((PI * (WLettre / 2)) / WTxt)
   
'End If
   
CX = 0
    CY = HTxt
   
If Lettre <> " " Then
     
Rotation2 = Rotation - (PI / 2)
     
For HY = 1 To HTxt - 1
       
For WX = 0 To WLettre
         
If Picture2.Point(WX, HY) = Couleur Then
           
RPoint Rotation2, CX, CY, CSng(WX), CSng(HY), RX, RY, Rayon, 1
            Plan.PSet (RX + X1, RY + Y1), Couleur
         
End If
        Next
WX
     
Next HY
   
End If
   
Plan.Refresh
   
'If J = 1 Then
    ' Rotation = Rotation + ((PI * WLettre) / WTxt)
    'Else
     
Rotation = Rotation + ((PI * (WLettre / 2)) / WTxt)
   
'End If
   
RPoint Rotation, 200, 150, 80, 150, RX, RY, Rayon, 1
    X1 = RX
    Y1 = RY
 
Next J
End If

Set
Plan = Nothing

End Sub

Public Sub
DemoPoints()
Dim Plan As PictureBox
Dim Rotation As Single
Dim
CentreX As Single, CentreY As Single
Dim
PTX(2) As Single, PTY(2) As Single
Dim
PTRX(2) As Single, PTRY(2) As Single
Dim
PI As Double, Rayon As Single
Dim
Ratio As Single, Angle As Double
Dim
Couleur As Long
Dim
I As Integer, J As Integer
For
I = 0 To 10
  Text1(I).BackColor = vbWhite
Next
Text1(11).Visible = False
Text1(12).Visible = False
PI = 3.14159265358979
'Modifier pour affecter la variable Plan
'à une PictureBox autre que Picture1
Set Plan = Picture1
Plan.BackColor = QBColor(15)
Plan.DrawWidth = 1
Plan.FillStyle = 1
If Me.Tag <> "Go" Then
 
Plan.Cls
  Me.Tag = "Go"
End If
'Acquisition des paramètres
CentreX = Val(Text1(0).Text)
CentreY = Val(Text1(1).Text)
Rotation = (Val(VirguleP$(Text1(8).Text)) * PI) / 180
Ratio = Val(VirguleP$(Text1(9).Text))
Couleur = QBColor(Val(Text1(10).Text)
Mod 16)
'Calcul des coordonnées,
'Montrer les cercles correspondants
J = 2
For I = 0 To 2
  PTX(I) = Val(Text1(J).Text)
  J = J + 1
  PTY(I) = Val(Text1(J).Text)
  J = J + 1
  RPoint Rotation, CentreX, CentreY, PTX(I), PTY(I), PTRX(I), PTRY(I), Rayon, Ratio
  Plan.Circle (CentreX, CentreY), Rayon, QBColor(7), , , Ratio
  Plan.Circle (PTX(I), PTY(I)), 2, QBColor(7), , , Ratio
  Plan.Circle (PTRX(I), PTRY(I)), 2, Couleur, , , Ratio
Next
'Relier les points
For I = 0 To 2
  J = I + 1
 
If J = 3 Then J = 0
  Plan.Line (PTX(I), PTY(I))-(PTX(J), PTY(J)), QBColor(7)
  Plan.Line (PTRX(I), PTRY(I))-(PTRX(J), PTRY(J)), Couleur
Next
Set
Plan = Nothing

End Sub

Public Sub
REllipse(Plan As PictureBox, CentreX As Single, CentreY As Single, _
                    Rayon
As Single, Debut As Single, Fin As Single, Ratio As Single, _
                    Rotation
As Single, Couleur As Long)
Dim
X1 As Single, Y1 As Single
Dim
X2 As Single, Y2 As Single
Dim
PX0 As Single, PY0 As Single
Dim
PX1 As Single, PY1 As Single
Dim
Tour As Boolean
Dim
PI As Double
Dim
AngleD As Double, AngleF As Double
PI = 3.14159265358979
If Debut = Fin Then
 
AngleD = 0
  AngleF = PI * 2
  Tour =
True
Else
 
AngleD = (PI * 2) - Fin
  AngleF = (PI * 2) - Debut
 
If AngleF < AngleD Then AngleF = AngleF + (PI * 2)
End If
PX1 = -1
Do
 
X1 = Cos(AngleD) * Rayon
 
If Ratio > 1 Then X1 = X1 * (1 / Ratio)
  X1 = X1 + CentreX
  Y1 = Sin(AngleD) * Rayon
 
If Ratio < 1 Then Y1 = Y1 * Ratio
  Y1 = Y1 + CentreY
  RPoint Rotation, CentreX, CentreY, X1, Y1, X2, Y2, 0, 1
 
If PX1 = -1 Then
   
PX0 = X2
    PY0 = Y2
 
Else
   
Plan.Line (PX1, PY1)-(X2, Y2), Couleur
 
End If
 
PX1 = X2
  PY1 = Y2
 
If AngleD = AngleF Then Exit Do
 
AngleD = AngleD + (PI / 90)
 
If AngleD > AngleF Then AngleD = AngleF
Loop
If
Tour Then
 
Plan.Line (PX1, PY1)-(PX0, PY0), Couleur
End If

End Sub
Visual Basic Research Center - (c) 2000/2002 -  Webmaster : docvb (chez) free (point) fr