Sie sind aktuell nicht angemeldet.

Funktionen: Einloggen  |  Neu registrieren  |  Suchen

Re: Monocrom Bild erstellen
Autor: FohnBit
Datum: 06.09.11 06:34
ummary>Konvertiert eine Bitmap In eine andere Farbtiefe</summary> ''' <param name="InBitmap">zu konvertierende Bitmap</param> ''' <param name="ToPixelFormat">In die zu konvertierende Farbtiefe</param> ''' <returns>Konvertierte Bitmap</returns> Private Function ConvertTo(ByVal InBitmap As Bitmap, _ ByVal ToPixelFormat As PixelFormat) As Bitmap Dim ScanLine As New Integer 'Breite einer Zeile Dim BitsPerPixel As New Short 'BPP für BITMAPINFO Struktur Dim PalBmp As Boolean = False 'Palettenbitmap Select Case ToPixelFormat Case PixelFormat.Format1bppIndexed ScanLine = ((InBitmap.Width + 31) And Not 31) \ 8 BitsPerPixel = 1 PalBmp = True Case PixelFormat.Format4bppIndexed ScanLine = ((InBitmap.Width + 7) And Not 7) \ 2 BitsPerPixel = 4 PalBmp = True Case PixelFormat.Format8bppIndexed ScanLine = (InBitmap.Width + 3) And Not 3 BitsPerPixel = 8 PalBmp = True Case PixelFormat.Format16bppRgb555 ScanLine = ((InBitmap.Width * 2) + 2) And Not 2 BitsPerPixel = 16 Case PixelFormat.Format24bppRgb ScanLine = ((InBitmap.Width * 3) + 3) And Not 3 BitsPerPixel = 24 Case PixelFormat.Format32bppRgb ScanLine = InBitmap.Width * 4 BitsPerPixel = 32 Case Else ' nicht unterstützte Pixelformate MsgBox("Die Konvertierung In dieses " & _ "Bildformat wird nicht unterstützt!") Return Nothing End Select ' Kopie von InBitmap erstellen Dim OrgBmp As New Bitmap(InBitmap) ' leeres Bitmapobjekt erstellen Dim ConvBmp As Bitmap = Nothing Dim tBitmap As New GDIBITMAP ' OrgBmp.Handle -> tBitmap If GetObjectA(OrgBmp.GetHbitmap, Len(tBitmap), tBitmap) <> 0 Then Dim tBITMAPINFO As New BITMAPINFO256 ' tBitmap.bmHeight muss als negativer Wert an ' tBITMAPINFO.bmiHeader.biHeight übergeben werden, ' da ansonsten das Bild horizontal gespiegelt wird tBITMAPINFO.bmiHeader.biHeight = -tBitmap.bmHeight tBITMAPINFO.bmiHeader.biWidth = tBitmap.bmWidth tBITMAPINFO.bmiHeader.biPlanes = tBitmap.bmPlanes tBITMAPINFO.bmiHeader.biBitCount = BitsPerPixel tBITMAPINFO.bmiHeader.biSize = Len(tBITMAPINFO.bmiHeader) tBITMAPINFO.bmiHeader.biCompression = BI_RGB ' Handle des Desktopfensters ermitteln Dim DeskHwndPtr As IntPtr = GetDesktopWindow() ' ist ein Handle vorhanden If CBool(DeskHwndPtr) Then ' DeviceContext des Desktop ermitteln Dim DeskDcPtr As IntPtr = GetDC(DeskHwndPtr) ' ist ein DeviceContext vorhanden If CBool(DeskDcPtr) Then ' ByteArray zur Aufnahme der DIB-Daten dimensionieren Dim bytData As Byte() = _ New Byte((tBitmap.bmHeight * ScanLine) - 1) {} ' DIB-Daten auslesen -> bytData If GetDIBits256(DeskDcPtr, OrgBmp.GetHbitmap, 0, _ tBitmap.bmHeight, bytData(0), tBITMAPINFO, _ DIB_RGB_COLORS) <> 0 Then ' neue Bitmap mit neuem Pixelformat erstellen ConvBmp = New Bitmap(tBitmap.bmWidth, _ tBitmap.bmHeight, ToPixelFormat) ' Bitmapdaten im Speicher sperren (schreiben) Dim ConvBMPData As BitmapData = _ ConvBmp.LockBits(New Rectangle(0, 0, _ ConvBmp.Width, ConvBmp.Height), _ ImageLockMode.WriteOnly, ToPixelFormat) ' DIB-Daten In den Speicher kopieren Call Marshal.Copy(bytData, 0, _ ConvBMPData.Scan0, bytData.Length) ' Bitmapdaten im Speicher wieder freigeben Call ConvBmp.UnlockBits(ConvBMPData) ' ist es eine Palettenbitmap ' 1bpp, 4bpp, 8bpp If PalBmp Then [/code ]

Monocrom Bild erstellen	1.013	FohnBit	06.09.11 06:34
Re: Monocrom Bild erstellen	772	FohnBit	06.09.11 06:34
Re: Monocrom Bild erstellen	727	FohnBit	06.09.11 06:35
Re: Monocrom Bild erstellen	742	FohnBit	06.09.11 06:51
Re: Monocrom Bild erstellen	763	DaveS	06.09.11 08:04
Re: Monocrom Bild erstellen	723	FohnBit	06.09.11 16:08
Re: Monocrom Bild erstellen	742	DaveS	06.09.11 16:27

Sie sind nicht angemeldet! Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden. Einloggen  |  Neu registrieren

Funktionen:  Zum Thema  |  Gesamtübersicht

Suchen