Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0795: Texte mit Farbverlauf und Kontur ausgeben

VB 5/6-Tipp 0795: Texte mit Farbverlauf und Kontur ausgeben

 von Zardoz

Schwierigkeitsgrad:

Verwendete API-Aufrufe: BitBlt, GetPixel, TextOutA (TextOut)

Download: Download des Beispielprojektes [3,43 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Texte mit Farbverlauf
' Copyright © 2011 by Zardoz
Option Explicit

Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

Private flg1 As Boolean

Private Sub Form_Load()
  ' Einstellungen
  
  With Me
    .ScaleMode = vbPixels
    .BackColor = RGB(222, 222, 222)
    .WindowState = vbMaximized
    .AutoRedraw = True
  End With
  Picture1.Visible = False
  flg1 = False
  
End Sub

Private Sub Form_Activate()

  Dim Txt As String, XPos As Single, YPos As Single
  Dim Color1 As Long, Color2 As Long, Out As String
  Dim i As Long, Knt As Long
  
  If flg1 = True Then Exit Sub ' nur einmal ausführen
  flg1 = True
  DoEvents
  
  Me.Line (0, 0)-Step(Me.ScaleWidth - 1, 100), vbWhite, BF
  
  XPos = 100 ' X-Position des Textes
  YPos = 0 ' Y-Position des Textes
  Color1 = RGB(255, 255, 255) ' Farbverlauf Startfarbe
  Color2 = RGB(255, 0, 0) ' Farbverlauf Zielfarbe
  Knt = vbBlack ' Konturfarbe (-1 = keine Kontur)
  Txt = "Texte mit Farbverlauf" ' Auszugebender Text
  ' Text zeichnen
  Call EffektText(Me, Txt, XPos, YPos, Color1, Color2, Knt)
  
  ' Beispieltexte ausgeben
  Txt = ""
  For i = Asc("A") To Asc("Z")
    Txt = Txt & Chr$(i) & " "
  Next i
  Out = Txt
  
  XPos = 30
  YPos = 100
  Color1 = RGB(0, 255, 255)
  Color2 = RGB(0, 0, 255)
  Knt = RGB(255, 0, 0)
  Call EffektText(Me, Left$(Txt, 2 * 13), XPos, YPos, Color1, Color2, Knt)
  YPos = 200
  Call EffektText(Me, Mid$(Txt, 2 * 13 + 1), XPos, YPos, Color1, Color2, Knt)
  
  XPos = 30
  YPos = 300
  Txt = "The quick brown fox"
  Color1 = RGB(255, 128, 0)
  Color2 = RGB(255, 255, 0)
  Knt = vbBlack
  Call EffektText(Me, Txt, XPos, YPos, Color1, Color2, Knt)
  
  XPos = 30
  YPos = 390
  Txt = "jumps over the lazy dog."
  Color1 = RGB(255, 255, 0)
  Color2 = RGB(255, 128, 0)
  Call EffektText(Me, Txt, XPos, YPos, Color1, Color2, Knt)
  
  XPos = 0
  YPos = 470
  Color1 = RGB(255, 255, 255)
  Color2 = RGB(0, 200, 0)
  Knt = vbBlack
  Txt = Left$(LCase$(Replace(Out, " ", "")), 26)
  Call EffektText(Me, Txt, XPos, YPos, Color1, Color2, Knt)
  
  XPos = 100
  YPos = 560
  Color1 = vbYellow
  Color2 = RGB(255, 0, 0)
  Knt = vbBlue
  Txt = "0 1 2 3 4 5 6 7 8 9 # . , !"
  Call EffektText(Me, Txt, XPos, YPos, Color1, Color2, Knt)
  
End Sub

Public Sub EffektText(Dest As Object, Txt As String, ByVal XPos As Single, ByVal YPos As Single, ByVal Color1 As Long, ByVal Color2 As Long, ByVal BorderColor As Long)
  
  Dim i As Long, j As Long, Fkt As Single
  Dim Wnk As Single, N As Long, Rad As Single
  Dim TW As Single, TH As Single, TW2 As Long
  Dim Y1 As Single, Y2 As Single, Pic1hdc As Long
  Dim C1(2) As Long, C2(2) As Long, C3(2) As Long
  Const Pi As Single = 3.141593
  
  If Trim$(Txt) = "" Then Exit Sub
  Rad = 3
  N = 11
  ' Farben zerlegen
  For i = 0 To 2
    C1(i) = Color1 And &HFF
    Color1 = Color1 \ &H100
    C2(i) = Color2 And &HFF
    Color2 = Color2 \ &H100
  Next i
  
  With Dest
    .ScaleMode = vbPixels
    .FontTransparent = True
    .FontSize = 48
    .FontName = "Arial Black"
    TW = .TextWidth(Txt) + 8
    TH = .TextHeight(Txt)
    TW2 = .TextWidth("W")
    With Picture1
      .BorderStyle = vbBSNone
      .ScaleMode = vbPixels
      .BackColor = vbBlack
      .ForeColor = vbWhite
      .Move 0, 0, TW, TH
      .FontSize = Dest.FontSize
      .FontName = Dest.FontName
      .FontTransparent = True
      .AutoRedraw = True
      .Cls
      Pic1hdc = .hdc
    End With
    ' Text für Höhenbestimmung ausgeben
    For i = 1 To Len(Txt)
      Call TextOut(Pic1hdc, 0, 0, Mid$(Txt, i, 1), 1)
    Next i
    
    ' Schrift von oben suchen
    Do
      For j = 0 To TH - 1
        For i = 0 To TW2 - 1
          If GetPixel(Pic1hdc, i, j) = vbWhite Then
            Y1 = j
            Exit Do
          End If
        Next i
      Next j
    Loop Until True
    
    ' Schrift von unten suchen
    Do
      For j = TH - 1 To 0 Step -1
        For i = 0 To TW2 - 1
          If GetPixel(Pic1hdc, i, j) = vbWhite Then
            Y2 = j
            Exit Do
          End If
        Next i
      Next j
    Loop Until True
    
    ' Farbverlauf zeichnen
    For i = Y1 To Y2
      Fkt = (i - Y1) / (Y2 - Y1)
      For j = 0 To 2
        C3(j) = C1(j) + (C2(j) - C1(j)) * Fkt
      Next j
      Picture1.Line (0, i)-(TW, i), RGB(C3(0), C3(1), C3(2))
    Next i
    
    If BorderColor <> -1 Then
      ' Kontur zeichnen
      .ForeColor = BorderColor
      For i = 0 To N - 1
        Wnk = 2 * Pi / N * i
        Call TextOut(.hdc, XPos + Rad * Cos(Wnk), YPos - Rad * Sin(Wnk), Txt, Len(Txt))
      Next i
    End If
    
    ' Text ausgeben
    .ForeColor = vbBlack
    Call BitBlt(.hdc, XPos - 4, YPos + Y1, TW, Y2 - Y1 + 1, Pic1hdc, 0, Y1, vbSrcInvert)
    Call TextOut(.hdc, XPos, YPos, Txt, Len(Txt))
    Call BitBlt(.hdc, XPos - 4, YPos + Y1, TW, Y2 - Y1 + 1, Pic1hdc, 0, Y1, vbSrcInvert)
  End With
  
  Picture1.Cls
  Picture1.AutoRedraw = False
  
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------