vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Mails senden, abrufen und decodieren - ganz easy ;-)  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2021
 
zurück
Rubrik: Grafik und Font · Font & Text   |   VB-Versionen: VB4, VB5, VB612.10.05
Schrift mit Farbverlauf

Schrift mittels Maske mit einem Farbverlauf versehen

Autor:   Jürgen FienauBewertung:     [ Jetzt bewerten ]Views:  9.640 
computer.net-berlin.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 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

Dieser Tipp wurde bereits 9.640 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
(einschl. Beispielprojekt!)

Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
- nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
- Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
 
   

Druckansicht Druckansicht Copyright ©2000-2021 vb@rchiv Dieter Otter
Alle 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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel