LISSAGE D'UNE COURBE DÉFINIT PAR DES POINTS (SUBDIVISION)

Private Type PointsV
    X As Integer
    Y As Integer
End Type

Dim NmbPoint As Integer

Dim I As Integer

Dim Points() As PointsV

Sub DrawCourbe()
On Error Resume Next
'---Affiche la courbe
Pic.Cls
For I = 0 To NmbPoint - 1
    '---Affiche le point rouge
    Pic.DrawWidth = 5
    Pic.ForeColor = vbRed
    Pic.PSet (Points(I).X, Points(I).Y)
    '---Affiche la ligne
    Pic.DrawWidth = 1
    Pic.ForeColor = vbWhite
    Pic.Line (Points(I).X, Points(I).Y)-(Points(I + 1).X, Points(I + 1).Y)
Next
End Sub

Sub Subdivise()
On Error Resume Next
'---Calcul la nouvelle courbe
Dim W As Single
'---W est le facteur de tension appartenant à l'interval [0,1]
'   plus W est proche de 0, plus la courbe finale ressemblera à la courbe originelle
'   plus W est proche de 1, plus la courbe finale sera rectiligne

W = 0.5
'---Redimensionne la structure de la grille pour stocker les nouveaux points
ReDim Preserve Points(2 * NmbPoint - 1)
For I = NmbPoint-1 To 0 Step -1
'---Replace les points deja présents dans la nouvelle structure
    Points(2 * I) = Points(I)
'---Créé les nouveaux points par interpolation, le nouveau point se trouve
'   au milieu du segment délimité par le point (I)=(2 * I) et le point (I - 1)
    Points(2 * I - 1).X = Int((Points(I).X + Points(I - 1).X) / 2)
    Points(2 * I - 1).Y = Int((Points(I).Y + Points(I - 1).Y) / 2)
'---Déplace les points deja présents
    Points(2 * I).X = Points(2 * I).X * (1 - W) + W / 2 * (Points(2 * I - 1).X + Points(2 * I + 1).X)
    Points(2 * I).Y = Points(2 * I).Y * (1 - W) + W / 2 * (Points(2 * I - 1).Y + Points(2 * I + 1).Y)
Next
NmbPoint = UBound(Points) + 1
DrawCourbe
End Sub

Private Sub Command1_Click()
    Subdivise
End Sub

Private Sub Pic_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'---Click pour créer un point
    ReDim Preserve Points(NmbPoint)
    Points(NmbPoint).X = X
    Points(NmbPoint).Y = Y
    NmbPoint = NmbPoint + 1
    DrawCourbe
End Sub