この発言は
#01144　ぜえた          さんの訂正(ビットマップ→アイコン ファイル)
に対するコメントです



TransparentColorが clBlack以外だとおかしくなるのを修正しました。

procedure SaveBitmapToStreamAsIcon(Bitmap: TBitmap; Stream: TStream);
を、次のように置き換えてください。

procedure SaveBitmapToStreamAsIcon(Bitmap: TBitmap; Stream: TStream);
const
  CI: TCursorOrIcon = (Reserved: 0; wType: rc3_Icon; Count: 1);
  MaxBitmapInfoSize = SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * 256;
var
  ColorInfoSize: Integer;
  ColorImageSize: Integer;
  MaskInfoSize: Integer;
  MaskImageSize: Integer;
  ColorCount: Integer;
  Size: Integer;
  Buf: Pointer;
  IconRec: PIconRec;
  ColorInfo: PBitmapInfo;
  ColorImage: Pointer;
  MaskImage: Pointer;
  TransparentColorReplacedBitmap: TBitmap;
  R: TRect;
  MaskInfo: array[0..MaxBitmapInfoSize-1] of Byte;
begin
  GetDIBSizes(Bitmap.Handle, ColorInfoSize, ColorImageSize);
  GetDIBSizes(Bitmap.MaskHandle, MaskInfoSize, MaskImageSize);
  Size := SizeOf(TCursorOrIcon) + SizeOf(TIconRec)
            + ColorInfoSize + ColorImageSize + MaskImageSize;
  Buf := AllocMem(Size);
  try
    Integer(IconRec) := Integer(Buf) + SizeOf(TCursorOrIcon);
    Integer(ColorInfo) := Integer(IconRec) + SizeOf(TIconRec);
    Integer(ColorImage) := Integer(ColorInfo) + ColorInfoSize;
    Integer(MaskImage) := Integer(ColorImage) + ColorImageSize;
    PCursorOrIcon(Buf)^ := CI;
    TransparentColorReplacedBitmap := TBitmap.Create;
    try
      with TransparentColorReplacedBitmap do begin
        Assign(Bitmap);
        R := Rect(0, 0, Width, Height);
        Canvas.Brush.Color := clBlack;
        Canvas.BrushCopy(R, Bitmap, R, Bitmap.TransparentColor);
        GetDIB(Handle, Palette, ColorInfo^, ColorImage^);
      end;
    finally
      TransparentColorReplacedBitmap.Free;
    end;
    GetDIB(Bitmap.MaskHandle, 0, MaskInfo, MaskImage^);
    with IconRec^, ColorInfo^.bmiHeader do begin
      if (biWidth >= 1) and (biWidth < 256) then Width := biWidth;
      if (biHeight >= 1) and (biHeight < 256) then Height := biHeight;
      ColorCount := 1 shl (biPlanes * biBitCount);
      if (ColorCount >= 1) and (ColorCount < 256) then
        Colors := ColorCount;
      Planes := biPlanes;
      BitCount := biBitCount;
      DIBSize := ColorInfoSize + ColorImageSize + MaskImageSize;
      DIBOffset := SizeOf(TCursorOrIcon) + SizeOf(TIconRec);
    end;
    with PBitmapInfoHeader(ColorInfo)^ do biHeight := biHeight * 2;
    Stream.WriteBuffer(Buf^, Size);
  finally
    FreeMem(Buf);
  end;
end;

                                                    ぜえた (QZC05100)
 



Original document by ぜえた          氏 ID:(QZC05100)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。