Chip 2002 December/Chip_2002-12_cd1.bin/zkuste/delphi/kompon/d6/AHICON32.ZIP/Icon32/Icon32.pas

Pascal/Delphi Source File | 2002-09-18 | 10KB | 397 lines

{
  Icon32

  This notice may not be removed from or altered in any source distribution.

  "Author" herein refers to Abduraghman Hendricks (the creator of the Icon32). "Software" refers to all files
  included with Icon32 distribution package.

  Please note that the Author hereby states that this package is provided "as is" and without any express or
  implied warranties, including, but not without limitation, the implied warranties of merchantability and fitness
  for a particular purpose. In other words, the Author accepts no liability for any damage that may result from
  using Icon32.

  Icon32 is distributed as a freeware. You are free to use Icon32 as part of your application for any purpose
  including freeware, commercial and shareware applications, provided an explicit credit is given to the author
  in application's about box and/or accompanying documentation.

  The origin of this software must not be misrepresented; you must not claim your authorship.
  All redistributions must retain the original copyright notice.

}
unit Icon32;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs;

type
  ByteArray = array of Byte;
  TIcon32FileString = type string;
  TBlendMode = (bmColor, bmAlpha);
  TIconSize = (is16,is24,is32,is48);

  TIcon32 = class(TGraphicControl)
  private
    FData      : Pointer;
    FDataSize  : Integer;
    FIcon32Name: TIcon32FileString;
    FBMP       : TBitmap;
    FBlendMode : TBlendMode;
    FBGColor     : TColor;
    FIconSize  : TIconSize;
    FUpdate    : boolean;
    procedure WriteData(Stream: TStream);
    procedure ReadData(Stream: TStream);

    procedure SetBGColor(const Value: TColor);
    procedure SetBlendMode(const Value: TBlendMode);
    procedure SetIconSize(const Value: TIconSize);
    procedure SetIcon32Name(const Value: TIcon32FileString);
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    function Empty: Boolean;
    procedure LoadFromFile(const FileName: String);
    procedure LoadFromStream(S: TStream);
    procedure SaveToFile(const FileName: String);
    procedure SaveToStream(S: TStream);
    procedure LoadBMP;
    function Equal(Ico: TIcon32): Boolean;
  published
    property Icon32Name : TIcon32FileString read FIcon32Name write SetIcon32Name;
    property BGColor: TColor read FBGColor Write SetBGColor default clBtnface;
    property BlendMode: TBlendMode read FBlendMode Write SetBlendMode default bmColor;
    property IconSize: TIconSize read FIconSize Write SetIconSize default is32;
  end;

function BlendColors(const Color1, Color2: TColor; Amount: Extended): TColor;

procedure Register;

implementation

{ TIcon32 }

procedure Register;
begin
  RegisterComponents('Portrix', [TIcon32]);
end;

constructor TIcon32.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  FBMP   := TBitmap.Create;
  FBGColor := clBtnFace;
  FIconSize := is32;
  Width  := 32;
  Height := 32;
  FUpdate := True;
end;

procedure TIcon32.DefineProperties(Filer: TFiler);
  function DoWrite: Boolean;
  begin
    if Filer.Ancestor <> nil then
      Result := not (Filer.Ancestor is TIcon32) or
        not Equal(TIcon32(Filer.Ancestor))
    else
      Result := not Empty;
  end;

begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('Data', ReadData, WriteData, DoWrite);
end;

destructor TIcon32.Destroy;
begin
  FBMP.Free;
  inherited;
end;

function StreamsEqual(S1, S2: TMemoryStream): Boolean;
begin
  Result := (S1.Size = S2.Size) and CompareMem(S1.Memory, S2.Memory, S1.Size);
end;

function TIcon32.Empty: Boolean;
begin
  Result := FDataSize = 0;
end;

function TIcon32.Equal(Ico: TIcon32): Boolean;
var
  MyImage, WavImage: TMemoryStream;
begin
  Result := (Ico <> nil) and (ClassType = Ico.ClassType);
  if Empty or Ico.Empty then
  begin
    Result := Empty and Ico.Empty;
    Exit;
  end;
  if Result then
  begin
    MyImage := TMemoryStream.Create;
    try
      SaveToStream(MyImage);
      WavImage := TMemoryStream.Create;
      try
        Ico.SaveToStream(WavImage);
        Result := StreamsEqual(MyImage, WavImage);
      finally
        WavImage.Free;
      end;
    finally
      MyImage.Free;
    end;
  end;
end;

procedure TIcon32.LoadBMP;
var
  buf: ByteArray;
  i,x,y,DataSize,bw,bs: Integer;
  BPP: Byte;
  col: TColor;
  bmp2: TBitmap;
  dc: HDC;
begin
  buf := nil;

  if FDataSize < 1 then Exit;

{    FBMP.Canvas.Brush.Style := bsSolid;
  FBMP.Canvas.Brush.Color := FBGColor;
  FBMP.Canvas.FillRect(Rect(0,0,FBMP.Width,FBMP.Height));
  Invalidate;}

  buf := ByteArray(FData);

  BPP        := buf[12];

  if BPP <> 32 then begin
    MessageDlg('Invalid icon',mtError,[mbOk],0);
    FIcon32Name := '';
    if not Empty then
      FreeMem(FData, FDataSize);
    FDataSize := 0;
    Exit;
  end;

  DataSize   := buf[14] + (buf[15] shl 8) + (buf[16] shl 16) + (buf[17] shl 24);
  bw         := buf[26] + (buf[27] shl 8) + (buf[28] shl 16) + (buf[29] shl 24);
  bs         := buf[42] + (buf[43] shl 8) + (buf[44] shl 16) + (buf[45] shl 24);

  case bw of
    16: IconSize := is16;
    24: IconSize := is24;
    32: IconSize := is32;
    48: IconSize := is48;
  end;

  if bs < 100 then
    bs := DataSize - 104;

  FBMP.Width := buf[6];
  FBMP.Height := buf[6];

  bmp2 := TBitmap.Create;
  bmp2.Width  := FBMP.Width;
  bmp2.height := FBMP.Height;

  Self.Visible := False;
  Self.Invalidate;

  dc := GetDc(0);

  bitblt(bmp2.Canvas.Handle,0,0,bw,bw,dc,
         Parent.Left+4+Self.Left,
         Parent.Top+23+Self.Top,
         SRCCOPY
  );

  x := 0; y := bw-1;
  i := 62;
  while i < bs+62 do begin
    col := RGB(buf[i+2],buf[i+1],buf[i]);

    if BPP = 32 then begin
      if FBlendMode = bmColor then
        col := BlendColors(FBGColor,RGB(buf[i+2],buf[i+1],buf[i]),buf[i+3] / 256)
      else begin
        col := BlendColors(bmp2.Canvas.Pixels[x,y],RGB(buf[i+2],buf[i+1],buf[i]),buf[i+3] / 256);
      end;
    end;

    FBMP.Canvas.Pixels[x,y] := col;

    Inc(i,BPP div 8);
    Inc(x);
    if x > bw-1 then begin
      x := 0;
      Dec(y);
    end;
    if y = -1 then begin
      break;
    end;
  end;
  bmp2.Free;

  Self.Visible := true;
  Invalidate;
end;

procedure TIcon32.LoadFromFile(const FileName: String);
var
  F: TFileStream;
begin
  F := TFileStream.Create(FileName, fmOpenRead);
  try
    LoadFromStream(F);
  finally
    F.Free;
  end;
end;

procedure TIcon32.LoadFromStream(S: TStream);
begin
  if not Empty then
    FreeMem(FData, FDataSize);
  FDataSize := 0;
  FData := AllocMem(S.Size);
  FDataSize := S.Size;
  S.Read(FData^, FDataSize);
  LoadBMP;
end;

procedure TIcon32.Paint;
begin
  inherited;
  if FBlendMode = bmAlpha then begin
    if FUpdate then begin
        LoadBMP;
      FUpdate := False;
    end;
  end;
  Canvas.Draw(0,0,FBMP);
end;

procedure TIcon32.ReadData(Stream: TStream);
begin
  LoadFromStream(Stream);
end;

procedure TIcon32.SaveToFile(const FileName: String);
var
  F: TFileStream;
begin
  F := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(F);
  finally
    F.Free;
  end;
end;

procedure TIcon32.SaveToStream(S: TStream);
begin
  if not Empty then
    S.Write(FData^, FDataSize);
end;

procedure TIcon32.SetBGColor(const Value: TColor);
begin
  FBGColor := Value;
  if FIcon32Name <> '' then LoadBMP;
end;

procedure TIcon32.SetBlendMode(const Value: TBlendMode);
begin
  FBlendMode := Value;
  if FIcon32Name <> '' then LoadBMP;
end;

procedure TIcon32.SetIcon32Name(const Value: TIcon32FileString);
begin
  if Value <> '' then begin
    if not FileExists(Value) then Exit;
    FIcon32Name := ExtractFileName(Value);
    if (not (csLoading in ComponentState)) and FileExists(Value) then
      LoadFromFile(Value);
  end
  else begin
    FIcon32Name := '';
    if not Empty then
      FreeMem(FData, FDataSize);
    FDataSize := 0;
  end;
end;

procedure TIcon32.SetIconSize(const Value: TIconSize);
begin
  FIconSize := Value;
  case Value of
    is16 :     begin
              Width  := 16;
              Height := 16;
            end;
    is24 :     begin
              Width  := 24;
              Height := 24;
            end;
    is32 :     begin
              Width  := 32;
              Height := 32;
            end;
    is48 :     begin
              Width  := 48;
              Height := 48;
            end;
  end;
end;

function BlendColors(const Color1, Color2: TColor; Amount: Extended): TColor;
var
  R,R2,G,G2,B,B2: Integer;
  win1, win2: Integer;
begin
  win1 := ColorToRGB(color1);
  win2 := ColorToRGB(color2);

  R := GetRValue(win1);
  G := GetGValue(win1);
  B := GetBValue(win1);

  R2 := GetRValue(win2);
  G2 := GetGValue(win2);
  B2 := GetBValue(win2);

  b2:=round((1-amount)*b+amount*b2);
  g2:=round((1-amount)*g+amount*g2);
  r2:=round((1-amount)*r+amount*r2);

  if R2 < 0 then R2 := 0;
  if G2 < 0 then G2 := 0;
  if B2 < 0 then B2 := 0;

  if R2 > 255 then R2 := r;
  if G2 > 255 then G2 := r;
  if B2 > 255 then B2 := r;

  Result := TColor(RGB(R2, G2, B2));
end;

procedure TIcon32.WriteData(Stream: TStream);
begin
  SaveToStream(Stream);
end;

end.