delphi 跨平台的，在FMX中读取ICON文件的每一帧到Bitmap  
官方Delphi 学习QQ群： 682628230（三千人）
频道

  1. 人气：
  2. 放大
  3. 缩小
  4. 二维码
  5. 赞赏

delphi 跨平台的，在FMX中读取ICON文件的每一帧到Bitmap

昨天在使用FreeImage的时候发现FreeImage对ICON的处理有问题，32位的帧读出来的背景居然是黑的。我猜应该是32位没有And的Mask数据。而它按照24位以下的处理方式把Alpha值填成255了。

只能自己动手写代码，也不复杂，算上把Windows单元抽出来声明的结构体，也就300行。经测试可以在Win32,Win64，Android,FMX for Linux上可以正常使用。

如此的简单，就不上传工程了，直接贴代码就是了。

unit FMX.Images.icon;
 
{
  wr960204武稀松
  2017.4.18
  FMX读取ICO，ICON文件各个帧到TBitmap的。
  经测试支持Win32, Win64,Android,FMX for Linux
}
interface
 
uses
  System.Types, // Winapi.Windows,
  System.Classes, System.sysutils, FMX.Graphics,
  System.Generics.Collections;
 
const
  PNG_Signature = $0A1A0A0D474E5089;
 
type
  // 从WinAPi.Windows单元拷贝过来的。为了不引用Windows单元，以便跨平台
  tagBITMAPINFOHEADER = record
    biSize: DWORD;
    biWidth: DWORD;
    biHeight: DWORD;
    biPlanes: Word;
    biBitCount: Word;
    biCompression: DWORD;
    biSizeImage: DWORD;
    biXPelsPerMeter: DWORD;
    biYPelsPerMeter: DWORD;
    biClrUsed: DWORD;
    biClrImportant: DWORD;
  end;
 
  TBitmapInfoHeader = tagBITMAPINFOHEADER;
  BITMAPINFOHEADER = tagBITMAPINFOHEADER;
 
  PRGBTriple = ^TRGBTriple;
 
  tagRGBTRIPLE = packed record
    rgbtBlue: Byte;
    rgbtGreen: Byte;
    rgbtRed: Byte;
  end;
 
  TRGBTriple = tagRGBTRIPLE;
  RGBTRIPLE = tagRGBTRIPLE;
  PRGBQuad = ^TRGBQuad;
 
  tagRGBQUAD = packed record
    rgbBlue: Byte;
    rgbGreen: Byte;
    rgbRed: Byte;
    rgbReserved: Byte;
  end;
 
  TRGBQuad = tagRGBQUAD;
  RGBQUAD = tagRGBQUAD;
 
  TIconDirEntry = packed record
    bWidth: Byte;
    bHeight: Byte;
    bColorCount: Byte;
    bReserved: Byte;
    wPlanes: Word;
    wBitCount: Word;
    dwBytesInRes: DWORD;
    dwImageOffset: DWORD;
  end;
 
  // Icon的结构体
  PIconDirEntry = ^TIconDirEntry;
 
  TIconDir = packed record
    idReserved: Word;
    idType: Word;
    idCount: Word;
    idEntries: array [0 .. $0] of TIconDirEntry;
  end;
 
  PIconDir = ^TIconDir;
 
  TICONIMAGE = packed record
    icHeader: BITMAPINFOHEADER; // ptr to header
    {
      icColors: array [0 .. ColorCount] of RGBQUAD; //
      icXOR: array [0 .. bWidth * bHeight] of Byte; //
      icAND: array [0 .. bWidth * bHeight / bColorCount] of Byte;
    }
  end;
 
  TICONIMAGEicColors = packed record
    icColors: array [0 .. $FFFF] of RGBQUAD; //
  end;
 
  TICONIMAGEicXOR = packed record
    icXOR: array [0 .. $FFFF] of Byte; //
  end;
 
  TICONIMAGEicAND = packed record
    icAND: array [0 .. $FFFF] of Byte;
  end;
 
  PICONIMAGE = ^TICONIMAGE;
  PTICONIMAGEicColors = ^TICONIMAGEicColors;
  PICONIMAGEicXOR = ^TICONIMAGEicXOR;
  PICONIMAGEicAND = ^TICONIMAGEicAND;
 
  TBmpList = TObjectList;
 
function LoadIcon(AFileName: string; Abmps: TBmpList): Boolean;
function LoadIconByStream(AStream: TStream; Abmps: TBmpList): Boolean;
function LoadIconByBuf(ABuf: PBYTE; ACount: Integer; Abmps: TBmpList): Boolean;
 
implementation
 
function LoadIcon(AFileName: string; Abmps: TBmpList): Boolean;
var
  fs: TFileStream;
begin
  fs := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
  Result := LoadIconByStream(fs, Abmps);
  fs.Free;
end;
 
function LoadIconByStream(AStream: TStream; Abmps: TBmpList): Boolean;
var
  bs: TBytes;
  ICONDIR: PIconDir;
 
begin
  Result := False;
  SetLength(bs, AStream.Size);
  AStream.Read(bs[0], Length(bs));
  Result := LoadIconByBuf(@bs[0], Length(bs), Abmps);
 
end;
 
{$POINTERMATH ON}
 
function LoadPngFrame(ABuf: PBYTE; ACount: Integer; Abmp: Tbitmap): Boolean;
var
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  ms.Write(ABuf^, ACount);
  ms.Position := 0;
  Abmp.LoadFromStream(ms);
  ms.Free;
  Result := True;
end;
 
function LoadIconFrame(lpIconDir: PIconDir; lpIconDirEntry: PIconDirEntry;
  lpIconImage: PICONIMAGE; Abmp: Tbitmap): Boolean;
var
  width, height, realBitsCount: Integer;
  x, y: Integer;
  hasAndMask: Boolean;
  lpColors: PRGBQuad;
  lpColorsTriple: PRGBTriple ABSOLUTE lpColors;
  lpColors256: PBYTE ABSOLUTE lpColors;
  lpXor: PBYTE;
  lpAnd: PBYTE;
  //
  colorMapSize, XorSize, AndSize: Integer;
  boundary, shift, shift2, index, bit, mask: Integer;
  //
  D: TBitmapData;
  image: PRGBQuad;
begin
  Result := False;
  {不能用lpIconDirEntry中的高和宽，教训是有些ICO文件不规范，这里的高和宽是0,
  所致最好用lpIconImage^.icHeader中的高和宽
  }
  width := lpIconImage^.icHeader.biWidth;
  height := lpIconImage^.icHeader.biHeight div 2; //高度等于 xor + and mask
  realBitsCount := lpIconImage^.icHeader.biBitCount;
  hasAndMask := (realBitsCount < 32) and
    (height <> lpIconImage^.icHeader.biHeight);
  colorMapSize := SizeOf(RGBQUAD) * (1 shl realBitsCount);
 
  if lpIconImage^.icHeader.biSize = 0 then
    lpColors := PRGBQuad(UInt64(lpIconImage) + SizeOf(TICONIMAGE) { 40 } )
  else
    lpColors := PRGBQuad(UInt64(lpIconImage) + lpIconImage^.icHeader.biSize { 40 } );
  lpXor := PBYTE(UInt64(lpColors) + colorMapSize);
 
  Abmp.Resize(width, height);
  if Abmp.Map(TMapAccess.Write, D) then
  begin
    case realBitsCount of
      32: // 32位色
        begin
          for y := 0 to height - 1 do
          begin
            image := D.GetScanline(y);
            for x := 0 to width - 1 do
            begin
              shift := x;
              shift2 := (x + (height - y - 1) * width);
              {
                image[shift].rgbBlue := lpColors[shift2].rgbBlue;
                image[shift].rgbGreen := lpColors[shift2].rgbGreen;;
                image[shift].rgbRed := lpColors[shift2].rgbRed;
                image[shift].rgbReserved := 255;//估计是Free Image这里填写的255.应该用32位色自己的.所以FreeImage拿出来的32位Frame背景居然是黑的
              }
              image[shift] := lpColors[shift2];
            end;
          end;
        end;
      24: // 24位色
        begin
          for y := 0 to height - 1 do
          begin
            image := D.GetScanline(y);
            for x := 0 to width - 1 do
            begin
              shift := x;
              shift2 := (x + (height - y - 1) * width);
              image[shift].rgbBlue := lpColorsTriple[shift2].rgbtBlue;
              image[shift].rgbGreen := lpColorsTriple[shift2].rgbtGreen;;
              image[shift].rgbRed := lpColorsTriple[shift2].rgbtRed;
              image[shift].rgbReserved := 255;
            end;
          end;
        end;
      8: // 256色
        begin
          for y := 0 to height - 1 do
          begin
            image := D.GetScanline(y);
            for x := 0 to width - 1 do
            begin
              shift := x;
              shift2 := (x + (height - y - 1) * width);
              index := lpXor[shift2];
              image[shift].rgbBlue := lpColors[index].rgbBlue;
              image[shift].rgbGreen := lpColors[index].rgbGreen;
              image[shift].rgbRed := lpColors[index].rgbRed;
              image[shift].rgbReserved := 255;
 
            end;
          end;
        end;
      4: // 16色
        begin
          for y := 0 to height - 1 do
          begin
            image := D.GetScanline(y);
            for x := 0 to width - 1 do
            begin
              shift := x;
              shift2 := (x + (height - y - 1) * width);
              Index := lpXor[shift2 div 2];
 
              if (shift2 mod 2) = 0 then
                Index := (Index shr 4) and $F
              else
                Index := Index and $F;
              image[shift].rgbBlue := lpColors[Index].rgbBlue;
              image[shift].rgbGreen := lpColors[Index].rgbGreen;
              image[shift].rgbRed := lpColors[Index].rgbRed;
              image[shift].rgbReserved := 255;
            end;
          end;
        end;
      1: // 两色
        begin
          boundary := width;
          while (boundary mod 32) <> 0 do
            Inc(boundary); // 32bit对齐
          //
          for y := 0 to height - 1 do
          begin
            image := D.GetScanline(y);
            for x := 0 to width - 1 do
            begin
              shift := x;
              shift2 := (x + (height - y - 1) * boundary);
              index := lpXor[shift2 div 8];
              bit := 7 - (x mod 8);
              index := (index shr bit) and $01;
 
              image[shift].rgbBlue := lpColors[index].rgbBlue;
              image[shift].rgbGreen := lpColors[index].rgbGreen;;
              image[shift].rgbRed := lpColors[index].rgbRed;
              image[shift].rgbReserved := 255;
 
            end;
          end;
        end;
    end;
    // if False then
    if hasAndMask then
    begin
      // 定位AndMask的位置
      boundary := width * realBitsCount; // 换算到位
      while (boundary mod 32) <> 0 do
        Inc(boundary);
      lpAnd := lpXor + (boundary * height div 8); // div 8 换算到字节
      // 计算对齐的宽度
      boundary := width;
      while (boundary mod 32) <> 0 do
        Inc(boundary); // 32bit对齐
 
      for y := 0 to height - 1 do
      begin
        image := D.GetScanline(y);
        for x := 0 to width - 1 do
        begin
          shift := x;
          bit := 7 - (x mod 8);
          shift2 := (x + (height - y - 1) * boundary) div 8;
          mask := ($01 and (lpAnd[shift2] shr bit));
          image[shift].rgbReserved := image[shift].rgbReserved * (1 - mask);
        end;
      end;
    end;
    Abmp.Unmap(D);
  end;
 
end;
 
function LoadIconByBuf(ABuf: PBYTE; ACount: Integer; Abmps: TBmpList): Boolean;
var
  ICONDIR: PIconDir ABSOLUTE ABuf;
  iconDirEntry: PIconDirEntry;
  IconImage: PICONIMAGE;
  i: Integer;
  isPngFormat: Boolean;
  lBmp: Tbitmap;
begin
 
  Result := False;
  if (ICONDIR^.idReserved <> 0) or (ICONDIR^.idType <> 1) or
    (ICONDIR^.idCount <= 0) then
    Exit;
 
  for i := 0 to ICONDIR^.idCount - 1 do
  begin
    iconDirEntry := @ICONDIR^.idEntries[i];
    IconImage := PICONIMAGE(@ABuf[iconDirEntry.dwImageOffset]);
 
    // 新格式的ICON里面可以包含PNG图片
    isPngFormat := PNG_Signature = PUint64(IconImage)^;
    lBmp := Tbitmap.Create;
    if isPngFormat then
    begin
      LoadPngFrame(PBYTE(IconImage), iconDirEntry^.dwBytesInRes, lBmp);
    end
    else
    begin
      LoadIconFrame(ICONDIR, iconDirEntry, IconImage, lBmp);
    end;
    Abmps.Add(lBmp);
    Result := True;
  end;
end;
{$POINTERMATH OFF}
 
end.

来源：http://www.raysoftware.cn/?p=589

推荐分享
最新信息 delphi13 多线程优化 TThreade... delphi 如何 FastMM配置 delphi13 FireDAC增强 并行备份... delphi12 Embarcadero ld... delphi 查看 cpu 核心数
热门信息 delphi 动态数组的使用 delphi多线程TThread详解 delphi try except语句 和 try finally语... delphi中常用字符串处理函数 delphi Inc函数和Dec函数的用法
推荐区 txt文本处理 查询128 说一段 简搜 短笑话 IP查询 正则大全 在线加密解密工具 在线文本筛选工具 1234828网址导航 windows库
图文皆来源于网络，内容仅做公益性分享，版权归原作者所有，如有侵权请告知删除！
  1. 关于我们
  2. 联系我们
 

Copyright © 2014 DelphiW.com 开发 源码 文档 技巧 All Rights Reserved
晋ICP备14006235号-8 晋公网安备 14108102000087号

执行时间: 0.4040379524231 seconds