Farbverlauf me

Public Sub Farbverlauf(Name As Object)
  Dim FrmDraw As Boolean
  Dim Beginn As Integer
  Dim b As Integer, h As Integer
  Dim X As Double, XX As Double
  Dim AktuelleFarbe As Long
 
  On Error GoTo err
 
    FrmDraw = Name.AutoRedraw
    Name.AutoRedraw = True
    b = Name.ScaleWidth        'Breite
    h = Name.ScaleHeight       'Höhe
    Name.Cls
 
    ' Farbübergang
    Select Case Richtung
 
      ' Horizontal; 0 Farbe1 -> Farbe2, ' 1 Farbe1 <- Farbe2
      Case 1, 2
        Beginn = 0
        For X# = Beginn To 1 Step 0.01
          XX# = X#
          If Richtung = 1 Then
            XX# = (1 - X#)
          End If
 
          AktuelleFarbe& = RGB(Farben(0).iRot - (Farben(0).iRot - Farben( _
            1).iRot) * _
                           XX#, Farben(0).iGruen - (Farben(0).iGruen - Farben( _
                           1).iGruen) _
                           * XX#, Farben(0).iBlau - (Farben(0).iBlau - Farben( _
                           1).iBlau) _
                           * XX#)
 
          Name.Line (X# * b, 0)-((X# + 0.01) * b, h), _
                   AktuelleFarbe&, BF
        Next
 
      ' Vertikal; ' 2 Farbe1 -> Farbe2, 3 Farbe1 <- Farbe2
      Case 3, 4
        For X# = 0 To 1 Step 0.01
          XX# = X#
          If Richtung = 3 Then XX# = (1 - X#)
          AktuelleFarbe& = RGB(Farben(0).iRot - (Farben(0).iRot - Farben( _
            1).iRot) * XX#, _
                           Farben(0).iGruen - (Farben(0).iGruen - Farben( _
                           1).iGruen) * XX#, _
                           Farben(0).iBlau - (Farben(0).iBlau - Farben( _
                           1).iBlau) * XX#)
 
          Name.Line (0, X# * h)-(b, (X# + 0.01) * h), _
        AktuelleFarbe&, BF
        Next
    End Select
 
    Name.AutoRedraw = FrmDraw     ' Zurücksetzen
Exit Sub
err:
End Sub

Wer aufhört sich zu verbessern, hört auf gut zu sein.

_________________________
Professionelle Entwicklerkomponenten
www.tools4vb.de