wwbitmap.pas

胜天进销存源码,国产优秀的进销存

unit wwbitmap;
{
//
// Components : TwwBitmap
//
// Copyright (c) 2001 by Woll2Woll Software
}
interface

{$i wwIfDef.pas}

uses Windows, Graphics, Classes, {fcGraphics, }wwChangeLink, SysUtils;

type
  TwwColor = record
    b, g, r: Byte
  end;
  PwwColor = ^TwwColor;

  TwwLine = array[0..0] of TwwColor;
  PwwLine = ^TwwLine;

  TwwPLines = array[0..0] of PwwLine;
  PwwPLines = ^TwwPLines;

  TwwBitmap = class(TGraphic)
  private
    FSmoothStretching: Boolean;
    FTransparentColor: TColor;

    FWidth: Integer;
    FHeight: Integer;
    FGap: Integer;
    FMaskBitmap: TBitmap;
    FRowInc: Integer;
    FSize: Integer;
    FBits: Pointer;
    FHandle: Integer;
    FDC: HDC;
    FCanvas: TCanvas;

    FMemoryImage: Pointer;
    FMemorySize: Integer;
    FMemoryDim: TSize;

    FPixelFormat: TPixelFormat;
    FPalette: HPALETTE;
    FRespectPalette: Boolean;
    FUseHalftonePalette: boolean;

    FIgnoreChange: Boolean;
    FChangeLinks: TList;

//    FPicture: TPicture;

    bmInfo: TBitmapInfo;
    bmHeader: TBitmapInfoHeader;
    function GetSleeping: Boolean;
    procedure InitHeader;
  protected
    Assigning: Boolean;
    SkipPalette: boolean;

    Procedure RestoreBitmapPalette(ACanvas: TCanvas; OldPalette: HPalette); virtual;
    Procedure SelectBitmapPalette(ACanvas: TCanvas; var OldPalette: HPalette); virtual;
    function GetEmpty: Boolean; override;
    function GetHeight: Integer; override;
    function GetWidth: Integer; override;
    procedure AssignTo(Dest: TPersistent); override;
    procedure Changed(Sender: TObject); override;
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
    procedure SetHeight(Value: Integer); override;
    procedure SetWidth(Value: Integer); override;

    procedure CleanUp; virtual;
    procedure Initialize; virtual;
    procedure NotifyChanges; virtual;
    procedure PaletteNeeded; virtual;

    property Gap: Integer read FGap;
    property RowInc: Integer read FRowInc;
    property DC: HDC read FDC;
  public
    Patch: Variant;
    Pixels: PwwPLines;
    Colors: array[Byte] of TRGBQuad;

    constructor Create; override;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;

    procedure RegisterChanges(ChangeLink: TwwChangeLink); virtual;
    procedure UnRegisterChanges(ChangeLink: TwwChangeLink); virtual;

    procedure Clear; virtual;
    procedure FreeMemoryImage; virtual;
    procedure LoadBlank(AWidth, AHeight: Integer); virtual;
    procedure LoadFromBitmap(Bitmap: TBitmap); virtual;
    procedure LoadFromJPEG(JPEG: TGraphic); virtual;
    procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
      APalette: HPALETTE); override;
    procedure LoadFromGraphic(Graphic: TGraphic); virtual;
    procedure LoadFromMemory(ABits: Pointer; ASize: Integer; Dimensions: TSize); virtual;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToBitmap(Bitmap: TBitmap); virtual;
    procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
      var APalette: HPALETTE); override;
    procedure SaveToStream(Stream: TStream); override;
    
    {$WARNINGS OFF}
    procedure SetSizeInternal(const AWidth, AHeight: Integer); virtual;
    {$WARNINGS ON}

    function GetMaskBitmap: TBitmap;
    function CopyPixels: PwwPLines;
    procedure Fill(Color: TColor);
    procedure Resize(AWidth, AHeight: Integer); virtual;
    procedure Sleep; virtual;
    procedure SmoothStretchDraw(ACanvas: TCanvas; Rect: TRect); virtual;
    procedure StretchDraw(ACanvas: TCanvas; const Rect: TRect); virtual;
    procedure TileDraw(ACanvas: TCanvas; ARect: TRect); virtual;
    procedure TransparentDraw(ACanvas: TCanvas; const Rect: TRect); virtual;
    procedure Wake; virtual;

    // Filters
    procedure AlphaBlend(Bitmap: TwwBitmap; Alpha: Integer; Stretch: Boolean);
    procedure Blur(Amount: Integer); virtual;
    procedure Contrast(Amount: Integer); virtual;
    procedure Emboss; virtual;
    procedure Flip(Horizontal: Boolean); virtual;
    procedure GaussianBlur(Amount: Integer); virtual;
    procedure Grayscale; virtual;
    procedure Invert; virtual;
    procedure Brightness(Amount: Integer); virtual;
    procedure Mask(MaskColor: TwwColor); virtual;

    { 12/7/99 - new method Changecolor used by fcImgBtn }
    procedure ChangeColor(OldColor: TwwColor; NewColor: TwwColor); virtual;
    procedure ColorTint(ra, ga, ba: Integer); virtual;
    procedure Colorize(ra, ga, ba: Integer); virtual;
//    procedure Colorize2(ra, ga, ba: Integer; ARect: TRect); virtual;
    procedure Rotate(Center: TPoint; Angle: Extended); virtual;
    procedure Saturation(Amount: Integer); virtual;
    procedure Sharpen(Amount: Integer); virtual;
    procedure Sponge(Amount: Integer); virtual;
    procedure Wave(XDiv, YDiv, RatioVal: Extended; Wrap: Boolean); virtual;

    property Bits: Pointer read FBits;
    property Canvas: TCanvas read FCanvas;
    property Handle: Integer read FHandle;
    property IgnoreChange: Boolean read FIgnoreChange write FIgnoreChange;
    property MaskBitmap: TBitmap read GetMaskBitmap;
    property RespectPalette: Boolean read FRespectPalette write FRespectPalette;
    property UseHalftonePalette: Boolean read FUseHalftonePalette write FUseHalftonePalette;
    property SmoothStretching: Boolean read FSmoothStretching write FSmoothStretching;
    property Sleeping: Boolean read GetSleeping;
    property Size: Integer read FSize;
    property TransparentColor: TColor read FTransparentColor write FTransparentColor;
  end;

function wwGetColor(Color: TColor): TwwColor;
function wwGetStdColor(Color: TwwColor): TColor;
function wwRGB(r, g, b: Byte): TwwColor;
function wwIntToByte(Value: Integer): Byte;
function wwTrimInt(i, Min, Max: Integer): Integer;

implementation

uses
{$ifdef wwdelphi6Up}
variants,
{$endif}
wwCommon;

{$R-}

type
  PPixel24 = ^TPixel24;
  TPixel24 = packed record
    Red: Byte;
    Green: Byte;
    Blue: Byte
  end;

procedure ByteSwapColors(var Colors; Count: Integer);
var   // convert RGB to BGR and vice-versa.  TRGBQuad <-> TPaletteEntry
  SysInfo: TSystemInfo;
begin
  GetSystemInfo(SysInfo);
  asm
        MOV   EDX, Colors
        MOV   ECX, Count
        DEC   ECX
        JS    @@END
        LEA   EAX, SysInfo
        CMP   [EAX].TSystemInfo.wProcessorLevel, 3
        JE    @@386
  @@1:  MOV   EAX, [EDX+ECX*4]
        BSWAP EAX
        SHR   EAX,8
        MOV   [EDX+ECX*4],EAX
        DEC   ECX
        JNS   @@1
        JMP   @@END
  @@386:
        PUSH  EBX
  @@2:  XOR   EBX,EBX
        MOV   EAX, [EDX+ECX*4]
        MOV   BH, AL
        MOV   BL, AH
        SHR   EAX,16
        SHL   EBX,8
        MOV   BL, AL
        MOV   [EDX+ECX*4],EBX
        DEC   ECX
        JNS   @@2
        POP   EBX
    @@END:
  end;
end;

(*
function SystemPaletteOverride(var Pal: TMaxLogPalette): Boolean;
var
  DC: HDC;
  SysPalSize: Integer;
begin
  Result := False;
  if SystemPalette16 <> 0 then
  begin
    DC := GetDC(0);
    try
      SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
      if SysPalSize >= 16 then
      begin
        { Ignore the disk image of the palette for 16 color bitmaps.
          Replace with the first and last 8 colors of the system palette }
        GetPaletteEntries(SystemPalette16, 0, 8, Pal.palPalEntry);
        GetPaletteEntries(SystemPalette16, 8, 8, Pal.palPalEntry[Pal.palNumEntries - 8]);
        Result := True;
      end
    finally
      ReleaseDC(0,DC);
    end;
  end;
end;


function PaletteFromDIBColorTable(DIBHandle: THandle; ColorTable: Pointer;
  ColorCount: Integer): HPalette;
var
  DC: HDC;
  Save: THandle;
  Pal: TMaxLogPalette;
begin
  Result := 0;
  Pal.palVersion := $300;
  if DIBHandle <> 0 then
  begin
    DC := CreateCompatibleDC(0);
    Save := SelectObject(DC, DIBHandle);
    Pal.palNumEntries := GetDIBColorTable(DC, 0, 256, Pal.palPalEntry);
    SelectObject(DC, Save);
    DeleteDC(DC);
  end
  else
  begin
    Pal.palNumEntries := ColorCount;
    Move(ColorTable^, Pal.palPalEntry, ColorCount * 4);
  end;
  if Pal.palNumEntries = 0 then Exit;
  if (Pal.palNumEntries <> 16) or not SystemPaletteOverride(Pal) then
    ByteSwapColors(Pal.palPalEntry, Pal.palNumEntries);
  Result := CreatePalette(PLogPalette(@Pal)^);
end;
*)

function wwSize(cx, cy: Integer): TSize;
begin
  result.cx := cx;
  result.cy := cy;
end;

function wwGetColor(Color: TColor): TwwColor;
begin
  //2/17/99 - Get Actual Color Value
  Color := ColorToRGB(Color);
  result.r := Color and $FF;
  result.g := Color and $FF00 shr 8;
  result.b := Color and $FF0000 shr 16;
end;

function wwGetStdColor(Color: TwwColor): TColor;
begin
  with Color do result := RGB(r, g, b);
end;

function wwRGB(r, g, b: Byte): TwwColor;
begin
  result.r := r;
  result.g := g;
  result.b := b;
end;

function wwIntToByte(Value: Integer): Byte;
begin
  if Value > 255 then result := 255
  else if Value < 0 then result := 0
  else result := Value;
end;

function wwTrimInt(i, Min, Max: Integer): Integer;
begin
  if i > Max then result := Max
  else if i < Min then result := Min
  else result := i;
end;

const
  DSx =     $00660046;
  DSna =    $00220326;

procedure fcDrawMask(Canvas: TCanvas; ARect: TRect; Bitmap, Mask: TBitmap;
  Buffer: Boolean);
var oldBkColor, oldTextColor: COLORREF;
    dcCompat: HDC;
    pbmpSave: HBITMAP;
    ABitmap: TBitmap;
    UseCanvas: TCanvas;
    Offset: TPoint;
begin
  oldBkColor := SetBkColor(Canvas.Handle, RGB(255, 255, 255));
  oldTextColor := SetTextColor(Canvas.Handle, RGB(0, 0, 0));

  ABitmap := nil;

  if Buffer then
  begin
    ABitmap := TBitmap.Create;
    ABitmap.Width := wwRectWidth(ARect);
    ABitmap.Height := wwRectHeight(ARect);
    ABitmap.Canvas.CopyRect(Rect(0, 0, ABitmap.Width, ABitmap.Height), Canvas, ARect);
    UseCanvas := ABitmap.Canvas;
    Offset := Point(0, 0);
  end else begin
    UseCanvas := Canvas;
    Offset := ARect.TopLeft;
  end;

  dcCompat := CreateCompatibleDC(Canvas.Handle);
  pbmpSave := SelectObject(dcCompat, Bitmap.Handle);
  BitBlt(UseCanvas.Handle, Offset.x, Offset.y, wwRectWidth(ARect), wwRectHeight(ARect), dcCompat, 0, 0, DSx);
  SelectObject(dcCompat, Mask.Handle);
  BitBlt(UseCanvas.Handle, Offset.x, Offset.y, wwRectWidth(ARect), wwRectHeight(ARect), dcCompat, 0, 0, DSna);
  SelectObject(dcCompat, Bitmap.Handle);
  BitBlt(UseCanvas.Handle, Offset.x, Offset.y, wwRectWidth(ARect), wwRectHeight(ARect), dcCompat, 0, 0, DSx);
  SelectObject(dcCompat, pbmpSave);
  DeleteDC(dcCompat);

  if Buffer then
  begin
    Canvas.CopyRect(ARect, ABitmap.Canvas, Rect(0, 0, ABitmap.Width, ABitmap.Height));
    ABitmap.Free;
  end;

  SetBkColor(Canvas.Handle, oldBkColor);
  SetTextColor(Canvas.Handle, oldTextColor);
end;

constructor TwwBitmap.Create;
begin
  inherited;
  FCanvas := TCanvas.Create;
  FChangeLinks := TList.Create;
  FTransparentColor := clNone;
  FPixelFormat := pf24Bit;
  Patch:= VarArrayCreate([0, 1], varVariant);
  Patch[0]:= False;     { Color table not valid }
  Patch[1]:= False;
end;

destructor TwwBitmap.Destroy;
begin
  FChangeLinks.Free;
  if Sleeping then FreeMemoryImage;
  CleanUp;
  FCanvas.Free;
  inherited;
end;

function TwwBitmap.GetSleeping: Boolean;
begin
  result := (FMemorySize > 0) and (FMemoryImage <> nil);
end;

function TwwBitmap.GetEmpty: Boolean;
begin
  result := FHandle = 0;
end;

function TwwBitmap.GetHeight: Integer;
begin
  result := FHeight;
end;

function TwwBitmap.GetWidth: Integer;
begin
  result := FWidth;
end;

procedure TwwBitmap.Assign(Source: TPersistent);
begin
  if (Source is TBitmap) and not (Source as TBitmap).Empty then
  begin
    FPixelFormat := (Source as TBitmap).PixelFormat;
    LoadFromBitmap(Source as TBitmap);
    Transparent := (Source as TBitmap).Transparent;
//    TransparentColor := (Source as TBitmap).TransparentColor;
  end else if (Source = nil) or ((Source is TBitmap) and (Source as TBitmap).Empty) then
  begin
    CleanUp;
    Changed(self);
  end else if (Source is TGraphic) and not (Source is TwwBitmap) then
  begin
    LoadFromGraphic(Source as TGraphic);
  end else inherited;
end;

procedure TwwBitmap.AssignTo(Dest: TPersistent);
begin
  if Dest is TBitmap then
  begin
    (Dest as TBitmap).PixelFormat := self.FPixelFormat;
    SaveToBitmap(Dest as TBitmap);
    (Dest as TBitmap).Transparent := Transparent;
    (Dest as TBitmap).TransparentColor := TransparentColor;
  end else if Dest is TwwBitmap then
    with TwwBitmap(Dest) do
  begin
    if not self.Empty then
    begin
      IgnoreChange := True;
      RespectPalette := self.RespectPalette;
      UseHalftonePalette:= self.UseHalftonePalette;
      LoadBlank(self.Width, self.Height);
      CopyMemory(TwwBitmap(Dest).Bits, self.Bits, self.Size);
      Transparent := self.Transparent;
      SmoothStretching := self.SmoothStretching;
      TransparentColor := self.TransparentColor;
      FPixelFormat := self.FPixelFormat;
      CopyMemory(@(Dest as TwwBitmap).Colors, @self.Colors, SizeOf(self.Colors));
      Patch[0]:= self.Patch[0];
      Patch[1]:= self.Patch[1]; // Halftone value
//      FHalfTone:= self.FHalfTone;

      IgnoreChange := False;
      Changed(Dest);
    end else begin
      CleanUp;
      Changed(Dest);
    end;
  end else inherited;
end;

procedure TwwBitmap.Changed(Sender: TObject);
begin
  if not IgnoreChange then
  begin
    inherited Changed(Sender);
    NotifyChanges;
  end;
end;

procedure TwwBitmap.NotifyChanges;
var i: Integer;
begin
  for i := 0 to FChangeLinks.Count - 1 do with TwwChangeLink(FChangeLinks[i]) do
  begin
    Sender := self;
    Change;
  end;
end;

procedure TwwBitmap.RegisterChanges(ChangeLink: TwwChangeLink);
begin
  FChangeLinks.Add(ChangeLink);
end;

procedure TwwBitmap.UnRegisterChanges(ChangeLink: TwwChangeLink);
begin
  FChangeLinks.Remove(ChangeLink);
end;

procedure TwwBitmap.TransparentDraw(ACanvas: TCanvas; const Rect: TRect);
var Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;
  Bmp.Width := Width;
  Bmp.Height := Height;
  Bmp.PixelFormat := pf24Bit;
  Bmp.Canvas.CopyRect(Classes.Rect(0, 0, Width, Height), Canvas, Classes.Rect(0, 0, Width, Height));
  fcDrawMask(ACanvas, Rect, Bmp, MaskBitmap, True);
  Bmp.Free;
end;

procedure TwwBitmap.StretchDraw(ACanvas: TCanvas; const Rect: TRect);
var TempBitmap: TwwBitmap;
begin
  if Transparent then
  begin
    TempBitmap := TwwBitmap.Create;
    TempBitmap.LoadBlank(wwRectWidth(Rect), wwRectHeight(Rect));
    StretchBlt(TempBitmap.Canvas.Handle, 0, 0, TempBitmap.Width, TempBitmap.Height,
      FDC, 0, 0, FWidth, FHeight, SRCCOPY);
    TempBitmap.TransparentDraw(ACanvas, Rect);
    TempBitmap.Free;
  end else begin
    SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
    with Rect do StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
      FDC, 0, 0, FWidth, FHeight, SRCCOPY);
  end;
end;

Procedure TwwBitmap.RestoreBitmapPalette(ACanvas: TCanvas; OldPalette: HPalette);
begin
  if (GetDeviceCaps(FDC, BITSPIXEL) <= 8)
     and (RespectPalette or UseHalftonePalette) then
  begin
    SelectPalette(ACanvas.Handle, OldPalette, True);
    if FPalette <> 0 then
    begin
      DeleteObject(FPalette);
      FPalette := 0;
    end;
  end;
end;

Procedure TwwBitmap.SelectBitmapPalette(ACanvas: TCanvas; var OldPalette: HPalette);
var
    DC: HDC;
begin