IconReader

[Jakson]

Nachdem ich verzweifelt nach einer Komponente gesucht habe die es ermöglicht eine bestimmte Auflösung aus eine Icon-Datei zu laden und nichts zu finden war habe ich mich entschlossen selber eine zu erstellen.

Hier nun meine Umsetzung.

Eine Icon-Datei ist nichts anderes als eine Sammlung von BMP/PNG Bildern mit einem einfachen Dateikopf davor.
Siehe hier: http://en.wikipedia.org/wiki/ICO_(file_format)

Eine Besonderheit dabei ist das die BMP Bilder doppelt so hoch in der Icon-Datei gespeichert sind wie angegeben.
Der erste Teil beinhaltet das eigentliche Bild der Rest die Maske in Monochrome.
Seit Windows Vista können auch PNG Bilder eingefügt werden.

Zur einfacheren Handhabung werden die Bilder intern in eine PNG Datei konvertiert. Dadurch muss man sich um das zeichnen der Maske nicht mehr kümmern.

Dazu verwende ich die Unit "PngFunctions" aus der Sammlung "PngComponents" von Embarcadero
Siehe hier: http://cc.embarcadero.com/item/26127

Ich hoffe meine Umsetzung ist einigermaßen verständlich und kann gut weiterverwendet werden.
Ich habe sogar ein kleines Beispiel Programm beigelegt.

Leider hat die Funktion "ConvertToPNG" einen kleinen Fehler.
Mit meiner Änderung ist es möglich aus 32bit Bildern den Alpha Kanal zu extrahieren.

Code:

else if ((Source AS TBitmap).PixelFormat = pf32bit) AND  ((Source AS TBitmap).AlphaFormat = afDefined)

Delphi-Quellcode:

procedure ConvertToPNG(Source: TGraphic; Dest: TPngImage);
var
  MaskLines: array of pngimage.PByteArray;

  function CompareColors(const Color1: TRGBTriple; const Color2: TColor): Boolean;
  begin
    Result := (Color1.rgbtBlue = Color2 shr 16 and $FF) and
      (Color1.rgbtGreen = Color2 shr 8 and $FF) and
      (Color1.rgbtRed = Color2 and $FF);
  end;

  function ColorToTriple(const Color: TColor): TRGBTriple;
  begin
    Result.rgbtBlue := Color shr 16 and $FF;
    Result.rgbtGreen := Color shr 8 and $FF;
    Result.rgbtRed := Color and $FF;
  end;

  function GetAlphaMask(SourceColor: TBitmap):Boolean;
  type
    TBitmapInfo = packed record
      bmiHeader: TBitmapV4Header;
      //Otherwise I may not get per-pixel alpha values.
      bmiColors: array[0..0] of TRGBQuad;
    end;
  var
    Bits: PRGBALine;
    BitmapInfo: TBitmapInfo;
    I, X, Y: Integer;
    BitsSize: Integer;
  begin
    Result := False;
    BitsSize := 4 * SourceColor.Width * SourceColor.Height;
    Bits := AllocMem(BitsSize);
    try
      ZeroMemory(Bits, BitsSize);
      ZeroMemory(@BitmapInfo, SizeOf(BitmapInfo));
      BitmapInfo.bmiHeader.bV4Size := SizeOf(BitmapInfo.bmiHeader);
      BitmapInfo.bmiHeader.bV4Width := SourceColor.Width;
      BitmapInfo.bmiHeader.bV4Height := -SourceColor.Height;
      //Otherwise the image is upside down.
      BitmapInfo.bmiHeader.bV4Planes := 1;
      BitmapInfo.bmiHeader.bV4BitCount := 32;
      BitmapInfo.bmiHeader.bV4V4Compression := BI_BITFIELDS;
      BitmapInfo.bmiHeader.bV4SizeImage := BitsSize;

      if GetDIBits(SourceColor.Canvas.Handle, SourceColor.Handle, 0,
        SourceColor.Height, Bits, Windows.PBitmapInfo(@BitmapInfo)^,
        DIB_RGB_COLORS) > 0 then begin
        //Because Win32 API is a piece of crap when it comes to icons, I have to check
        //whether an has an alpha-channel the hard way.
        for I := 0 to (SourceColor.Height * SourceColor.Width) - 1 do begin
          if Bits[I].rgbReserved <> 0 then begin
            Result := True;
            Break;
          end;
        end;

        if Result then begin
          //OK, so not all alpha-values are 0, which indicates the existence of an
          //alpha-channel.
          I := 0;
          for Y := 0 to SourceColor.Height - 1 do
            for X := 0 to SourceColor.Width - 1 do begin
              MaskLines[Y][X] := Bits[I].rgbReserved;
              Inc(I);
            end;
        end;
      end;
    finally
      FreeMem(Bits, BitsSize);
    end;
  end;

  function WinXPOrHigher: Boolean;
  var
    Info: TOSVersionInfo;
  begin
    Info.dwOSVersionInfoSize := SizeOf(Info);
    GetVersionEx(Info);
    Result := (Info.dwPlatformId = VER_PLATFORM_WIN32_NT) and
      ((Info.dwMajorVersion > 5) or
      ((Info.dwMajorVersion = 5) and (Info.dwMinorVersion >= 1)));
  end;

var
  Temp, SourceColor, SourceMask: TBitmap;
  X, Y: Integer;
  Line: PRGBLine;
  MaskLine, AlphaLine: pngimage.PByteArray;
  TransparentColor, CurrentColor: TColor;
  IconInfo: TIconInfo;
  AlphaNeeded: Boolean;
begin
  Assert(Dest <> nil, 'Dest is nil!');
  //A PNG does not have to be converted
  if Source is TPngImage then begin
    Dest.Assign(Source);
    Exit;
  end;

  AlphaNeeded := False;
  Temp := TBitmap.Create;
  SetLength(MaskLines, Source.Height);
  for Y := 0 to Source.Height - 1 do begin
    MaskLines[Y] := AllocMem(Source.Width);
    FillMemory(MaskLines[Y], Source.Width, 255);
  end;
  try
    //Initialize intermediate color bitmap
    Temp.Width := Source.Width;
    Temp.Height := Source.Height;
    Temp.PixelFormat := pf24bit;

    //Now figure out the transparency
    if Source is TBitmap then begin
      if Source.Transparent then begin
        //TBitmap is just about comparing the drawn colors against the TransparentColor
        if TBitmap(Source).TransparentMode = tmFixed then
          TransparentColor := TBitmap(Source).TransparentColor
        else
          TransparentColor := TBitmap(Source).Canvas.Pixels[0, Source.Height - 1];

        for Y := 0 to Temp.Height - 1 do begin
          Line := Temp.ScanLine[Y];
          MaskLine := MaskLines[Y];
          for X := 0 to Temp.Width - 1 do begin
            CurrentColor := GetPixel(TBitmap(Source).Canvas.Handle, X, Y);
            if CurrentColor = TransparentColor then begin
              MaskLine^[X] := 0;
              AlphaNeeded := True;
            end;
            Line[X] := ColorToTriple(CurrentColor);
          end;
        end;
      end
      else if ((Source AS TBitmap).PixelFormat = pf32bit) AND  ((Source AS TBitmap).AlphaFormat = afDefined) then begin
        // Extract Alphachannel from BmpFile
        Temp.Canvas.Draw(0, 0, Source);
        AlphaNeeded := GetAlphaMask(Source AS TBitmap);
      end
      else begin
        Temp.Canvas.Draw(0, 0, Source);
      end;
    end
    else if Source is TIcon then begin
      //TIcon is more complicated, because there are bitmasked (classic) icons and
      //alphablended (modern) icons. Not to forget about the "inverse" color.
      GetIconInfo(TIcon(Source).Handle, IconInfo);
      SourceColor := TBitmap.Create;
      SourceMask := TBitmap.Create;
      try
        SourceColor.Handle := IconInfo.hbmColor;
        SourceMask.Handle := IconInfo.hbmMask;
        Temp.Canvas.Draw(0, 0, SourceColor);
        for Y := 0 to Temp.Height - 1 do begin
          MaskLine := MaskLines[Y];
          for X := 0 to Temp.Width - 1 do begin
            if GetPixel(SourceMask.Canvas.Handle, X, Y) <> 0 then begin
              MaskLine^[X] := 0;
              AlphaNeeded := True;
            end;
          end;
        end;
        if (GetDeviceCaps(SourceColor.Canvas.Handle, BITSPIXEL) = 32) and WinXPOrHigher then begin
          //This doesn't neccesarily mean we actually have 32bpp in the icon, because the
          //bpp of an icon is always the same as the display settings, regardless of the
          //actual color depth of the icon :(
          AlphaNeeded := GetAlphaMask(SourceColor);
        end;
        //This still doesn't work for alphablended icons...
      finally
        SourceColor.Free;
        SourceMask.Free
      end;
    end;

    //And finally, assign the destination PNG image
    Dest.Assign(Temp);
    if AlphaNeeded then begin
      Dest.CreateAlpha;
      for Y := 0 to Dest.Height - 1 do begin
        AlphaLine := Dest.AlphaScanline[Y];
        CopyMemory(AlphaLine, MaskLines[Y], Temp.Width);
      end;
    end;

  finally
    for Y := 0 to Source.Height - 1 do
      FreeMem(MaskLines[Y], Source.Width);
    Temp.Free;
  end;
end;

Ich hab den Bereich Codesammlung nicht mehr gefunden.
Nur "Software-Projekte der Mitglieder" und diese Unit ist nicht wirklich ein eigenes Projekt.
Sollte es einen besseren Bereich geben dafür geben bitte ich darum diesen Eintrag dahin zu verschieben.

Danke Jakson