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 Dieser Tipp wurde bereits 19.756 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevWizard für VB5/6 Professionelle Assistenten im Handumdrehen Erstellen Sie eigene Assistenten (Wizards) im Look & Feel von Windows 2000/XP - mit allem Komfort und zwar in Windeseile :-) Tipp des Monats Mai 2024 Hermann Röttger Wochentage eines Datumsbereichs ermitteln Wochentage eines Datumsbereichs ermitteln, optional mit Feiertagsberechnung TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |