StdPicture mit Farbverlauf erstellen Dieser Tipp zeigt, wie man ein StdPicture-Objekt mit Farbverlauf von rechts nach links bzw. von oben nach unten per VB-Code erstellt.
Autor:   LonelySuicide666	Bewertung:     [ Jetzt bewerten ]	Views:  19.728
www.vbapihelpline.de	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 18 Bewertung insgesamt: sehr gut Durchschnittliche Bewertung: 4.9 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Unser heutiger Tipp zeigt, wie man ein StdPicture-Objekt mit integriertem Farbverlauf erstellt. Der Farbverlauf kann hierbei entweder von rechts nach links oder von oben nach unten angezeigt werden. Dieses Picture-Objekt kann dann einer Form, einer PictureBox oder auch einem Image-Control! zugewiesen werden.

Fügen Sie nachfolgenden Code in ein Modul ein:

Option Explicit
 
' Benötigte API-Deklarationen
Private Declare Function GetDC Lib "user32" ( _
  ByVal hwnd As Long) As Long
 
Private Declare Function ReleaseDC Lib "user32" ( _
  ByVal hwnd As Long, _
  ByVal hDC As Long) As Long
 
Private Declare Function DeleteDC Lib "gdi32" ( _
  ByVal hDC As Long) As Long
 
Private Declare Function GetDesktopWindow Lib "user32" () As Long
 
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
  ByVal hDC As Long) As Long
 
Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
  ByVal hDC As Long, _
  ByVal nWidth As Long, _
  ByVal nHeight As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" ( _
  ByVal hDC As Long, _
  ByVal hObject As Long) As Long
 
Private Declare Function SetDIBits Lib "gdi32" ( _
  ByVal hDC As Long, _
  ByVal hBmp As Long, _
  ByVal nStartScan As Long, _
  ByVal cScanLines As Long, _
  lpvBits As Any, _
  lpbm As BITMAPINFO, _
  ByVal fuColorUse As Long) As Long
 
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
  lpPictDesc As PictDesc, _
  riid As Any, _
  ByVal fOwn As Long, _
  lplpvObj As IPicture) As Long
 
Private Declare Function DeleteObject Lib "gdi32" ( _
  ByVal hObject As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  pDest As Any, _
  pSrc As Any, _
  ByVal ByteLen As Long)
 
Private Type PictDesc
  cbSizeofStruct As Long
  picType As Long
  hImage As Long
  xExt As Long
  yExt As Long
End Type
 
Private Type BITMAPINFOHEADER
  biSize As Long
  biWidth As Long
  biHeight As Long
  biPlanes As Integer
  biBitCount As Integer
  biCompression As Long
  biSizeImage As Long
  biXPelsPerMeter As Long
  biYPelsPerMeter As Long
  biClrUsed As Long
  biClrImportant As Long
End Type
 
Private Type RGBQUAD
  rgbBlue As Byte
  rgbGreen As Byte
  rgbRed As Byte
  rgbReserved As Byte
End Type
 
Private Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type

' Berechnet die Schrittweite für die
' Farbtransformationen
Private Function CalcStepping( _
  ByVal ColorStart As Long, _
  ByVal ColorEnd As Long, _
  ByVal Steps As Long) As Double
 
  If ColorStart > ColorEnd Then
    CalcStepping = ColorStart - ColorEnd
    If CalcStepping <> 0 Then
      CalcStepping = -(CalcStepping / Steps)
    End If
  Else
    CalcStepping = ColorEnd - ColorStart
    If CalcStepping <> 0 Then
      CalcStepping = CalcStepping / Steps
    End If
  End If
End Function

' Erstellt ein StdPicture mit Farbverlauf
Public Function CreateGradientBitmap( _
  ByVal Width As Long, _
  ByVal Height As Long, _
  ByVal ColorStart As Long, _
  ByVal ColorEnd As Long, _
  ByVal LeftToRight As Boolean) As StdPicture
 
  Dim hDC As Long
  Dim TmpDC As Long
  Dim hBmp As Long
  Dim hBmpOld As Long
  Dim hDib As Long, BMI As BITMAPINFO
  Dim bmBits() As RGBQUAD
  Dim ColorS(3) As Byte
  Dim ColorE(3) As Byte
  Dim i As Long
  Dim j As Long
  Dim TmpLng As Long
  Dim IID_IPicture(3) As Long
  Dim TmpPicture As IPicture
  Dim PD As PictDesc
  Dim ColorSteps1 As Double
  Dim ColorSteps2 As Double
  Dim ColorSteps3 As Double
  Dim TmpColor1 As Double
  Dim TmpColor2 As Double
  Dim TmpColor3 As Double
 
  ' Bitmap-Device erstellen
  hDC = GetDC(GetDesktopWindow)
  TmpDC = CreateCompatibleDC(hDC)
  hBmp = CreateCompatibleBitmap(hDC, Width, Height)
  hBmpOld = SelectObject(TmpDC, hBmp)
 
  ' Initialfarben berechnen
  CopyMemory ColorS(0), ColorStart, 4
  CopyMemory ColorE(0), ColorEnd, 4
  ColorSteps1 = CalcStepping(ColorS(0), ColorE(0), Width)
  ColorSteps2 = CalcStepping(ColorS(1), ColorE(1), Width)
  ColorSteps3 = CalcStepping(ColorS(2), ColorE(2), Width)
  TmpColor1 = ColorS(0)
  TmpColor2 = ColorS(1)
  TmpColor3 = ColorS(2)
 
  ' Array erstellen und Farbwerte zuweisen
  If Not LeftToRight Then
    ReDim bmBits(Height - 1, Width - 1)
    For i = 0 To Width - 1
      TmpColor1 = TmpColor1 + ColorSteps1
      TmpColor2 = TmpColor2 + ColorSteps2
      TmpColor3 = TmpColor3 + ColorSteps3
 
      For j = 0 To Height - 1
        bmBits(j, i).rgbRed = TmpColor1
        bmBits(j, i).rgbGreen = TmpColor2
        bmBits(j, i).rgbBlue = TmpColor3
      Next j
    Next i
  Else
    ReDim bmBits(Width - 1, Height - 1)
    For i = 0 To Width - 1
      TmpColor1 = TmpColor1 + ColorSteps1
      TmpColor2 = TmpColor2 + ColorSteps2
      TmpColor3 = TmpColor3 + ColorSteps3
 
      For j = 0 To Height - 1
        bmBits(i, j).rgbRed = TmpColor1
        bmBits(i, j).rgbGreen = TmpColor2
        bmBits(i, j).rgbBlue = TmpColor3
      Next j
    Next i
  End If
 
  ' Farb-Array dem Bitmap zuweisen
  With BMI.bmiHeader
    .biSize = Len(BMI.bmiHeader)
    .biWidth = Width
    .biHeight = Height
    .biPlanes = 1
    .biBitCount = 32
    .biSizeImage = Width * Height * 4
  End With
  SetDIBits TmpDC, hBmp, 0, Height, bmBits(0, 0), BMI, 0
 
  ' Speicher aufräumen
  Call DeleteObject(hDib)
  Call SelectObject(TmpDC, hBmpOld)
  DeleteDC TmpDC
  ReleaseDC GetDesktopWindow, hDC
 
  ' StdPicture aus dem GDI Bitmap erstellen
  IID_IPicture(0) = &H7BF80980
  IID_IPicture(1) = &H101ABF32
  IID_IPicture(2) = &HAA00BB8B
  IID_IPicture(3) = &HAB0C3000
 
  With PD
    .cbSizeofStruct = Len(PD)
    .hImage = hBmp
    .picType = 1
  End With
  If OleCreatePictureIndirect(PD, IID_IPicture(0), _
    Abs(True), TmpPicture) = 0 Then
 
    Set CreateGradientBitmap = TmpPicture
  End If
End Function

Ein paar Anwendungsbeispiele:

' PictureBox mit Farbverlauf blau/weiß 
' von oben nach unten
With Picture1
  Set .Picture = CreateGradientBitmap( _
    .Width / Screen.TwipsPerPixelX, _
    .Height / Screen.TwipsPerPixelY, _
    vbBlue, vbWhite, False)
End With

' Image-Control mit Farbverlauf rot/weiß 
' von links nach rechts
With Image1
  Set .Picture = CreateGradientBitmap( _
    .Width / Screen.TwipsPerPixelX, _
    .Height / Screen.TwipsPerPixelY, _
    vbRed, vbWhite, True)
End With