tebitmap.pas

这个东西的功能很强大

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

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

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

unit TeBitmap;

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

interface

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

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

const
  teBitmapVersion = '2.3.0';
  teBitmapVersionPropText = 'LibBmp Version ' + teBitmapVersion;

type
  TteBitmapVersion = type string;

var
  Sig: PChar = '- ' + teBitmapVersionPropText +
    {$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 }

  PteColor = ^TteColor;
  TteColor = type cardinal;

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

  PteColorRecBor = ^TteColorRecBor;
  TteColorRecBor = 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;

  PteColorArray = ^TteColorArray;
  TteColorArray = array [0..0] of TteColor;

  PteColorRecArray = ^TteColorRecArray;
  TteColorRecArray = array [0..0] of TteColorRec;

  TArrayOfteColor = array of TteColor;

const

  teTransparent         = $007F007F;
  AlphaMask              = $FF000000;

  teBlack               : TteColor = $FF000000;
  teGray                : TteColor = $FF7F7F7F;
  teWhite               : TteColor = $FFFFFFFF;
  teMaroon              : TteColor = $FF7F0000;
  teGreen               : TteColor = $FF007F00;
  teOlive               : TteColor = $FF7F7F00;
  teNavy                : TteColor = $FF00007F;
  tePurple              : TteColor = $FF7F007F;
  teTeal                : TteColor = $FF007F7F;
  teRed                 : TteColor = $FFFF0000;
  teLime                : TteColor = $FF00FF00;
  teYellow              : TteColor = $FFFFFF00;
  teBlue                : TteColor = $FF0000FF;
  teFuchsia             : TteColor = $FFFF00FF;
  teAqua                : TteColor = $FF00FFFF;

  teMenu                : TteColor = $FFEDEDEE;
  teBorder              : TteColor = $FF003399;
  teWindow              : TteColor = $FFEBEBEE;
  teBtnFace             : TteColor = $FFD2D2D2;
  teBtnShadow           : TteColor = $FFA8A8A8;
  teHotHighlight        : TteColor = $FFF8C751;
  teHighlight           : TteColor = $FF64A0FF;
  teHintBack            : TteColor = $FFEBEBEE;
  teNone                : TteColor = $33333333;

  teTransparentVar	 : TteColor = teTransparent;

type

  TteBitmapLink = class;

{ TteBitmap the main class }

  TteBitmap = class(TPersistent)
  private
    FBits: PteColorArray;
    FWidth, FHeight: integer;
    FName: string;
    {$IFNDEF KS_CLX}
    FBitmapInfo: TBitmapInfo;
    FHandle: HBITMAP;
    FDC: HDC;
    {$ELSE}
    FImage: QImageH;
    FPainter: QPainterH;
    {$ENDIF}
    FAlphaBlend: boolean;
    FTransparent: boolean;
    FNewFormat: boolean;
    function  GetPixel(X, Y: Integer): TteColor;
    procedure SetPixel(X, Y: Integer; Value: TteColor);
    function GetPixelPtr(X, Y: Integer): PteColor;
    function GetScanLine(Y: Integer): PteColorArray;
  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: TteColor);
    function Empty: boolean;
    { I/O }
    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromPcxStream(Stream: TStream);
    { BitmapLink }
    function GetBitmapLink(Rect: TRect): TteBitmapLink; overload;
    function GetBitmapLink(Rect: string): TteBitmapLink; overload;
    { Checking }
    procedure CheckingTransparent(Color: TteColor = teTransparent); overload;
    procedure CheckingTransparent(ARect: TRect; Color: TteColor = teTransparent); overload;
    procedure CheckingAlphaBlend; overload;
    procedure CheckingAlphaBlend(ARect: TRect); overload;
    procedure SetAlpha(Alpha: byte); overload;
    procedure SetAlpha(Alpha: byte; Rect: TRect); overload;
    { Color transition }
    procedure ChangeBitmapHue(DeltaHue: integer);
    procedure ChangeBitmapBrightness(DeltaBrightness: integer);
    { Manipulation }
    procedure FlipHorz;
    { Paint routines }
    procedure MoveTo(X, Y: integer);
    procedure LineTo(X, Y: integer; Color: TteColor);
    procedure DrawGraphic(Graphic: TGraphic; DstRect: TRect);
    procedure FillRect(R: TRect; Color: TteColor);
    procedure FillRoundRect(R: TRect; Radius: integer; Color: TteColor);
    procedure FillHalftoneRect(R: TRect; Color, HalfColor: TteColor);
    procedure FillGradientRect(Rect: TRect; BeginColor, EndColor: TteColor; Vertical: boolean);
    procedure FillRadialGradientRect(Rect: TRect; BeginColor, EndColor: TteColor; Pos: TPoint);
    procedure FillEllipse(R: TRect; Color: TteColor);
    procedure FillPolygon(Points: array of TPoint; Color: TColor);
    procedure FillHalftonePolygon(Points: array of TPoint; Color, HalfColor: TteColor);
    procedure DrawEdge(R: TRect; RaisedColor, SunkenColor: TteColor);
    procedure DrawBevel(R: TRect; Color: TteColor; Width: integer; Down: boolean);
    procedure DrawRect(R: TRect; Color: TteColor);
    procedure DrawFocusRect(R: TRect; Color: TteColor);
    procedure DrawRoundRect(R: TRect; Radius: integer; Color: TteColor);
    procedure DrawLine(R: TRect; Color: TteColor);
    procedure DrawEllipse(R: TRect; Color: TteColor);
    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 TteBitmap }
    procedure Draw(Bitmap: TteBitmap; X, Y: integer); overload;
    procedure Draw(Bitmap: TteBitmap; X, Y: integer; SrcRect: TRect); overload;
    procedure Draw(Bitmap: TteBitmap; DstRect: TRect); overload;
    procedure Draw(Bitmap: TteBitmap; 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: TteBitmap; 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: TteBitmap; DstRect, DstClip, SrcRect: TRect); overload;
    { Alpha blend two bitmap }
    procedure MergeDraw(Bitmap: TteBitmap; X, Y: integer; SrcRect: TRect);
    { Low-level access}
    {$IFNDEF KS_CLX}
    property Handle: HBITMAP read FHandle;
    property DC: HDC read FDC;
    {$ELSE}
    property Image: QImageH read FImage;
    property Painter: QPainterH read FPainter;
    {$ENDIF}
    { Access properties }
    property Bits: PteColorArray read FBits;
    property Pixels[X, Y: Integer]: TteColor read GetPixel write SetPixel; default;
    property PixelPtr[X, Y: Integer]: PteColor read GetPixelPtr;
    property ScanLine[Y: Integer]: PteColorArray 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;

{ TteBitmapLink }

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

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

{ TteBitmapList }

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

    procedure Clear; override;

    function GetBitmapLink(Image: TteBitmap; Rect: TRect): TteBitmapLink; overload;
    function GetBitmapLink(Name: string; Rect: TRect): TteBitmapLink; overload;
    function GetBitmapLink(Name, Rect: string): TteBitmapLink; overload;

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

{ Color functions }

function teColor(Color: TColor; A: Byte = $FF): TteColor; overload;
function teColor(R, G, B: SmallInt; A: Byte = $FF): TteColor; overload;
function teColor(ColorRec: TteColorRec): TteColor; overload;

function teColorToColor(Color: TteColor): TColor;

function teColorToColor16(Color: TteColor): word; // 16-bit, 5-6-5
function teColorToColor15(Color: TteColor): word; // 15-bit, 5-5-5

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

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

function ChangeHue(Color: TteColor; DeltaHue: integer): TteColor;
function ChangeBrightness(Color: TteColor; DeltaBrightness: integer): TteColor;

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

const

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


{ Function prototypes }

type
  TteAlphaBlendPixel = function (Src, Dst: TteColor): TteColor;
  TteAlphaBlendLine = procedure (Src, Dst: PteColor; Count: Integer);
  TteTransparentLine = procedure (Src, Dst: PteColor; Count: Integer);

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

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

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

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

{ Function variables }

var
  PixelAlphaBlendFunc: TteAlphaBlendPixel;
  LineAlphaBlendFunc: TteAlphaBlendLine;
  LineTransparentFunc: TteTransparentLine;

  MoveLongwordFunc: TteMoveLongword;
  FillLongwordFunc: TteFillLongword;
  FillLongwordRectFunc: TteFillLongwordRect;

  FillAlphaFunc: TteFillAlpha;
  FillAlphaRectFunc: TteFillAlphaRect;

  ClearAlphaFunc: TteClearAlpha;

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

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


{ Function prototypes }

type
  TteStretchToDCOpaque = procedure (DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
    SrcBmp: TteBitmap; SrcX, SrcY, SrcW, SrcH: Integer);
  TteStretchToDCTransparent = procedure(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
    SrcBmp: TteBitmap; SrcX, SrcY, SrcW, SrcH: Integer);
  TteStretchToDCAlphaBlend = procedure (DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
    SrcBmp: TteBitmap; SrcX, SrcY, SrcW, SrcH: Integer);

  TteStretchToDibOpaque = procedure (Bits: Pointer; DstRect, DstClip: TRect;
    BitsW, BitsH: integer; Src: TteBitmap; SrcRect: TRect);
  TteStretchToDibTransparent = procedure(Bits: Pointer; DstRect, DstClip: TRect;
    BitsW, BitsH: integer; Src: TteBitmap; SrcRect: TRect);
  TteStretchToDibAlphaBlend = procedure (Bits: Pointer; DstRect, DstClip: TRect;
    BitsW, BitsH: integer; Src: TteBitmap; SrcRect: TRect);

  TteStretchOpaque = procedure(Dst: TteBitmap; DstRect, DstClip: TRect; Src: TteBitmap;
    SrcRect: TRect);
  TteStretchTransparent = procedure(Dst: TteBitmap; DstRect, DstClip: TRect; Src: TteBitmap;
    SrcRect: TRect);
  TteStretchAlphaBlend = procedure(Dst: TteBitmap; DstRect, DstClip: TRect; Src: TteBitmap;
    SrcRect: TRect);

  TteBltOpaque = procedure(Dst: TteBitmap; DstRect: TRect; Src: TteBitmap;
    SrcX, SrcY: Integer);
  TteBltTransparent = procedure(Dst: TteBitmap; DstRect: TRect; Src: TteBitmap;
    SrcX, SrcY: Integer);
  TteBltAlphaBlend = procedure(Dst: TteBitmap; DstRect: TRect; Src: TteBitmap;
    SrcX, SrcY: Integer);

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

{ Function variables }

var
  { DC }
  StretchToDCOpaqueFunc: TteStretchToDCOpaque;
  StretchToDCAlphaBlendFunc: TteStretchToDCAlphaBlend;
  StretchToDCTransparentFunc: TteStretchToDCTransparent;
  { Dib }
  GetBitsFromDCFunc: TteGetBitsFromDC;
  StretchToDibOpaqueFunc: TteStretchToDibOpaque;
  StretchToDibAlphaBlendFunc: TteStretchToDibAlphaBlend;
  StretchToDibTransparentFunc: TteStretchToDibTransparent;
  { teBitmap }
  BltOpaqueFunc: TteBltOpaque;
  BltAlphaBlendFunc: TteBltAlphaBlend;
  BltTransparentFunc: TteBltTransparent;
  StretchOpaqueFunc: TteStretchOpaque;
  StretchAlphaBlendFunc: TteStretchAlphaBlend;
  StretchTransparentFunc: TteStretchTransparent;


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

uses TeUtils;

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);