Rubrik: Grafik und Font · Grafische Effekte | VB-Versionen: VB4, VB5, VB6 | 29.12.03 |
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: | Views: 19.749 |
www.vbapihelpline.de | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
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