be_bitmap.pas

KSDev.BlockEngine.v3.03.rar 界面控件

{==============================================================================

  LibBmp
  Copyright (C) 2000-2003 by Evgeny Kryukov
  All rights reserved

  All contents of this file and all other files included in this archive
  are Copyright (C) 2003 Evgeny Kryukov. Use and/or distribution of
  them requires acceptance of the License Agreement.

  See License.txt for licence information

  $Id: be_bitmap.pas,v 1.1.1.1 2006/11/02 17:02:51 eugene Exp $

===============================================================================}

unit be_bitmap;

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

interface

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

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

const
  beBitmapVersion = '3.0';
  beBitmapVersionPropText = 'LibBmp Version ' + beBitmapVersion;

var
  SigBmp: PChar = '- ' + beBitmapVersionPropText +
    {$IFDEF KS_DELPHI4} ' - D4 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER4} ' - CB4 - ' + {$ENDIF}
    {$IFDEF KS_DELPHI5} ' - D5 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER5} ' - CB5 - '+ {$ENDIF}
    {$IFDEF KS_DELPHI6} ' - D6 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER6} ' - CB6 - '+ {$ENDIF}
    {$IFDEF KS_DELPHI7} ' - D7 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER7} ' - CB7 - '+ {$ENDIF}
    'Copyright (C) 1998-2003 by Evgeny Kryukov -';


type

  { Color type }

  PbeColor = ^TbeColor;
  TbeColor = type cardinal;

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

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

  PbeColorArray = ^TbeColorArray;
  TbeColorArray = array [0..0] of TbeColor;

  PbeColorRecArray = ^TbeColorRecArray;
  TbeColorRecArray = array [0..0] of TbeColorRec;

  TArrayOfbeColor = array of TbeColor;

const

  beTransparent         = $007F007F;
  AlphaMask              = $FF000000;

  beBlack               : TbeColor = $FF000000;
  beGray                : TbeColor = $FF7F7F7F;
  beWhite               : TbeColor = $FFFFFFFF;
  beMaroon              : TbeColor = $FF7F0000;
  beGreen               : TbeColor = $FF007F00;
  beOlive               : TbeColor = $FF7F7F00;
  beNavy                : TbeColor = $FF00007F;
  bePurple              : TbeColor = $FF7F007F;
  beTeal                : TbeColor = $FF007F7F;
  beRed                 : TbeColor = $FFFF0000;
  beLime                : TbeColor = $FF00FF00;
  beYellow              : TbeColor = $FFFFFF00;
  beBlue                : TbeColor = $FF0000FF;
  beFuchsia             : TbeColor = $FFFF00FF;
  beAqua                : TbeColor = $FF00FFFF;

  beMenu                : TbeColor = $FFEDEDEE;
  beBorder              : TbeColor = $FF003399;
  beWindow              : TbeColor = $FFEBEBEE;
  beBtnFace             : TbeColor = $FFD2D2D2;
  beBtnShadow           : TbeColor = $FFA8A8A8;
  beHotHighlight        : TbeColor = $FFF8C751;
  beHighlight           : TbeColor = $FF64A0FF;
  beHintBack            : TbeColor = $FFEBEBEE;
  beNone                : TbeColor = $33333333;

  beTransparentVar	 : TbeColor = beTransparent;

type

  TbeBitmapLink = class;

{ TbeBitmap the main class }

  TbeBitmap = class(TPersistent)
  private
    FBits: PbeColorArray;
    FWidth, FHeight: integer;
    FName: string;
    {$IFNDEF KS_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): TbeColor;
    procedure SetPixel(X, Y: Integer; Value: TbeColor);
    function GetPixelPtr(X, Y: Integer): PbeColor;
    function GetScanLine(Y: Integer): PbeColorArray;
    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: TbeColor);
    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): TbeBitmapLink; overload;
    function GetBitmapLink(Rect: string): TbeBitmapLink; overload;
    { Checking }
    procedure CheckingTransparent(Color: TbeColor = beTransparent); overload;
    procedure CheckingTransparent(ARect: TRect; Color: TbeColor = beTransparent); 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: TbeColor);
    procedure DrawGraphic(Graphic: TGraphic; DstRect: TRect);
    procedure FillRect(R: TRect; Color: TbeColor);
    procedure FillRoundRect(R: TRect; Radius: integer; Color: TbeColor);
    procedure FillHalftoneRect(R: TRect; Color, HalfColor: TbeColor);
    procedure FillGradientRect(Rect: TRect; BeginColor, EndColor: TbeColor; Vertical: boolean);
    procedure FillRadialGradientRect(Rect: TRect; BeginColor, EndColor: TbeColor; Pos: TPoint);
    procedure FillEllipse(R: TRect; Color: TbeColor);
    procedure FillPolygon(Points: array of TPoint; Color: TColor);
    procedure FillHalftonePolygon(Points: array of TPoint; Color, HalfColor: TbeColor);
    procedure DrawEdge(R: TRect; RaisedColor, SunkenColor: TbeColor);
    procedure DrawBevel(R: TRect; Color: TbeColor; Width: integer; Down: boolean);
    procedure DrawRect(R: TRect; Color: TbeColor);
    procedure DrawFocusRect(R: TRect; Color: TbeColor);
    procedure DrawRoundRect(R: TRect; Radius: integer; Color: TbeColor);
    procedure DrawLine(R: TRect; Color: TbeColor);
    procedure DrawEllipse(R: TRect; Color: TbeColor);
    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 KS_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 TbeBitmap }
    procedure Draw(Bitmap: TbeBitmap; X, Y: integer); overload;
    procedure Draw(Bitmap: TbeBitmap; X, Y: integer; SrcRect: TRect); overload;
    procedure Draw(Bitmap: TbeBitmap; DstRect: TRect); overload;
    procedure Draw(Bitmap: TbeBitmap; 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: TbeBitmap; 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: TbeBitmap; DstRect, DstClip, SrcRect: TRect); overload;
    { Alpha blend two bitmap }
    procedure MergeDraw(Bitmap: TbeBitmap; X, Y: integer; SrcRect: TRect);
    { Low-level access}
    {$IFNDEF KS_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: PbeColorArray read FBits;
    property Pixels[X, Y: Integer]: TbeColor read GetPixel write SetPixel; default;
    property PixelPtr[X, Y: Integer]: PbeColor read GetPixelPtr;
    property ScanLine[Y: Integer]: PbeColorArray 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;

{ TbeBitmapLink }

  TbeBitmapLink = class(TPersistent)
  private
    FImage: TbeBitmap;
    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: TbeBitmap; X, Y: integer); overload;

    property Assigned: boolean read GetAssigned;
    property Image: TbeBitmap 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;

{ TbeBitmapList }

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

    procedure Clear; override;

    function GetBitmapLink(Image: TbeBitmap; Rect: TRect): TbeBitmapLink; overload;
    function GetBitmapLink(Name: string; Rect: TRect): TbeBitmapLink; overload;
    function GetBitmapLink(Name, Rect: string): TbeBitmapLink; overload;

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

{ Color functions }

function beColor(Color: TColor; A: Byte = $FF): TbeColor; overload;
function beColor(R, G, B: SmallInt; A: Byte = $FF): TbeColor; overload;
function beColor(ColorRec: TbeColorRec): TbeColor; overload;

function beColorToColor(Color: TbeColor): TColor;

function beColorToColor16(Color: TbeColor): word; // 16-bit, 5-6-5
function beColorToColor15(Color: TbeColor): word; // 15-bit, 5-5-5

function ChangeColor(Color: TbeColor; Dr, Dg, Db: smallint; Da: smallint = 0): TbeColor; overload;
function ChangeColor(Color: TbeColor; Dx: smallint): TbeColor; 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: TbeColor; Dr, Dg, Db: smallint; Da: smallint = 0): TbeColor; overload;
function SunkenColor(Color: TbeColor; Dx: smallint): TbeColor; overload;
function RaisedColor(Color: TbeColor; Dr, Dg, Db: smallint; Da: smallint = 0): TbeColor; overload;
function RaisedColor(Color: TbeColor; Dx: smallint): TbeColor; overload;

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

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

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

const

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


{ Function prototypes }

type
  TbeAlphaBlendPixel = function (Src, Dst: TbeColor): TbeColor;
  TbeAlphaBlendLine = procedure (Src, Dst: PbeColor; Count: Integer);
  TbeTransparentLine = procedure (Src, Dst: PbeColor; Count: Integer);

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

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

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

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

{ Function variables }

var
  PixelAlphaBlendFunc: TbeAlphaBlendPixel;
  LineAlphaBlendFunc: TbeAlphaBlendLine;
  LineTransparentFunc: TbeTransparentLine;

  MoveLongwordFunc: TbeMoveLongword;
  FillLongwordFunc: TbeFillLongword;
  FillLongwordRectFunc: TbeFillLongwordRect;

  FillAlphaFunc: TbeFillAlpha;
  FillAlphaRectFunc: TbeFillAlphaRect;

  ClearAlphaFunc: TbeClearAlpha;

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

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


{ Function prototypes }

type
  TbeStretchToDCOpaque = procedure (DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
    SrcBmp: TbeBitmap; SrcX, SrcY, SrcW, SrcH: Integer);
  TbeStretchToDCTransparent = procedure(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
    SrcBmp: TbeBitmap; SrcX, SrcY, SrcW, SrcH: Integer);
  TbeStretchToDCAlphaBlend = procedure (DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
    SrcBmp: TbeBitmap; SrcX, SrcY, SrcW, SrcH: Integer);

  TbeStretchToDibOpaque = procedure (Bits: Pointer; DstRect, DstClip: TRect;
    BitsW, BitsH: integer; Src: TbeBitmap; SrcRect: TRect);
  TbeStretchToDibTransparent = procedure(Bits: Pointer; DstRect, DstClip: TRect;
    BitsW, BitsH: integer; Src: TbeBitmap; SrcRect: TRect);
  TbeStretchToDibAlphaBlend = procedure (Bits: Pointer; DstRect, DstClip: TRect;
    BitsW, BitsH: integer; Src: TbeBitmap; SrcRect: TRect);

  TbeStretchOpaque = procedure(Dst: TbeBitmap; DstRect, DstClip: TRect; Src: TbeBitmap;
    SrcRect: TRect);
  TbeStretchTransparent = procedure(Dst: TbeBitmap; DstRect, DstClip: TRect; Src: TbeBitmap;
    SrcRect: TRect);
  TbeStretchAlphaBlend = procedure(Dst: TbeBitmap; DstRect, DstClip: TRect; Src: TbeBitmap;
    SrcRect: TRect);

  TbeBltOpaque = procedure(Dst: TbeBitmap; DstRect: TRect; Src: TbeBitmap;
    SrcX, SrcY: Integer);
  TbeBltTransparent = procedure(Dst: TbeBitmap; DstRect: TRect; Src: TbeBitmap;
    SrcX, SrcY: Integer);
  TbeBltAlphaBlend = procedure(Dst: TbeBitmap; DstRect: TRect; Src: TbeBitmap;
    SrcX, SrcY: Integer);

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

{ Function variables }

var
  { DC }
  StretchToDCOpaqueFunc: TbeStretchToDCOpaque;
  StretchToDCAlphaBlendFunc: TbeStretchToDCAlphaBlend;
  StretchToDCTransparentFunc: TbeStretchToDCTransparent;
  { Dib }
  GetBitsFromDCFunc: TbeGetBitsFromDC;
  StretchToDibOpaqueFunc: TbeStretchToDibOpaque;
  StretchToDibAlphaBlendFunc: TbeStretchToDibAlphaBlend;
  StretchToDibTransparentFunc: TbeStretchToDibTransparent;
  { beBitmap }
  BltOpaqueFunc: TbeBltOpaque;
  BltAlphaBlendFunc: TbeBltAlphaBlend;
  BltTransparentFunc: TbeBltTransparent;
  StretchOpaqueFunc: TbeStretchOpaque;
  StretchAlphaBlendFunc: TbeStretchAlphaBlend;
  StretchTransparentFunc: TbeStretchTransparent;


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

uses be_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;