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