Schrift mit Farbverlauf


In diesem Beispiel werden wir einen Text mit Farbverlauf programmieren. Zuerst den Text in die erste PictureBox mittels der Print-Anweisung zeichnen lassen. 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.
Laden Sie sich die Zip-Datei mit VB 6 Source Code hinunter und probieren Sie es mal aus.

Projekt - Download
© FienauBerlin   Web-ComputerEcke.de
 

Quell-Code
Option Explicit
 
' benötigte API-Deklarationen
'Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, _
            ByVal x1 As Long, ByVal Y1 As Long, ByVal nWidth As Long, _
            ByVal nHeight As Long, ByVal hSrcDC As Long, _
            ByVal xSrc As Long, ByVal ySrc As Long, _
            ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, _
            ByVal dwRop As Long) As Long
 
 
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, EndCol As Double
Dim RedI As Single, BlueI As Single, GreenI As Single
Dim RedStart As Integer, GreenStart As Integer, BlueStart As Integer
Dim RedEnd As Double, GreenEnd As Double, BlueEnd As Double
Dim NC As Single

Private Sub Command1_Click(Index As Integer) Call Gradient(Index) End Sub
Private Sub Command2_Click() Form_Load End Sub
Private Sub Gradient(Index As Integer) Dim R1 As Long, R2 As Long Dim i As Integer, j As Integer Dim StartY%, EndY%, StartX%, EndX% Screen.MousePointer = 11 PicMask.Width = Picture1.Width PicMask.Height = Picture1.Height PicMask.Cls PicMask.Picture = LoadPicture() PicGradient.Width = Picture1.Width PicGradient.Height = Picture1.Height PicGradient.Cls PicGradient.Picture = LoadPicture() PicMask.AutoRedraw = True Picture1.AutoRedraw = True PicGradient.AutoRedraw = True StartX = 0 EndX = 0 StartY = 0 EndY = 0 '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 ' Case 2 'Beispiel für Bild hinterlegen ' PicOpen.Picture = LoadPicture(Bild-Datei) ' PicOpen.AutoRedraw = True ' StretchBlt PicGradient.hdc, StartX, StartY, EndX, EndY, _ PicOpen.hdc, 0, 0, PicOpen.ScaleWidth, _ PicOpen.ScaleHeight, vbSrcCopy ' PicGra.Refresh ' PicOpen.Refresh ' PicOpen.AutoRedraw = False ' PicOpen.Cls 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 Function InitializeCol(Y As Integer) 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 Function
Private Sub Form_Load() StartCol = &HF0F0F0 '&HFBFBEE EndCol = &H505050 '&H808000 Picture1.Picture = LoadPicture(App.Path & "\Text.bmp") End Sub
' Text mit Farbmaske ausgeben Private Sub Text1_Change() With Picture1 .AutoRedraw = True ' Schriftgröße festlegen .Font.Name = "Times New Roman" .Font.Size = 48 .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