VB 5/6-Tipp 0729: Bild als Icon speichern
von Frank Schüler
Beschreibung
Dieser Tipp zeigt wie ein Bild, das sich in einer PictureBox befindet, als Icon gespeichert werden kann. Dabei werden alle Standardgrößen und Farbtiefen für Icons unterstützt.
| Schwierigkeitsgrad:
| Verwendete API-Aufrufe: CreateDIBSection (CreateDIBSection256), CreateIconFromResourceEx, DeleteObject, GetDC, GetDIBits (GetDIBits256), IIDFromString, OleCreatePictureIndirect, OleTranslateColor, ReleaseDC, SetDIBits (SetDIBits256) | Download: |
'Dieser Quellcode stammt von http://www.activevb.de 'und kann frei verwendet werden. Für eventuelle Schäden 'wird nicht gehaftet. 'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum. 'Ansonsten viel Spaß und Erfolg mit diesem Source! '------------- Anfang Projektdatei Pic2Ico.vbp ------------- '------- Anfang Formular "frmMain" alias frmMain.frm ------- ' Steuerelement: Rahmensteuerelement "frmBpp" ' Steuerelement: Optionsfeld-Steuerelement "opBpp" (Index von 0 bis 5) auf frmBpp ' Steuerelement: Schaltfläche "cmdDraw" ' Steuerelement: Bildfeld-Steuerelement "picView" ' Steuerelement: Bildfeld-Steuerelement "picIco" ' Steuerelement: Schaltfläche "cmdSave" Option Explicit Private eIconFormat As IconFormat Private Sub cmdDraw_Click() ' nun zeichnen wir irgendwas in die ' PictureBox in der Größe für ein 32x32 Icon picIco.Line (0, 0)-(31, 31), vbBlue, B picIco.Line (5, 5)-(26, 26), vbBlack, B picIco.Line (10, 10)-(22, 22), vbRed, BF picIco.Line (0, 0)-(32, 32), vbYellow picIco.Line (0, 31)-(32, -1), vbMagenta picIco.Line (0, 16)-(32, 16), vbGreen picIco.Line (16, 0)-(16, 32), vbCyan picIco.Line (14, 14)-(18, 18), picIco.BackColor, BF ' Button zum speichern aktivieren cmdSave.Enabled = True End Sub Private Sub cmdSave_Click() Dim strPath As String Dim eIconSize As IconSize ' Anwendungspfad ermitteln strPath = App.Path ' Backslash anhängen wenn nicht vorhanden If Right$(strPath, 1) <> "\" Then strPath = strPath & "\" End If ' Dateiname an den Pfad hängen strPath = strPath & "testing.ico" ' Es kann auch ein Bild in die PictureBox geladen bzw. gezeichnet werden. ' Allerdings findet hier keine Skalierung des Bildes auf die gewünschte ' Icongröße statt sondern es wird ein entsprechend großer Ausschnitt aus ' dem Bild in ein Icon konvertiert. Entweder man läd schon ein entsprechend ' großes Bild in die PictureBox oder man skaliert das Bild voher zb. mit ' PaintPicture oder StretchBlt und SetStretchBltMode auf die gewünschte ' Größe und zeichnet dieses in die PictureBox. ' Icongröße (Bildausschnitt aus picIco) eIconSize = [32x32] ' *************************************************************** ' Unter Windows 95/98/Me muss die PictureBox vorher auf die Größe ' des zu erstellenden Icons eingestellt werden. ' Ab Windows NT sind diese Zeilen überflüssig. picIco.Move picIco.Left, picIco.Top, eIconSize, eIconSize picIco.Cls Call cmdDraw_Click ' *************************************************************** ' nun speichern wir einen 32x32 Pixel großen Ausschnitt aus dem Image ' als 32x32 großes Icon im 256 Color-Format wobei die Hintergrundfarbe ' der PictureBox als transparente Farbe für das Icon verwendet werden soll. If SaveImageAsIcon(picIco.Image, strPath, eIconSize, eIconFormat, _ picIco.BackColor, True) Then ' nach Iconformat selektieren Select Case eIconFormat Case IconFormat.[2 Color], IconFormat.[16 Color], _ IconFormat.[256 Color], IconFormat.[24 Bit Truecolor] ' erstelltes Icon zum Test in eine PictureBox laden picView.Picture = LoadPicture(strPath) Case Else ' VBC kann keine 16bit und 32bit Icons per LoadPicture laden. ' Daher verwenden wir hier eine andere Methode um das Icon ' in die PictureBox zu laden. picView.Picture = LoadIcon(strPath, picView.BackColor) End Select Else ' hier ist dann irgendwas schief gelaufen Set picView.Picture = Nothing picView.Move cmdDraw.Left + cmdDraw.Width + 4, cmdDraw.Top, 255, 255 MsgBox "Speichern war nicht erfolgreich." End If End Sub Private Sub Form_Load() Me.ScaleMode = vbPixels Me.Width = 10300 Me.Height = 4300 eIconFormat = [256 Color] With picIco .BorderStyle = 0 .ScaleMode = vbPixels ' PictureBox auf die maximale Standard-Icongröße aufziehen .Move 2, 2, 256, 256 ' ein muss, sonst geht gar nichts .AutoRedraw = True ' nur damit sich die PictureBox vom Hintergrund der Form abhebt .BackColor = QBColor(8) ' damit wir etwas sehen bleibt die PictureBox sichtbar ' .Visible = False End With With cmdDraw .Caption = "Draw" .Move picIco.Left + picIco.Width + 4, picIco.Top, 155, 30 End With With cmdSave .Caption = "Save Image as Icon" .Move picIco.Left + picIco.Width + 4, cmdDraw.Top + cmdDraw.Height + _ 4, 155, 30 .Enabled = False End With With frmBpp .Move cmdSave.Left, cmdSave.Top + cmdSave.Height + 4, 155 End With With picView .AutoSize = True .BorderStyle = 0 .Move cmdDraw.Left + cmdDraw.Width + 4, cmdDraw.Top, 255, 255 ' nur damit wir die transparenten Bereiche des Icons sehen .BackColor = QBColor(15) End With End Sub Private Sub opBpp_Click(Index As Integer) ' Farbtiefe für das zu speichernde Icon festlegen Select Case Index Case 0 eIconFormat = [2 Color] Case 1 eIconFormat = [16 Color] Case 2 eIconFormat = [256 Color] Case 3 eIconFormat = [16 Bit Truecolor] Case 4 eIconFormat = [24 Bit Truecolor] Case 5 eIconFormat = [32 Bit Truecolor] End Select End Sub '-------- Ende Formular "frmMain" alias frmMain.frm -------- '------ Anfang Modul "modPic2Ico" alias modPic2Ico.bas ------ Option Explicit ' ----==== Const ====---- Private Const S_OK As Long = 0& Private Const BI_RGB As Long = 0& Private Const DIB_RGB_COLORS As Long = 0& Private Const IconVersion As Long = &H30000 Private Const LR_DEFAULTCOLOR As Long = &H0 Private Const IID_IPicture As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" ' ----==== Enum ====---- ' Standard-Iconpixelformate Public Enum IconFormat [2 Color] = 1 [16 Color] = 4 [256 Color] = 8 [16 Bit Truecolor] = 16 [24 Bit Truecolor] = 24 [32 Bit Truecolor] = 32 End Enum ' Standard-Icongrößen Public Enum IconSize [16x16] = 16 [24x24] = 24 [32x32] = 32 [48x48] = 48 [64x64] = 64 [72x72] = 72 [96x96] = 96 [128x128] = 128 [256x256] = 256 End Enum ' ----==== 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 BITMAPINFO256 bmiHeader As BITMAPINFOHEADER bmiColors(255) As Long End Type Private Type IconHeader ihReserved As Integer ihType As Integer ihCount As Integer End Type Private Type IconEntry ieWidth As Byte ieHeight As Byte ieColorCount As Byte ieReserved As Byte iePlanes As Integer ieBitCount As Integer ieBytesInRes As Long ieImageOffset As Long End Type Private Type IID Data1 As Long Data2 As Integer Data3 As Integer Data4(0 To 7) As Byte End Type Private Type PICTDESC cbSizeOfStruct As Long picType As Long hGdiObj As Long hPalOrXYExt As Long End Type ' ----==== GDI32 API Deklarationen ====---- Private Declare Function CreateDIBSection256 Lib "gdi32.dll" _ Alias "CreateDIBSection" ( _ ByVal hdc As Long, _ ByRef pBitmapInfo As BITMAPINFO256, _ ByVal un As Long, _ ByVal lplpVoid As Long, _ ByVal handle As Long, _ ByVal dw As Long) As Long Private Declare Function DeleteObject Lib "gdi32" ( _ ByVal hObject As Long) As Long Private Declare Function GetDIBits256 Lib "gdi32.dll" _ Alias "GetDIBits" ( _ ByVal aHDC As Long, _ ByVal hBitmap As Long, _ ByVal nStartScan As Long, _ ByVal nNumScans As Long, _ ByRef lpBits As Any, _ ByRef lpBI As BITMAPINFO256, _ ByVal wUsage As Long) As Long Private Declare Function SetDIBits256 Lib "gdi32.dll" _ Alias "SetDIBits" ( _ ByVal hdc As Long, _ ByVal hBitmap As Long, _ ByVal nStartScan As Long, _ ByVal nNumScans As Long, _ ByRef lpBits As Any, _ ByRef lpBI As BITMAPINFO256, _ ByVal wUsage As Long) As Long ' ----==== USER32 API Deklarationen ====---- Private Declare Function CreateIconFromResourceEx Lib "user32.dll" ( _ ByRef presbits As Any, _ ByVal dwResSize As Long, _ ByVal fIcon As Long, _ ByVal dwVer As Long, _ ByVal cxDesired As Long, _ ByVal cyDesired As Long, _ ByVal Flags As Long) As Long ' ----==== OLE32 API Declarationen ====---- Private Declare Function IIDFromString Lib "ole32.dll" ( _ ByVal lpsz As Long, _ ByRef lpIID As IID) As Long ' ----==== OLEAUT32 API Deklarationen ====---- Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _ ByRef lpPictDesc As PICTDESC, _ ByRef riid As IID, _ ByVal fOwn As Boolean, _ ByRef lplpvObj As Object) As Long Private Declare Function OleTranslateColor Lib "oleaut32.dll" ( _ ByVal lOleColor As Long, _ ByVal lHPalette As Long, _ ByRef lColorRef As Any) As Long ' ----==== USER32 API Deklarationen ====---- Private Declare Function GetDC Lib "user32.dll" ( _ ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32.dll" ( _ ByVal hwnd As Long, _ ByVal hdc As Long) As Long ' ------------------------------------------------------ ' Funktion : FileExists ' Beschreibung : Existiert eine Datei ' Übergabewert : FileName = Pfad\Datei.ext ' Rückgabewert : True = Datei ist vorhanden ' False = Datei ist nicht vorhanden ' ------------------------------------------------------ Private Function FileExists(ByVal FileName As String) As Boolean On Error Resume Next Dim ret As Long ret = Len(Dir$(FileName)) If Err Or ret = 0 Then FileExists = False Else FileExists = True End Function ' ------------------------------------------------------ ' Funktion : LoadIcon ' Beschreibung : Lädt ein Icon aus einer Icondatei ' Übergabewert : IcoFileName = Pfad\Datei.ext ' TransColor32Bit = Hintergrundfarbe für das 32Bit-Icon ' Rückgabewert : StdPicture (Icon) ' ------------------------------------------------------ Public Function LoadIcon(ByVal IcoFileName As String, Optional ByVal TransColor32Bit As _ Long = vbButtonFace) As StdPicture ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ' Diese Funktion ist eine speziell für diesen Tipp angepasste Version ' eines anderen Tipps zum laden von Icons. Mit dieser Funktion kann ' nur eine Icondatei ausgelesen werden, in der sich auch nur ein Icon ' befindet. ' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Dim hIcon As Long Dim lngFNr As Long Dim lngAlpha As Long Dim lngRed As Long Dim lngGreen As Long Dim lngBlue As Long Dim lngX As Long Dim lngY As Long Dim lngPictOffset As Long Dim lngMaskOffset As Long Dim lngPictPos As Long Dim lngMaskPos As Long Dim lngPictStride As Long Dim lngMaskStride As Long Dim bytIconData() As Byte Dim bytARGB(0 To 3) As Byte Dim tIID As IID Dim tPictDesc As PICTDESC Dim tIconEntry As IconEntry Dim tIconHeader As IconHeader Dim tBITMAPINFO As BITMAPINFOHEADER Dim oPicture As IPicture ' wenn die Datei vorhanden ist If FileExists(IcoFileName) Then ' wenn die Dateierweiterung = "ico" ist If LCase$(Right$(IcoFileName, 3)) = "ico" Then ' freie Dateinummer holen lngFNr = FreeFile ' Icondatei binär zum lesen öffnen Open IcoFileName For Binary Access Read As #lngFNr ' IconHeader einlesen Get #lngFNr, , tIconHeader ' ist es eine Icondatei If tIconHeader.ihType = 1 Then ' ist ein Icon in der Datei vorhanden If tIconHeader.ihCount = 1 Then ' IconEntry einlesen Get #lngFNr, , tIconEntry ' ByteArray bytIconData zur Aufname der Bilddaten ' dimensionieren ReDim bytIconData(tIconEntry.ieBytesInRes - 1) ' Bilddaten einlesen Get #lngFNr, , bytIconData() End If End If ' Zugriff auf die Datei schließen Close #lngFNr ' wenn es kein 32Bit-Icon ist If tIconEntry.ieBitCount < 32 Then ' dann kann das Icon direkt aus den Daten erstellt werden hIcon = CreateIconFromResourceEx(bytIconData(0), _ tIconEntry.ieBytesInRes, 1, IconVersion, tIconEntry.ieWidth, _ tIconEntry.ieHeight, LR_DEFAULTCOLOR) Else ' Für 32Bit-Icons müssen wir ein wenig schummeln damit das Icon korrekt ' dargestellt wird. Wir mischen die Farbe des Icons mit der Hintergrundfarbe ' auf dem das Icon dann dargestellt werden soll um so den Effekt von ' transparenz zu erzeugen. ' Systemfarben konvertieren und Farbwert von Long nach RGB splitten If OleTranslateColor(TransColor32Bit, 0&, bytARGB(0)) = 0 Then ' Breite einer Bildzeile inkl. PadBytes berechnen lngPictStride = tIconEntry.ieWidth * 4 ' 32bpp lngMaskStride = ((tIconEntry.ieWidth + 31) And Not 31) \ 8 ' 1bpp ' Offset berechen wo im ByteArray bytIcoData die Bilddaten liegen lngPictOffset = Len(tBITMAPINFO) lngMaskOffset = lngPictOffset + (tIconEntry.ieHeight * lngPictStride) ' alle Pixel des Icons durchlaufen For lngY = 0 To tIconEntry.ieHeight - 1 For lngX = 0 To tIconEntry.ieWidth - 1 ' Pixelpositionen im ByteArray bytIcoData berechnen lngPictPos = lngPictOffset + (lngY * lngPictStride) + (lngX * 4) lngMaskPos = lngMaskOffset + (lngY * lngMaskStride) + (lngX \ 8) ' ist es ein Weißer Pixel in der Maske If (bytIconData(lngMaskPos) And CByte(&H80 / (2 ^ (lngX And _ &H7)))) = CByte(&H80 / (2 ^ (lngX And &H7))) Then ' dann wird der Pixel vom Iconimage auf transparent ' gesetzt lngAlpha = 0 ' diesen Pixel in der Maskenbitmap auf Schwarz setzen bytIconData(lngMaskPos) = bytIconData(lngMaskPos) And Not _ CByte(&H80 / (2 ^ (lngX And &H7))) Else ' Schwarzer Pixel in der Maske ' dann wird der Pixel vom Iconimage opaque bzw. ' entsprechend der transparenz gesetzt lngAlpha = CLng(bytIconData(lngPictPos + 3)) ' A End If ' Alphawert von 255 abziehen lngAlpha = 255 - lngAlpha ' RGB-daten des Pixels auslesen lngRed = CLng(bytIconData(lngPictPos + 2)) ' R lngGreen = CLng(bytIconData(lngPictPos + 1)) ' G lngBlue = CLng(bytIconData(lngPictPos + 0)) ' B ' RGB-Daten des Pixels mit den RGB-Daten von ' TransColor32Bit prozentual mischen bytIconData(lngPictPos + 2) = CByte(lngRed - (((lngRed - _ bytARGB(0)) * lngAlpha) / 255)) bytIconData(lngPictPos + 1) = CByte(lngGreen - (((lngGreen - _ bytARGB(1)) * lngAlpha) / 255)) bytIconData(lngPictPos + 0) = CByte(lngBlue - (((lngBlue - _ bytARGB(2)) * lngAlpha) / 255)) Next lngX Next lngY ' Icon aus den Daten erstellen hIcon = CreateIconFromResourceEx(bytIconData(0), _ tIconEntry.ieBytesInRes, 1, IconVersion, tIconEntry.ieWidth, _ tIconEntry.ieHeight, LR_DEFAULTCOLOR) End If End If ' ist ein Handle auf ein Icon vorhanden If hIcon <> 0 Then ' IID_IPicture -> tIID If IIDFromString(StrPtr(IID_IPicture), tIID) = S_OK Then With tPictDesc .cbSizeOfStruct = Len(tPictDesc) .picType = vbPicTypeIcon .hGdiObj = hIcon End With ' StdPicture (Icon) aus dem Handle erstellen If OleCreatePictureIndirect(tPictDesc, tIID, True, oPicture) = S_OK _ Then ' StdPicture zurückgeben Set LoadIcon = oPicture End If End If End If End If End If End Function ' ------------------------------------------------------ ' Funktion : SaveImageAsIcon ' Beschreibung : Speichert ein Image als Icon ' Übergabewert : Image = StdPicture ' IcoFileName = Pfad\Datei.ext ' Size = Enum IconSize ' PixelFormat = Enum IconFormat ' TransColor = Farbe die transparent werden soll ' UseTransparency = TransColor verwenden ' Rückgabewert : True = speichern war erfolgreich ' False = speichern war nicht erfolgreich ' ------------------------------------------------------ Public Function SaveImageAsIcon(ByVal Image As StdPicture, ByVal IcoFileName As String, _ Optional ByVal Size As IconSize = [32x32], Optional ByVal PixelFormat As IconFormat _ = [16 Color], Optional ByVal TransColor As Long = vbButtonFace, Optional ByVal _ UseTransparency As Boolean = True) As Boolean Dim lngX As Long Dim lngY As Long Dim lngDC As Long Dim hBmp32 As Long Dim lngFNr As Long Dim lngPictPos As Long Dim lngMaskPos As Long Dim lngPalItem As Long Dim lngPalCount As Long Dim lngPalette() As Long Dim lngMaskStride As Long Dim lngPictStride As Long Dim bytPictArray() As Byte Dim bytMaskArray() As Byte Dim tIconEntry As IconEntry Dim tIconHeader As IconHeader Dim tBITMAPINFO As BITMAPINFO256 Dim tBITMAPINFOHEADER As BITMAPINFOHEADER ' Wir konvertieren zunächst das Bild in das 32bpp Format und schneiden ' die entsprechende Größe (Size) aus der übergebenden Bitmap aus. Das ' 32bpp Format verwenden wir hier weil es einfacher ist eine Farbe ' als tranparente Farbe zu setzen. Insbesondere ist die Verarbeitung ' dann für die 16bpp, 8bpp, 4bpp und 1bpp Formate einfacher was die ' transparente Farbe angeht. ' Breite einer Bildzeile inkl. PadBytes berechnen lngPictStride = Size * 4 ' 32bpp lngMaskStride = ((Size + 31) And Not 31) \ 8 ' 1bpp ' ByteArrays zur Aufnahme der Bilddaten dimensionieren ' bytPictArray enthält später die Bilddaten für die Iconbitmap ' bytMaskArray enthält später die Bilddaten für die Maskenbitmap ReDim bytPictArray((Size * lngPictStride) - 1) ReDim bytMaskArray((Size * lngMaskStride) - 1) ' Bitmapinfos zum konvertieren in das 32bpp ' Pixelformat festlegen -> tBITMAPINFO.bmiHeader tBITMAPINFO.bmiHeader.biSize = Len(tBITMAPINFO.bmiHeader) tBITMAPINFO.bmiHeader.biWidth = Size tBITMAPINFO.bmiHeader.biHeight = Size tBITMAPINFO.bmiHeader.biPlanes = 1 tBITMAPINFO.bmiHeader.biBitCount = [32 Bit Truecolor] tBITMAPINFO.bmiHeader.biCompression = BI_RGB tBITMAPINFO.bmiHeader.biSizeImage = UBound(bytPictArray) + 1 ' DC ermitteln lngDC = GetDC(0&) ' ist ein DC vorhanden If lngDC <> 0 Then ' Bild in das angegebene Pixelformat konvertieren. Die Bitmapdaten ' befinden sich nun im ByteArray bytPictArray. If GetDIBits256(lngDC, Image.handle, 0&, Size, bytPictArray(0), tBITMAPINFO, _ DIB_RGB_COLORS) <> 0 Then ' wenn eine Farbe transparent gemacht werden soll If UseTransparency Then ' Systemfarben konvertieren If OleTranslateColor(TransColor, 0&, TransColor) = 0 Then ' Alle Pixel im ByteArray bytPictArray durchlaufen For lngY = 0 To Size - 1 For lngX = 0 To Size - 1 ' Pixelpositionen in den ByteArrays berechnen lngPictPos = (lngY * lngPictStride) + (lngX * 4) lngMaskPos = (lngY * lngMaskStride) + (lngX \ 8) ' zunächst setzen wir den Alphakanal auf Opaque bytPictArray(lngPictPos + 3) = 255 ' entspricht die Farbe des Pixels im Bild mit der Farbe ' überein die transparent gemacht werden soll If RGB(bytPictArray(lngPictPos + 2), bytPictArray(lngPictPos _ + 1), bytPictArray(lngPictPos + 0)) = TransColor Then ' dann setzen wir diesen Pixel auf schwarz ' transparent bytPictArray(lngPictPos + 3) = 0 ' A bytPictArray(lngPictPos + 2) = 0 ' R bytPictArray(lngPictPos + 1) = 0 ' G bytPictArray(lngPictPos + 0) = 0 ' B ' diesen Pixel setzen wir dann für die Maskenbitmap ' auf Weiß bytMaskArray(lngMaskPos) = bytMaskArray(lngMaskPos) Or _ CByte(&H80 / (2 ^ (lngX And &H7))) End If Next lngX Next lngY End If End If ' wenn das Icon in eine andere Farbtiefe als 32bpp gespeichert ' werden soll, dann konvertieren wir das Bild nochmal in das ' entsprechende Pixelformat. If PixelFormat <> [32 Bit Truecolor] Then ' div. Standardeinstellungen für ' die entsprechenden Pixelformate Select Case PixelFormat ' 2 Farben, 1bpp Case IconFormat.[2 Color] ' Anzahl der Farben in der Palette lngPalCount = 2 ' Breite einer Bildzeile inkl. PadBytes berechnen lngPictStride = ((Size + 31) And Not 31) \ 8 ' 16 Farben, 4bpp Case IconFormat.[16 Color] lngPalCount = 16 lngPictStride = ((Size + 7) And Not 7) \ 2 ' 256 Farben, 8bpp Case IconFormat.[256 Color] lngPalCount = 256 lngPictStride = (Size + 3) And Not 3 ' 16Bit Case IconFormat.[16 Bit Truecolor] lngPictStride = ((Size * 2) + 2) And Not 2 ' 24Bit Case IconFormat.[24 Bit Truecolor] lngPictStride = ((Size * 3) + 3) And Not 3 End Select ' DIB-Bitmap erstellen -> hBmp32 hBmp32 = CreateDIBSection256(lngDC, tBITMAPINFO, DIB_RGB_COLORS, 0&, 0&, _ 0&) ' ist ein DIB-Bitmap vorhanden If hBmp32 <> 0 Then ' Bitmapdaten (32bpp) aus dem ByteArray bytPictArray in das ' DIB-Bitmap schreiben If SetDIBits256(lngDC, hBmp32, 0&, Size, bytPictArray(0), _ tBITMAPINFO, DIB_RGB_COLORS) <> 0 Then ' alte Daten im ByteArray bytPictArray löschen Erase bytPictArray ' ByteArray bytPictArray zur Aufnahme der Bilddaten ' erneut dimensionieren ReDim bytPictArray((Size * lngPictStride) - 1) ' Bitmapinfos zum konvertieren in das entsprechende ' Pixelformat festlegen -> tBITMAPINFO.bmiHeader tBITMAPINFO.bmiHeader.biSize = Len(tBITMAPINFO.bmiHeader) tBITMAPINFO.bmiHeader.biWidth = Size tBITMAPINFO.bmiHeader.biHeight = Size tBITMAPINFO.bmiHeader.biPlanes = 1 tBITMAPINFO.bmiHeader.biBitCount = PixelFormat tBITMAPINFO.bmiHeader.biCompression = BI_RGB tBITMAPINFO.bmiHeader.biSizeImage = UBound(bytPictArray) + 1 ' Bild in das angegebene Pixelformat konvertieren. ' Die konvertierten Bitmapdaten befinden sich nun ' wieder im ByteArray bytPictArray. If GetDIBits256(lngDC, hBmp32, 0&, Size, bytPictArray(0), _ tBITMAPINFO, DIB_RGB_COLORS) <> 0 Then End If End If ' DIB-Bitmap löschen Call DeleteObject(hBmp32) End If End If ' Daten für den Type IconHeader festlegen tIconHeader.ihReserved = 0 ' muss 0 sein tIconHeader.ihType = 1 ' 1 = Typ Icon tIconHeader.ihCount = 1 ' Anzahl der Icons in der Datei ' Daten für den Type IconEntry festlegen ' nur wenn die Icongröße < 256x256 Pixel ist If Size < [256x256] Then ' Größe des Icons speichern tIconEntry.ieWidth = tBITMAPINFO.bmiHeader.biWidth tIconEntry.ieHeight = tBITMAPINFO.bmiHeader.biHeight End If ' Anzahl der Ebenen und Bittiefe speichern tIconEntry.iePlanes = tBITMAPINFO.bmiHeader.biPlanes tIconEntry.ieBitCount = tBITMAPINFO.bmiHeader.biBitCount ' größe der Bitmapdaten in Bytes berechnen tIconEntry.ieBytesInRes = Len(tBITMAPINFOHEADER) + UBound(bytPictArray) + _ UBound(bytMaskArray) + 2 ' Beginn der Bitmap in der Icondatei berechnen tIconEntry.ieImageOffset = Len(tIconHeader) + Len(tIconEntry) ' Daten für den Type BITMAPINFOHEADER festlegen ' größe der Struktur speichern tBITMAPINFOHEADER.biSize = Len(tBITMAPINFOHEADER) ' Breite der Bitmap tBITMAPINFOHEADER.biWidth = tBITMAPINFO.bmiHeader.biWidth ' Höhe der Bitmap * 2 (Höhe Iconbitmap + Höhe Maskenbitmap) tBITMAPINFOHEADER.biHeight = tBITMAPINFO.bmiHeader.biHeight * 2 ' Anzahl der Ebenen, Bittiefe und Komprimierung speichern tBITMAPINFOHEADER.biPlanes = tBITMAPINFO.bmiHeader.biPlanes tBITMAPINFOHEADER.biBitCount = tBITMAPINFO.bmiHeader.biBitCount tBITMAPINFOHEADER.biCompression = tBITMAPINFO.bmiHeader.biCompression ' Bildgröße in Bytes tBITMAPINFOHEADER.biSizeImage = tBITMAPINFO.bmiHeader.biSizeImage ' ist lngPalCount > 0 dann ist es eine Palettenbitmap ' (1bpp, 4bpp und 8bpp) If lngPalCount > 0 Then ' dann müssen wir zur Größe der Bitmapdaten noch die Größe ' der Palette hinzu rechnen tIconEntry.ieBytesInRes = tIconEntry.ieBytesInRes + (lngPalCount * 4) ' nur wenn lngPalCount < 256 ist If lngPalCount < 256 Then ' dann die Anzahl der verwendeten Farben in der Palette ' speichern tIconEntry.ieColorCount = lngPalCount End If ' Anzahl der verwendeten Farben in der Palette tBITMAPINFOHEADER.biClrUsed = lngPalCount ' Anzahl der verwendeten Farben in der Palette tBITMAPINFOHEADER.biClrImportant = lngPalCount ' Array zur Aufnahme der Palettendaten ' dimensionieren. ReDim lngPalette(lngPalCount - 1) ' Palettendaten umkopieren, damit wir die ' Palette einfach mit Put ausgeben können. For lngPalItem = 0 To lngPalCount - 1 lngPalette(lngPalItem) = tBITMAPINFO.bmiColors(lngPalItem) Next lngPalItem End If ' ist die zuschreibenden Datei vorhanden If FileExists(IcoFileName) Then ' dann löschen wir die Datei Kill IcoFileName End If ' freie Dateinummer holen lngFNr = FreeFile ' neue Datei erstellen Open IcoFileName For Binary Access Write As #lngFNr ' IconHeader schreiben Put #lngFNr, , tIconHeader ' IconEntry schreiben Put #lngFNr, , tIconEntry ' BITMAPINFOHEADER schreiben Put #lngFNr, , tBITMAPINFOHEADER ' bei einer Palettenbitmap müsen wir hier die Palette mitschreiben If lngPalCount > 0 Then ' Palette schreiben Put #lngFNr, , lngPalette() End If ' Bilddaten der Iconbitmap schreiben Put #lngFNr, , bytPictArray ' Bilddaten der Maskenbitmap schreiben Put #lngFNr, , bytMaskArray ' zugriff auf die Datei schließen Close #lngFNr ' Rückgabewert der Funktion setzen SaveImageAsIcon = True End If ' DC freigeben Call ReleaseDC(0&, lngDC) End If End Function '------- Ende Modul "modPic2Ico" alias modPic2Ico.bas ------- '-------------- Ende Projektdatei Pic2Ico.vbp --------------
Tipp-Kompatibilität:
| Windows/VB-Version | Win32s | Win95 | Win98 | WinME | WinNT4 | Win2000 | WinXP |
| VB4 |  | | | | | | |
| VB5 | | | | | | | |
| VB6 | | | | | |  | |
Ihre Meinung
Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.