vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
TOP-Angebot: 12 bzw. 19 Entwickler-Vollversionen zum unschlagbaren Preis!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2014
 
zurück
Rubrik: Grafik und Font · Grafische Effekte   |   VB-Versionen: VB4, VB5, VB629.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:   LonelySuicide666Bewertung:     [ Jetzt bewerten ]Views:  11.554 
www.vbapihelpline.deSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8 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

Dieser Tipp wurde bereits 11.554 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!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.
 
   

Druckansicht Druckansicht Copyright ©2000-2014 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.

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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel