graphics.pas

这是不可多得的源代码

    function ReleaseHandle: HENHMETAFILE;
    property CreatedBy: String read GetAuthor;
    property Description: String read GetDesc;
    property Enhanced: Boolean read FEnhanced write FEnhanced default True;
    property Handle: HENHMETAFILE read GetHandle write SetHandle;
    property MMWidth: Integer read GetMMWidth write SetMMWidth;
    property MMHeight: Integer read GetMMHeight write SetMMHeight;
    property Inch: Word read GetInch write SetInch;
  end;

  { TBitmap }
  { TBitmap is an encapsulation of a Windows HBITMAP and HPALETTE.  It manages
    the palette realizing automatically as well as having a Canvas to allow
    modifications to the image.  Creating copies of a TBitmap is very fast
    since the handle is copied not the image.  If the image is modified, and
    the handle is shared by more than one TBitmap object, the image is copied
    before the modification is performed (i.e. copy on write).
      Canvas - Allows drawing on the bitmap.
      Handle - The HBITMAP encapsulated by the TBitmap.  Grabbing the handle
        directly should be avoided since it causes the HBITMAP to be copied if
        more than one TBitmap share the handle.
      Palette - The HPALETTE realized by the TBitmap.  Grabbing this handle
        directly should be avoided since it causes the HPALETTE to be copied if
        more than one TBitmap share the handle.
      Monochrome - True if the bitmap is a monochrome bitmap }

  TBitmapImage = class(TSharedImage)
  private
    FHandle: HBITMAP;     // DDB or DIB handle, used for drawing
    FMaskHandle: HBITMAP; // DDB handle
    FPalette: HPALETTE;
    FDIBHandle: HBITMAP;  // DIB handle corresponding to TDIBSection
    FDIB: TDIBSection;
    FSaveStream: TMemoryStream; // Save original RLE stream until image is modified
    FOS2Format: Boolean;  // Write BMP file header, color table in OS/2 format
    FHalftone: Boolean;   // FPalette is halftone; don't write to file
  protected
    procedure FreeHandle; override;
  public
    destructor Destroy; override;
  end;

  TBitmapHandleType = (bmDIB, bmDDB);
  TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, pf24bit, pf32bit, pfCustom);
  TTransparentMode = (tmAuto, tmFixed);

  TBitmap = class(TGraphic)
  private
    FImage: TBitmapImage;
    FCanvas: TCanvas;
    FIgnorePalette: Boolean;
    FMaskBitsValid: Boolean;
    FMaskValid: Boolean;
    FTransparentColor: TColor;
    FTransparentMode: TTransparentMode;
    procedure Changing(Sender: TObject);
    procedure CopyImage(AHandle: HBITMAP; APalette: HPALETTE; DIB: TDIBSection);
    procedure DIBNeeded;
    procedure FreeContext;
    function GetCanvas: TCanvas;
    function GetHandle: HBITMAP; virtual;
    function GetHandleType: TBitmapHandleType;
    function GetMaskHandle: HBITMAP; virtual;
    function GetMonochrome: Boolean;
    function GetPixelFormat: TPixelFormat;
    function GetScanline(Row: Integer): Pointer;
    function GetTransparentColor: TColor;
    procedure NewImage(NewHandle: HBITMAP; NewPalette: HPALETTE;
      const NewDIB: TDIBSection; OS2Format: Boolean; RLEStream: TStream = nil);
    procedure ReadStream(Stream: TStream; Size: Longint);
    procedure ReadDIB(Stream: TStream; ImageSize: LongWord; bmf: PBitmapFileHeader = nil);
    procedure SetHandle(Value: HBITMAP);
    procedure SetHandleType(Value: TBitmapHandleType); virtual;
    procedure SetMaskHandle(Value: HBITMAP);
    procedure SetMonochrome(Value: Boolean);
    procedure SetPixelFormat(Value: TPixelFormat);
    procedure SetTransparentColor(Value: TColor);
    procedure SetTransparentMode(Value: TTransparentMode);
    function TransparentColorStored: Boolean;
    procedure WriteStream(Stream: TStream; WriteSize: Boolean);
  protected
    procedure Changed(Sender: TObject); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetPalette: HPALETTE; override;
    function GetWidth: Integer; override;
    procedure HandleNeeded;
    procedure MaskHandleNeeded;
    procedure PaletteNeeded;
    procedure ReadData(Stream: TStream); override;
    procedure SetHeight(Value: Integer); override;
    procedure SetPalette(Value: HPALETTE); override;
    procedure SetWidth(Value: Integer); override;
    procedure WriteData(Stream: TStream); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Dormant;
    procedure FreeImage;
    function HandleAllocated: Boolean;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure LoadFromResourceName(Instance: THandle; const ResName: String);
{$IFDEF MSWINDOWS}
    procedure LoadFromResourceID(Instance: THandle; ResID: Integer);
{$ENDIF}
    procedure Mask(TransparentColor: TColor);
    function ReleaseHandle: HBITMAP;
    function ReleaseMaskHandle: HBITMAP;
    function ReleasePalette: HPALETTE;
    procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
      var APalette: HPALETTE); override;
    procedure SaveToStream(Stream: TStream); override;
    property Canvas: TCanvas read GetCanvas;
    property Handle: HBITMAP read GetHandle write SetHandle;
    property HandleType: TBitmapHandleType read GetHandleType write SetHandleType;
    property IgnorePalette: Boolean read FIgnorePalette write FIgnorePalette;
    property MaskHandle: HBITMAP read GetMaskHandle write SetMaskHandle;
    property Monochrome: Boolean read GetMonochrome write SetMonochrome;
    property PixelFormat: TPixelFormat read GetPixelFormat write SetPixelFormat;
    property ScanLine[Row: Integer]: Pointer read GetScanLine;
    property TransparentColor: TColor read GetTransparentColor
      write SetTransparentColor stored TransparentColorStored;
    property TransparentMode: TTransparentMode read FTransparentMode
      write SetTransparentMode default tmAuto;
  end;

  { TIcon }
  { TIcon encapsulates window HICON handle. Drawing of an icon does not stretch
    so calling stretch draw is not meaningful.
      Handle - The HICON used by the TIcon. }

  TIconImage = class(TSharedImage)
  private
    FHandle: HICON;
    FMemoryImage: TCustomMemoryStream;
    FSize: TPoint;
  protected
    procedure FreeHandle; override;
  public
    destructor Destroy; override;
  end;

  TIcon = class(TGraphic)
  private
    FImage: TIconImage;
    FRequestedSize: TPoint;
    function GetHandle: HICON;
    procedure HandleNeeded;
    procedure ImageNeeded;
    procedure NewImage(NewHandle: HICON; NewImage: TMemoryStream);
    procedure SetHandle(Value: HICON);
  protected
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure SetHeight(Value: Integer); override;
    procedure SetTransparent(Value: Boolean); override;
    procedure SetWidth(Value: Integer); override;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function HandleAllocated: Boolean;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure LoadFromStream(Stream: TStream); override;
    function ReleaseHandle: HICON;
    procedure SaveToClipboardFormat(var Format: Word; var Data: THandle;
      var APalette: HPALETTE); override;
    procedure SaveToStream(Stream: TStream); override;
    property Handle: HICON read GetHandle write SetHandle;
  end;

var    // New TFont instances are intialized with the values in this structure:
  DefFontData: TFontData = (
    Handle: 0;
    Height: 0;
    Pitch: fpDefault;
    Style: [];
    Charset : DEFAULT_CHARSET;
    Name: 'MS Sans Serif');

var
  SystemPalette16: HPalette; // 16 color palette that maps to the system palette

var
  DDBsOnly: Boolean = False; // True = Load all BMPs as device bitmaps.
                             // Not recommended.

function GraphicFilter(GraphicClass: TGraphicClass): string;
function GraphicExtension(GraphicClass: TGraphicClass): string;
function GraphicFileMask(GraphicClass: TGraphicClass): string;

function ColorToRGB(Color: TColor): Longint;
function ColorToString(Color: TColor): string;
function StringToColor(const S: string): TColor;
procedure GetColorValues(Proc: TGetStrProc);
function ColorToIdent(Color: Longint; var Ident: string): Boolean;
function IdentToColor(const Ident: string; var Color: Longint): Boolean;
procedure GetCharsetValues(Proc: TGetStrProc);
function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;

procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
  var ImageSize: DWORD);
function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;

function CopyPalette(Palette: HPALETTE): HPALETTE;

procedure PaletteChanged;
procedure FreeMemoryContexts;

function GetDefFontCharSet: TFontCharSet;

function TransparentStretchBlt(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; MaskDC: HDC; MaskX,
  MaskY: Integer): Boolean;

function CreateMappedBmp(Handle: HBITMAP; const OldColors, NewColors: array of TColor): HBITMAP;
function CreateMappedRes(Instance: THandle; ResName: PChar; const OldColors, NewColors: array of TColor): HBITMAP;
function CreateGrayMappedBmp(Handle: HBITMAP): HBITMAP;
function CreateGrayMappedRes(Instance: THandle; ResName: PChar): HBITMAP;

function AllocPatternBitmap(BkColor, FgColor: TColor): TBitmap;

// Alignment must be a power of 2.  Color BMPs require DWORD alignment (32).
function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;

implementation

{ Things left out
  ---------------
  Regions
  PatBlt
  Tabbed text
  Clipping regions
  Coordinate transformations
  Paths
  Beziers }

uses Consts;

const
  csAllValid = [csHandleValid..csBrushValid];

var
  ScreenLogPixels: Integer;
  StockPen: HPEN;
  StockBrush: HBRUSH;
  StockFont: HFONT;
  StockIcon: HICON;
  BitmapImageLock: TRTLCriticalSection;
  CounterLock: TRTLCriticalSection;

procedure InternalDeletePalette(Pal: HPalette);
begin
  if (Pal <> 0) and (Pal <> SystemPalette16) then
    DeleteObject(Pal);
end;

{ Resource managers }

const
  ResInfoSize = SizeOf(TResource) - SizeOf(TFontData);

type
  TResourceManager = class(TObject)
    ResList: PResource;
    FLock: TRTLCriticalSection;
    ResDataSize: Word;
    constructor Create(AResDataSize: Word);
    destructor Destroy; override;
    function AllocResource(const ResData): PResource;
    procedure FreeResource(Resource: PResource);
    procedure ChangeResource(GraphicsObject: TGraphicsObject; const ResData);
    procedure AssignResource(GraphicsObject: TGraphicsObject;
      AResource: PResource);
    procedure Lock;
    procedure Unlock;
  end;

var
  FontManager: TResourceManager;
  PenManager: TResourceManager;
  BrushManager: TResourceManager;

function GetHashCode(const Buffer; Count: Integer): Word; assembler;
asm
        MOV     ECX,EDX
        MOV     EDX,EAX
        XOR     EAX,EAX
@@1:    ROL     AX,5
        XOR     AL,[EDX]
        INC     EDX
        DEC     ECX
        JNE     @@1
end;

constructor TResourceManager.Create(AResDataSize: Word);
begin
  ResDataSize := AResDataSize;
  InitializeCriticalSection(FLock);
end;

destructor TResourceManager.Destroy;
begin
  DeleteCriticalSection(FLock);
end;

procedure TResourceManager.Lock;
begin
  EnterCriticalSection(FLock);
end;

procedure TResourceManager.Unlock;
begin
  LeaveCriticalSection(FLock);
end;

function TResourceManager.AllocResource(const ResData): PResource;
var
  ResHash: Word;
begin
  ResHash := GetHashCode(ResData, ResDataSize);
  Lock;
  try
    Result := ResList;
    while (Result <> nil) and ((Result^.HashCode <> ResHash) or
      not CompareMem(@Result^.Data, @ResData, ResDataSize)) do
      Result := Result^.Next;
    if Result = nil then
    begin
      GetMem(Result, ResDataSize + ResInfoSize);
      with Result^ do
      begin
        Next := ResList;
        RefCount := 0;
        Handle := TResData(ResData).Handle;
        HashCode := ResHash;
        Move(ResData, Data, ResDataSize);
      end;
      ResList := Result;
    end;
    Inc(Result^.RefCount);
  finally
    Unlock;
  end;
end;

procedure TResourceManager.FreeResource(Resource: PResource);
var
  P: PResource;
  DeleteIt: Boolean;
begin
  if Resource <> nil then
    with Resource^ do
    begin
      Lock;
      try
        Dec(RefCount);
        DeleteIt := RefCount = 0;
        if DeleteIt then
        begin
          if Resource = ResList then
            ResList := Resource^.Next
          else
          begin
            P := ResList;
            while P^.Next <> Resource do P := P^.Next;
            P^.Next := Resource^.Next;
          end;
        end;
      finally
        Unlock;
      end;
      if DeleteIt then
      begin  // this is outside the critsect to minimize lock time
        if Handle <> 0 then DeleteObject(Handle);
        FreeMem(Resource);
      end;
    end;
end;

procedure TResourceManager.ChangeResource(GraphicsObject: TGraphicsObject;
  const ResData);
var
  P: PResource;
begin
  Lock;
  try  // prevent changes to GraphicsObject.FResource pointer between steps
    P := GraphicsObject.FResource;
    GraphicsObject.FResource := AllocResource(ResData);
    if GraphicsObject.FResource <> P then GraphicsObject.Changed;
    FreeResource(P);
  finally
    Unlock;