sf_bitmap.pas

smartflash ,delphi vcl组件 ,可以实现透明flash窗体

{*******************************************************************}
{                                                                   }
{       Almediadev Visual Component Library                         }
{       SmartFlash                                                  }
{       Version 1.50                                                }
{                                                                   }
{       Copyright (c) 2000-2007 Almediadev                          }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{       Home:  http://www.almdev.com                                }
{       Support: [e-mail]                                 }
{                                                                   }
{*******************************************************************}

unit sf_bitmap;

{$I sf_define.inc}
{$O+}
{$R-}
{$Q-}

interface

uses SysUtils, Classes,
  {$IFDEF AL_CLX}
  Qt, Types, QGraphics,
  {$ELSE}
  Windows, Graphics,
  {$ENDIF}
  Math, Clipbrd, sf_winapi;

{!============================================================================!}
type

  { Color type }

  PsfColor = ^TsfColor;
  TsfColor = type cardinal;

  PsfColorRec = ^TsfColorRec;
  TsfColorRec = packed record
    case Cardinal of
      0: (Color: Cardinal);
      2: (HiWord, LoWord: Word);
      3: (B, G, R, A: Byte);
    end;

  PsfColorRecBor = ^TsfColorRecBor;
  TsfColorRecBor = packed record
    case Cardinal of
      0: (Color: Cardinal);
      2: (HiWord, LoWord: Word);
      {$IFDEF AL_CLX}
      3: (B, G, R, A: Byte);
      {$ELSE}
      3: (R, G, B, A: Byte);
      {$ENDIF}
    end;

  PsfColorArray = ^TsfColorArray;
  TsfColorArray = array [0..0] of TsfColor;

  PsfColorRecArray = ^TsfColorRecArray;
  TsfColorRecArray = array [0..0] of TsfColorRec;

  TArrayOffeColor = array of TsfColor;

const

  sfTransparent         = $007F007F;
  AlphaMask              = $FF000000;

  sfBlack               : TsfColor = $FF000000;
  sfGray                : TsfColor = $FF7F7F7F;
  sfWhite               : TsfColor = $FFFFFFFF;
  sfMaroon              : TsfColor = $FF7F0000;
  sfGreen               : TsfColor = $FF007F00;
  sfOlive               : TsfColor = $FF7F7F00;
  sfNavy                : TsfColor = $FF00007F;
  sfPurple              : TsfColor = $FF7F007F;
  sfTeal                : TsfColor = $FF007F7F;
  sfRed                 : TsfColor = $FFFF0000;
  sfLime                : TsfColor = $FF00FF00;
  sfYellow              : TsfColor = $FFFFFF00;
  sfBlue                : TsfColor = $FF0000FF;
  sfFuchsia             : TsfColor = $FFFF00FF;
  sfAqua                : TsfColor = $FF00FFFF;

  sfMenu                : TsfColor = $FFEDEDEE;
  sfBorder              : TsfColor = $FF003399;
  sfWindow              : TsfColor = $FFEBEBEE;
  sfBtnFace             : TsfColor = $FFD2D2D2;
  sfBtnShadow           : TsfColor = $FFA8A8A8;
  sfHotHighlight        : TsfColor = $FFF8C751;
  sfHighlight           : TsfColor = $FF64A0FF;
  sfHintBack            : TsfColor = $FFEBEBEE;
  sfNone                : TsfColor = $33333333;

  sfTransparentVar	 : TsfColor = sfTransparent;

type

  TsfBitmapLink = class;

{ TsfBitmap the main class }

  TsfBitmap = class(TPersistent)
  private
    FBits: PsfColorArray;
    FWidth, FHeight: integer;
    FName: string;
    {$IFNDEF AL_CLX}
    FBitmapInfo: TBitmapInfo;
    FHandle: HBITMAP;
    FDC: HDC;
    FCanvas: TCanvas;
    {$ELSE}
    FImage: QImageH;
    FPainter: QPainterH;
    {$ENDIF}
    FAlphaBlend: boolean;
    FTransparent: boolean;
    FNewFormat: boolean;
    function  GetPixel(X, Y: Integer): TsfColor;
    procedure SetPixel(X, Y: Integer; Value: TsfColor);
    function GetPixelPtr(X, Y: Integer): PsfColor;
    function GetScanLine(Y: Integer): PsfColorArray;
    function GetCanvas: TCanvas;
  protected
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;
    procedure AssignTo(Dest: TPersistent); override;
    { }
    procedure SetSize(AWidth, AHeight: Integer);
    procedure Clear(Color: TsfColor);
    function Empty: boolean;
    { I/O }
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromPcxStream(Stream: TStream);
    procedure LoadFromResource(const ResFileName, ResName: string);
    { BitmapLink }
    function GetBitmapLink(Rect: TRect): TsfBitmapLink; overload;
    function GetBitmapLink(Rect: string): TsfBitmapLink; overload;
    { Checking }
    procedure CheckingTransparent(Color: TsfColor = sfTransparent); overload;
    procedure CheckingTransparent(ARect: TRect; Color: TsfColor = sfTransparent); overload;
    procedure CheckingAlphaBlend; overload;
    procedure CheckingAlphaBlend(ARect: TRect); overload;
    procedure SetAlpha(Alpha: byte); overload;
    procedure SetAlpha(Alpha: byte; Rect: TRect); overload;
    { Color transition }
    procedure SetBitmapHue(Hue: integer);
    procedure ChangeBitmapSat(DeltaSat: integer);
    procedure ChangeBitmapHue(DeltaHue: integer);
    procedure ChangeBitmapBrightness(DeltaBrightness: integer);
    { Manipulation }
    procedure FlipHorz;
    { Paint routines }
    procedure MoveTo(X, Y: integer);
    procedure LineTo(X, Y: integer; Color: TsfColor);
    procedure DrawGraphic(Graphic: TGraphic; DstRect: TRect);
    procedure FillRect(R: TRect; Color: TsfColor);
    procedure FillRoundRect(R: TRect; Radius: integer; Color: TsfColor);
    procedure FillHalftoneRect(R: TRect; Color, HalfColor: TsfColor);
    procedure FillGradientRect(Rect: TRect; BeginColor, EndColor: TsfColor; Vertical: boolean);
    procedure FillRadialGradientRect(Rect: TRect; BeginColor, EndColor: TsfColor; Pos: TPoint);
    procedure FillEllipse(R: TRect; Color: TsfColor);
    procedure FillPolygon(Points: array of TPoint; Color: TColor);
    procedure FillHalftonePolygon(Points: array of TPoint; Color, HalfColor: TsfColor);
    procedure DrawEdge(R: TRect; RaisedColor, SunkenColor: TsfColor);
    procedure DrawBevel(R: TRect; Color: TsfColor; Width: integer; Down: boolean);
    procedure DrawRect(R: TRect; Color: TsfColor);
    procedure DrawFocusRect(R: TRect; Color: TsfColor);
    procedure DrawRoundRect(R: TRect; Radius: integer; Color: TsfColor);
    procedure DrawLine(R: TRect; Color: TsfColor);
    procedure DrawEllipse(R: TRect; Color: TsfColor);
    procedure DrawPolygon(Points: array of TPoint; Color: TColor);
    function DrawText(AText: WideString; var Bounds: TRect; Flag: cardinal): integer; overload;
    function DrawText(AText: WideString; X, Y: integer): integer; overload;
    function DrawVerticalText(AText: WideString; Bounds: TRect; Flag: cardinal; FromTop: boolean): integer;
    function TextWidth(AText: WideString; Flags: Integer = 0): integer;
    function TextHeight(AText: WideString): integer;
    { Draw to Canvas }
    {$IFNDEF AL_CLX}
    procedure Draw(DC: HDC; X, Y: integer); overload;
    procedure Draw(DC: HDC; X, Y: integer; SrcRect: TRect); overload;
    procedure Draw(DC: HDC; DstRect: TRect); overload;
    procedure Draw(DC: HDC; DstRect, SrcRect: TRect); overload;
    {$ENDIF}
    procedure Draw(Canvas: TCanvas; X, Y: integer); overload;
    procedure Draw(Canvas: TCanvas; X, Y: integer; SrcRect: TRect); overload;
    procedure Draw(Canvas: TCanvas; DstRect: TRect); overload;
    procedure Draw(Canvas: TCanvas; DstRect, SrcRect: TRect); overload;
    { Draw to TsfBitmap }
    procedure Draw(Bitmap: TsfBitmap; X, Y: integer); overload;
    procedure Draw(Bitmap: TsfBitmap; X, Y: integer; SrcRect: TRect); overload;
    procedure Draw(Bitmap: TsfBitmap; DstRect: TRect); overload;
    procedure Draw(Bitmap: TsfBitmap; DstRect, SrcRect: TRect); overload;
    { Complex Draw }
    procedure Tile(DC: HDC; DstRect, SrcRect: TRect); overload;
    procedure Tile(Canvas: TCanvas; DstRect, SrcRect: TRect); overload;
    procedure Tile(Bitmap: TsfBitmap; DstRect, SrcRect: TRect); overload;
    procedure TileClip(DC: HDC; DstRect, DstClip, SrcRect: TRect); overload;
    procedure TileClip(Canvas: TCanvas; DstRect, DstClip, SrcRect: TRect); overload;
    procedure TileClip(Bitmap: TsfBitmap; DstRect, DstClip, SrcRect: TRect); overload;
    { Alpha blend two bitmap }
    procedure MergeDraw(Bitmap: TsfBitmap; X, Y: integer; SrcRect: TRect);
    { Low-level access}
    {$IFNDEF AL_CLX}
    property Handle: HBITMAP read FHandle;
    property DC: HDC read FDC;
    property Canvas: TCanvas read GetCanvas;
    {$ELSE}
    property Image: QImageH read FImage;
    property Painter: QPainterH read FPainter;
    {$ENDIF}
    { Access properties }
    property Bits: PsfColorArray read FBits;
    property Pixels[X, Y: Integer]: TsfColor read GetPixel write SetPixel; default;
    property PixelPtr[X, Y: Integer]: PsfColor read GetPixelPtr;
    property ScanLine[Y: Integer]: PsfColorArray read GetScanLine;
    property Width: integer read FWidth;
    property Height: integer read FHeight;
    { States }
    property AlphaBlend: boolean read FAlphaBlend write FAlphaBlend;
    property Transparent: boolean read FTransparent write FTransparent;
    { Persitent properties }
    property Name: string read FName write FName;
    property NewFormat: boolean read FNewFormat write FNewFormat;
  published
  end;

{ TsfBitmapLink }

  TsfBitmapLink = class(TPersistent)
  private
    FImage: TsfBitmap;
    FRect: TRect;
    FName: string;
    FMaskedBorder: boolean;
    FMaskedAngles: boolean;
    FMasked: boolean;
    function GetBottom: integer;
    function GetLeft: integer;
    function GetRight: integer;
    function GetTop: integer;
    procedure SetBottom(const Value: integer);
    procedure SetLeft(const Value: integer);
    procedure SetRight(const Value: integer);
    procedure SetTop(const Value: integer);
    function GetAssigned: boolean;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;

    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);

    procedure CheckingMasked; overload;
    procedure CheckingMasked(Margin: TRect); overload;

    procedure Draw(Canvas: TCanvas; X, Y: integer); overload;
    procedure Draw(Bitmap: TsfBitmap; X, Y: integer); overload;

    property Assigned: boolean read GetAssigned;
    property Image: TsfBitmap read FImage write FImage;
    property Rect: TRect read FRect write FRect;
    property Masked: boolean read FMasked write FMasked;
    property MaskedBorder: boolean read FMaskedBorder write FMaskedBorder;
    property MaskedAngles: boolean read FMaskedAngles write FMaskedAngles;
  published
    property Name: string read FName write FName;
    property Left: integer read GetLeft write SetLeft;
    property Top: integer read GetTop write SetTop;
    property Right: integer read GetRight write SetRight;
    property Bottom: integer read GetBottom write SetBottom;
  end;

{ TsfBitmapList }

  TsfBitmapList = class(TList)
  private
    function GetImage(index: integer): TsfBitmap;
    function GetBitmapByName(index: string): TsfBitmap;
  protected
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure Clear; override;

    function GetBitmapLink(Image: TsfBitmap; Rect: TRect): TsfBitmapLink; overload;
    function GetBitmapLink(Name: string; Rect: TRect): TsfBitmapLink; overload;
    function GetBitmapLink(Name, Rect: string): TsfBitmapLink; overload;

    property Bitmaps[index: integer]: TsfBitmap read GetImage; default;
    property BitmapByName[index: string]: TsfBitmap read GetBitmapByName;
  end;

{ Color functions }

function sfColor(Color: TColor; A: Byte = $FF): TsfColor; overload;
function sfColor(R, G, B: SmallInt; A: Byte = $FF): TsfColor; overload;
function sfColor(ColorRec: TsfColorRec): TsfColor; overload;

function sfColorToColor(Color: TsfColor): TColor;

function sfColorToColor16(Color: TsfColor): word; // 16-bit, 5-6-5
function sfColorToColor15(Color: TsfColor): word; // 15-bit, 5-5-5

function ChangeColor(Color: TsfColor; Dr, Dg, Db: smallint; Da: smallint = 0): TsfColor; overload;
function ChangeColor(Color: TsfColor; Dx: smallint): TsfColor; overload;
function StdChangeColor(Color: TColor; Dr, Dg, Db: smallint; Da: smallint = 0): TColor; overload;
function StdChangeColor(Color: TColor; Dx: smallint): TColor; overload;

function SunkenColor(Color: TsfColor; Dr, Dg, Db: smallint; Da: smallint = 0): TsfColor; overload;
function SunkenColor(Color: TsfColor; Dx: smallint): TsfColor; overload;
function RaisedColor(Color: TsfColor; Dr, Dg, Db: smallint; Da: smallint = 0): TsfColor; overload;
function RaisedColor(Color: TsfColor; Dx: smallint): TsfColor; overload;

function HSLtoRGB(H, S, L: Single): TsfColor;
procedure RGBtoHSL(RGB: TsfColor; out H, S, L: single);

function SetHue(Color: TsfColor; Hue: integer): TsfColor;
function ChangeSat(Color: TsfColor; DeltaSat: integer): TsfColor;
function ChangeHue(Color: TsfColor; DeltaHue: integer): TsfColor;
function ChangeBrightness(Color: TsfColor; DeltaBrightness: integer): TsfColor;

{$IFDEF AL_CLX}
function RGB(R, G, B: byte): TColor;
{$ENDIF}

const

  EnableDibOperation: boolean = true; // Use dib routines from DC


{ Function prototypes }

type
  TsfAlphaBlendPixel = function (Src, Dst: TsfColor): TsfColor;
  TsfAlphaBlendLine = procedure (Src, Dst: PsfColor; Count: Integer);
  TsfTransparentLine = procedure (Src, Dst: PsfColor; Count: Integer);

  TsfMoveLongword = procedure (const Src: Pointer; Dst: Pointer; Count: Integer);

  TsfFillLongword = procedure (Src: Pointer; Count: integer; Value: longword);
  TsfFillLongwordRect = procedure (Src: Pointer; W, H, X1, Y1, X2, Y2: integer;
    Value: longword);

  TsfFillAlpha = procedure (Src: Pointer; Count: integer; Alpha: byte);
  TsfFillAlphaRect = procedure (Src: Pointer; W, H, X1, Y1, X2, Y2: integer; Alpha: byte);

  TsfClearAlpha = procedure (Src: Pointer; Count: integer; Value: longword);

{ Function variables }

var
  PixelAlphaBlendFunc: TsfAlphaBlendPixel;
  LineAlphaBlendFunc: TsfAlphaBlendLine;
  LineTransparentFunc: TsfTransparentLine;

  MoveLongwordFunc: TsfMoveLongword;
  FillLongwordFunc: TsfFillLongword;
  FillLongwordRectFunc: TsfFillLongwordRect;

  FillAlphaFunc: TsfFillAlpha;
  FillAlphaRectFunc: TsfFillAlphaRect;

  ClearAlphaFunc: TsfClearAlpha;

function MulDiv16(Number, Numerator, Denominator: Word): Word;

function FromRGB(Color: longword): longword;
function ToRGB(Color32: longword): longword;


{ Function prototypes }

type
  TsfStretchToDCOpaque = procedure (DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
    SrcBmp: TsfBitmap; SrcX, SrcY, SrcW, SrcH: Integer);
  TsfStretchToDCTransparent = procedure(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
    SrcBmp: TsfBitmap; SrcX, SrcY, SrcW, SrcH: Integer);
  TsfStretchToDCAlphaBlend = procedure (DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
    SrcBmp: TsfBitmap; SrcX, SrcY, SrcW, SrcH: Integer);

  TsfStretchToDibOpaque = procedure (Bits: Pointer; DstRect, DstClip: TRect;
    BitsW, BitsH: integer; Src: TsfBitmap; SrcRect: TRect);
  TsfStretchToDibTransparent = procedure(Bits: Pointer; DstRect, DstClip: TRect;
    BitsW, BitsH: integer; Src: TsfBitmap; SrcRect: TRect);
  TsfStretchToDibAlphaBlend = procedure (Bits: Pointer; DstRect, DstClip: TRect;
    BitsW, BitsH: integer; Src: TsfBitmap; SrcRect: TRect);

  TsfStretchOpaque = procedure(Dst: TsfBitmap; DstRect, DstClip: TRect; Src: TsfBitmap;
    SrcRect: TRect);
  TsfStretchTransparent = procedure(Dst: TsfBitmap; DstRect, DstClip: TRect; Src: TsfBitmap;
    SrcRect: TRect);
  TsfStretchAlphaBlend = procedure(Dst: TsfBitmap; DstRect, DstClip: TRect; Src: TsfBitmap;
    SrcRect: TRect);

  TsfBltOpaque = procedure(Dst: TsfBitmap; DstRect: TRect; Src: TsfBitmap;
    SrcX, SrcY: Integer);
  TsfBltTransparent = procedure(Dst: TsfBitmap; DstRect: TRect; Src: TsfBitmap;
    SrcX, SrcY: Integer);
  TsfBltAlphaBlend = procedure(Dst: TsfBitmap; DstRect: TRect; Src: TsfBitmap;
    SrcX, SrcY: Integer);

  TsfGetBitsFromDC = function(DC: HDC; var Width, Height, BitCount: integer): Pointer;

{ Function variables }

var
  { DC }
  StretchToDCOpaqueFunc: TsfStretchToDCOpaque;
  StretchToDCAlphaBlendFunc: TsfStretchToDCAlphaBlend;
  StretchToDCTransparentFunc: TsfStretchToDCTransparent;
  { Dib }
  GetBitsFromDCFunc: TsfGetBitsFromDC;
  StretchToDibOpaqueFunc: TsfStretchToDibOpaque;
  StretchToDibAlphaBlendFunc: TsfStretchToDibAlphaBlend;
  StretchToDibTransparentFunc: TsfStretchToDibTransparent;
  { sfBitmap }
  BltOpaqueFunc: TsfBltOpaque;
  BltAlphaBlendFunc: TsfBltAlphaBlend;
  BltTransparentFunc: TsfBltTransparent;
  StretchOpaqueFunc: TsfStretchOpaque;
  StretchAlphaBlendFunc: TsfStretchAlphaBlend;
  StretchTransparentFunc: TsfStretchTransparent;


implementation {===============================================================}

uses sf_utils;

type
  TGraphicAccess = class(TGraphic);

  PPoints = ^TPoints;
  TPoints = array[0..0] of TPoint;

//To test the hashing implementatiotn, you should define "USE_HASH" in te_define.inc
{.$DEFINE USE_HASH}
{$IFDEF USE_HASH}

  { TStringHash }

  PPHashItem = ^PHashItem;
  PHashItem = ^THashItem;
  THashItem = record
    Next: PHashItem;
    Key: Cardinal;
    Value: Integer;
  end;

  { Based on TStringHash class by Borland }

  TIntegerHash = class
  private
    Buckets: array of PHashItem;
  protected
    function Find(const Key: Cardinal): PPHashItem;
    function HashOfInteger(const Key: Cardinal): Cardinal;
  public
    constructor Create(Size: Cardinal = 256);
    destructor Destroy; override;
    procedure Add(const Key: Cardinal; Value: Integer);
    procedure Clear;
    function ValueOf(const Key: Cardinal): Integer;
  end;