この発言は
#01134　かとちん        さんのビットマップ→アイコン ファイル変換処理
に対するコメントです

この発言に対し以下のコメントが寄せられています

#01144　ぜえた          さん　訂正(ビットマップ→アイコン ファイル)




　かとちん さん、こんにちは。



16色のアイコンでも内部では画面の色数になっているのではないでしょうか。
そのために VCLではアイコンをファイルにセーブするとき16色に固定している
んだと思います。
したがって、256色のアイコンファイルを作るには、ビットマップから（アイ
コンを経由せずに）直接アイコンファイルにするしかないでしょう。

ということで、直接変換するように作ってみました。
Bitmap の Transparentは Trueにしておいてください。

const
  rc3_StockIcon = 0;
  rc3_Icon = 1;
  rc3_Cursor = 2;

type
  PCursorOrIcon = ^TCursorOrIcon;
  TCursorOrIcon = packed record
    Reserved: Word;
    wType: Word;
    Count: Word;
  end;

  PIconRec = ^TIconRec;
  TIconRec = packed record
    Width: Byte;
    Height: Byte;
    Colors: Word;
    Planes: Word;
    BitCount: Word;
    DIBSize: Longint;
    DIBOffset: Longint;
  end;

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;
  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;
    GetDIB(Bitmap.Handle, 0, ColorInfo^, ColorImage^);
    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 := Size;
      DIBOffset := SizeOf(TCursorOrIcon) + SizeOf(TIconRec);
    end;
    with PBitmapInfoHeader(ColorInfo)^ do biHeight := biHeight * 2;
    Stream.WriteBuffer(Buf^, Size);
  finally
    FreeMem(Buf);
  end;
end;

procedure SaveBitmapToFileAsIcon(Bitmap: TBitmap; const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveBitmapToStreamAsIcon(Bitmap, Stream);
  finally
    Stream.Free;
  end;
end;

//サンプル

procedure TForm1.Button1Click(Sender: TObject);
var
  Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  try
    Bitmap.LoadFromFile('C:\Test.bmp');
    Bitmap.TransparentMode := tmAuto;
    Bitmap.Transparent := True;
    SaveBitmapToFileAsIcon(Bitmap, 'C:\Test.ico');
  finally
    Bitmap.Free;
  end;
end;

                                                    ぜえた (QZC05100)
 



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

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