Figures - rotation de graphiques

Télécharger le projet
Commenter

Description

Figures - Démonstration graphique des rotations de points, de polygones ou d'ellipses.

Source / Exemple : 


'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
'_____________________________________________
'
'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 = True Then
  Plan.Line (PX1, PY1)-(PX0, PY0), Couleur
End If

End Sub
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.