Schrift mit Farbverlauf Schrift mittels Maske mit einem Farbverlauf versehen
Autor:   Jürgen Fienau	Bewertung:	Views:  10.452
computer.net-berlin.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

In diesem Beispiel werden wir einen Text mit Farbverlauf programmieren. Zuerst wird der Text mittels der Print-Anweisung in eine PictureBox gezeichnet. Dann erstellen wir eine Maske und die Anfangs- und End-Koordinaten für den Farbverlauf (damit dieser auch weiß, wo er hingehört.) Nach dem Zeichnen des Farbverlaufes wird ebenfalls mit einer Schleife (X/Y für eine Fläche) die weiße Fläche aus der Maske in Form des Farbverlaufes in die erste PictureBox eingefügt.

Erstellen Sie ein neues Projekt mit folgenden Controls:

• TextBox (Text1) für die Eingabe des Textes
• 2 x CommandButton (Command1(0) und Command1(1)) mit Beschriftung "Horizontal" und "Vertikal"
• 1 x CommandButton (Command2) mit der Beschriftung "Reset"
• 1 x PictureBox (Picture1)
• 1 x PictureBox (PicGradient) (kann unsichtbar sein!)
• 1 x PictureBox (PicMask) (kenn ebenfalls unsichtbar sein!)

Fügen Sie nachfolgenden Code in den Codeteil der Form ein:

Option Explicit
 
' Benötigte API-Deklarationen
Private Declare Function SetPixel Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal X As Long, _
  ByVal Y As Long, _
  ByVal crColor As Long) As Long
 
Private Declare Function GetPixel Lib "gdi32" ( _
  ByVal hdc As Long, _
  ByVal X As Long, _
  ByVal Y As Long) As Long
 
Dim StartCol As Double
Dim EndCol As Double
Dim RedI As Single
Dim BlueI As Single
Dim GreenI As Single
Dim RedStart As Integer
Dim GreenStart As Integer
Dim BlueStart As Integer
Dim RedEnd As Double
Dim GreenEnd As Double
Dim BlueEnd As Double
Dim NC As Single

Private Sub Form_Load()
  StartCol = &HF0F0F0  ' &HFBFBEE
  EndCol = &H505050    ' &H808000
End Sub

Private Sub Command1_Click(Index As Integer)
  ' Farbverlauf
  Call Gradient(Index)
End Sub

Private Sub Command2_Click()
  Form_Load
End Sub

Private Sub Gradient(Index As Integer)
  Dim R1 As Long
  Dim R2 As Long
  Dim i As Long
  Dim j As Long
  Dim StartY As Long
  Dim EndY As Long
  Dim StartX As Long
  Dim EndX As Long
 
  Screen.MousePointer = 11
  SetPicSize Picture1, PicMask
  SetPicSize Picture1, PicGradient
  Picture1.AutoRedraw = True
 
  ' X/Y-Koordinaten für PicGradient
  For j = 0 To Picture1.ScaleHeight - 1
    For i = 0 To Picture1.ScaleWidth - 1
      R1 = GetPixel(Picture1.hdc, i, j)
      If R1 = &H806040 Then ' Dunkelblau
        If StartY = 0 Then StartY = j
        EndY = j
      End If
    Next i
  Next j
 
  For i = 0 To Picture1.ScaleWidth - 1
    For j = 0 To Picture1.ScaleHeight - 1
      R1 = GetPixel(Picture1.hdc, i, j)
      If R1 = &H806040 Then
        If StartX = 0 Then StartX = i
        EndX = i
      End If
    Next j
  Next i
 
  Select Case Index
    Case 0
      ' Horizontal
      Call InitializeCol((EndY - StartY) + 1)
      For i = StartY To EndY
        NC = RGB(RedStart + (i - StartY) * RedI, _
          GreenStart + (i - StartY) * GreenI, _
          BlueStart + (i - StartY) * BlueI)
        PicGradient.Line (StartX, i)-(EndX + 1, i), NC
      Next
 
    Case 1
      ' Vertikal
      Call InitializeCol((EndX - StartX) + 1)
      For i = StartX To EndX
        NC = RGB(RedStart + (i - StartX) * RedI, _
          GreenStart + (i - StartX) * GreenI, _
          BlueStart + (i - StartX) * BlueI)
        PicGradient.Line (i, StartY)-(i, EndY + 1), NC
      Next
  End Select
 
  Picture1.Picture = Picture1.Image
 
  ' Maske erstellen
  For i = 0 To Picture1.ScaleWidth - 1
    For j = 0 To Picture1.ScaleHeight - 1
      R1 = GetPixel(Picture1.hdc, i, j)
      If R1 <> &H806040 Then
        SetPixel PicMask.hdc, i, j, vbBlack
      End If
    Next j
  Next i
  PicMask.Refresh
 
  ' Farbverlauf oder Bild mittels Maske hinterlegen.
  For i = 0 To PicMask.ScaleWidth - 1
    For j = 0 To PicMask.ScaleHeight - 1
      R1 = GetPixel(PicMask.hdc, i, j)
      If R1 <> vbBlack Then
        R2 = GetPixel(PicGradient.hdc, i, j)
        SetPixel Picture1.hdc, i, j, R2
      End If
    Next j
  Next i
 
  Picture1.AutoRedraw = False
  PicGradient.AutoRedraw = False
  PicMask.AutoRedraw = False
  Screen.MousePointer = 0
End Sub

Private Sub InitializeCol(ByVal Y As Long)
  RedStart = StartCol Mod 256
  RedEnd = EndCol Mod 256
  RedI = (RedEnd - RedStart) / Y
 
  GreenStart = (StartCol And &HFF00FF00) / 256
  GreenEnd = (EndCol And &HFF00FF00) / 256
  GreenI = (GreenEnd - GreenStart) / Y
 
  BlueStart = (StartCol And &HFFFF0000) / (65536)
  BlueEnd = (EndCol And &HFFFF0000) / (65536)
  BlueI = (BlueEnd - BlueStart) / Y
End Sub

' Text mit Farbmaske ausgeben
Private Sub Text1_Change()
  With Picture1
    .AutoRedraw = True
    ' Schriftgröße festlegen
    .Font.Name = "Times New Roman"
    .Font.Size = 36
    .Font.Bold = True
    .Cls
    .Picture = LoadPicture()
    .BackColor = vbWhite
    .ForeColor = &H806040 ' DunkelBlau
    Picture1.Print Text1.Text
    .ForeColor = vbRed
    Picture1.Print Text1.Text
    .Refresh
    .AutoRedraw = False
  End With
End Sub

Private Sub SetPicSize(oSource As Object, oDest As Object)
  With oDest
    .Width = oSource.Width
    .Height = oSource.Height
    .Cls
    .Picture = LoadPicture()
    .AutoRedraw = True
  End With
End Sub

Copyright ©2000-2024 vb@rchiv Dieter OtterAlle Rechte vorbehalten.

Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.