lbmorphbmp.pas

天涯進銷存系統

unit LBMorphBmp;

{$P+,S-,W-,R-}
{$C PRELOAD}

interface

{ remove this line for remove shareware limitation }
{$DEFINE SHAREWARE}

uses Graphics, Windows, LBMorphUtils;

type

  TFColor = record
    b,g,r: Byte;
  end;
  PFColor=^TFColor;

  TLine = array[0..0]of TFColor;
  PLine = ^TLine;
  TFilterProc = function(Value :Single) :Single;

  type
    TGradKind = (gdRight, gdLeft, gdTop, gdBottom, gdVCenter, gdHCenter);

  TEffectBmp = class(TObject)
  private
    procedure SetPixel(x,y:Integer;Clr:Integer);
    function GetPixel(x,y:Integer):Integer;
    procedure SetLine(y:Integer;Line:Pointer);
    function GetLine(y:Integer):Pointer;
  public
    Handle, Width, Height, Size: Integer;
    Bits: Pointer;
    BmpHeader: TBITMAPINFOHEADER;
    BmpInfo: TBITMAPINFO;
    constructor Create(cx,cy:Integer);
    constructor CreateFromhWnd(hBmp:Integer);
    constructor CreateCopy(hBmp:TEffectBmp);
    destructor  Destroy; override;
    property Pixels[x,y:Integer]:Integer read GetPixel write SetPixel;
    property ScanLines[y:Integer]:Pointer read GetLine write SetLine;
    procedure GetScanLine(y:Integer;Line:Pointer);
    procedure   Flip;   //Horizontal
    procedure   Flop;   //Vertical
    procedure Resize(Dst:TEffectBmp);
    procedure Tile(Dst:TEffectBmp);
    procedure Draw(hDC,x,y:Integer);
    procedure Stretch(hDC,x,y,cx,cy:Integer);
    procedure DrawRect(hDC,hx,hy,x,y,cx,cy:Integer);
    procedure TileDraw(hDC,x,y,cx,cy:Integer);
    procedure SplitBlur(Amount:Integer);
    procedure Wave(XDIV,YDIV,RatioVal:Integer);
    procedure AddColorNoise(Amount:Integer);
    procedure AddMiddleColor(Color: TColor);
    procedure AddMiddleColorInRect(Color: TColor; Rct: TRect);
    procedure Blur(Amount: integer);
    procedure MaskSplitBlur(Msk: TEffectBmp; Amount: Integer);
    procedure MiddleBMP(EB:TEffectBmp);
    procedure AddGradColor(Color: TColor; Kind: TGradKind);
    procedure AddGradBMP(BMP: TEffectBMP; Kind: TGradKind);
    procedure Morph(BMP: TEffectBMP; Kf: Double);
    procedure MorphRect(BMP: TEffectBMP; Kf: Double; Rct: TRect;
                        StartX, StartY: Integer);
    procedure CopyRect(BMP: TEffectBMP; Rct:TRect; StartX, StartY: Integer);
  end;

  PEfBmp = ^TEffectBmp;

implementation

uses Forms;

procedure TEffectBmp.SetPixel(x,y:Integer;Clr:Integer);
begin
  CopyMemory(
    Pointer(Integer(Bits)+(y*(Width mod 4))+(((y*Width)+x)*3)), @Clr,3);
end;

function TEffectBmp.GetPixel(x,y:Integer):Integer;
begin
  CopyMemory(
    @Result,
    Pointer(Integer(Bits)+(y*(Width mod 4))+(((y*Width)+x)*3)), 3);
end;

procedure TEffectBmp.SetLine(y:Integer;Line:Pointer);
begin
  CopyMemory(
    Pointer(Integer(Bits)+(y*(Width mod 4))+((y*Width)*3)), Line, Width*3);
end;

function TEffectBmp.GetLine(y:Integer):Pointer;
begin
  Result := Pointer(Integer(Bits)+(y*(Width mod 4))+((y*Width)*3));
end;

procedure TEffectBmp.GetScanLine(y:Integer;Line:Pointer);
begin
  CopyMemory(
    Line,
    Pointer(Integer(Bits)+(y*(Width mod 4))+((y*Width)*3)), Width*3);
end;


constructor TEffectBmp.Create(cx,cy:Integer);
begin
  Width := cx;
  Height := cy;
  Size := ((Width*3)+(Width mod 4))*Height;
  with BmpHeader do
  begin
    biSize := SizeOf(BmpHeader);
    biWidth := Width;
    biHeight := -Height;
    biPlanes := 1;
    biBitCount := 24;
    biCompression := BI_RGB;
  end;
  BmpInfo.bmiHeader := BmpHeader;
  Handle := CreateDIBSection(0,
                   BmpInfo,
                   DIB_RGB_COLORS,
                   Bits,
                   0,
                   0);
end;

constructor TEffectBmp.CreateFromhWnd(hBmp:Integer);
var
  Bmp: TBITMAP;
  hDC: Integer;
begin
  hDC := CreateDC('DISPLAY',nil,nil,nil);
  SelectObject(hDC,hBmp);
  GetObject(hBmp,SizeOf(Bmp),@Bmp);
  Width := Bmp.bmWidth;
  Height := Bmp.bmHeight;
  Size := ((Width*3)+(Width mod 4))*Height;

  with BmpHeader do
  begin
    biSize := SizeOf(BmpHeader);
    biWidth := Width;
    biHeight := -Height;
    biPlanes := 1;
    biBitCount := 24;
    biCompression := BI_RGB;
  end;
  BmpInfo.bmiHeader := BmpHeader;
  Handle := CreateDIBSection(0,
                   BmpInfo,
                   DIB_RGB_COLORS,
                   Bits,
                   0,
                   0);
  GetDIBits(hDC,hBmp,0,Height,Bits,BmpInfo,DIB_RGB_COLORS);
  DeleteDC(hDC);
end;

constructor TEffectBmp.CreateCopy(hBmp:TEffectBmp);
begin
  BmpHeader := hBmp.BmpHeader;
  BmpInfo := hBmp.BmpInfo;
  Width := hBmp.Width;
  Height := hBmp.Height;
  Size := ((Width*3)+(Width mod 4))*Height;

  Handle := CreateDIBSection(0,
                   BmpInfo,
                   DIB_RGB_COLORS,
                   Bits,
                   0, 
                   0);
  CopyMemory(Bits,hBmp.Bits,Size);
end;


procedure TEffectBmp.Stretch(hDC,x,y,cx,cy:Integer);
begin
  StretchDiBits(hDC,
                x,y,cx,cy,
                0,0,Width,Height,
                Bits,
                BmpInfo,
                DIB_RGB_COLORS,
                SRCCOPY);
end;

procedure TEffectBmp.Flip;
var
Buff,
Line: PLine;
x,y:  Integer;
begin
  GetMem(Line,Width*3);
  GetMem(Buff,Width*3);

  for y:=0 to Height-1 do
  begin
    GetScanLine(y,Buff);
    for x:=0 to Width-1 do
    begin
      Line^[(Width-1)-x].r:=Buff[x].r;
      Line^[(Width-1)-x].g:=Buff[x].g;
      Line^[(Width-1)-x].b:=Buff[x].b;
    end;
    ScanLines[y]:=Line;
  end;
  FreeMem(Buff,Width*3);
  FreeMem(Line,Width*3);
end;

procedure TEffectBmp.Flop;
var
y,cy: Integer;
Buff,
Line: PLine;
begin
  GetMem(Buff,Width*3);
  GetMem(Line,Width*3);
  if Odd(Height)then cy:=Height div 2 else cy:=Height div 2 - 1;
  for y:=0 to cy do
  begin
    GetScanLine(y,Buff);
    GetScanLine((Height-1)-y,Line);
    ScanLines[y]:=Line;
    ScanLines[(Height-1)-y]:=Buff;
  end;
  FreeMem(Buff,Width*3);
  FreeMem(Line,Width*3);
end;

procedure TEffectBmp.Draw(hDC,x,y:Integer);
begin
  SetDIBitsToDevice(hDC,
                    x,y,Width,Height,
                    0,0,0,Height,
                    Bits,
                    BmpInfo,
                    DIB_RGB_COLORS);
end;

procedure TEffectBmp.DrawRect(hDC,hx,hy,x,y,cx,cy:Integer);
begin
  StretchDiBits(hDC,
                hx,hy+cy-1,cx,-cy+1,
                x,Height-y,cx,-cy+1,
                Bits,
                BmpInfo,
                DIB_RGB_COLORS,
                SRCCOPY);
end;

procedure TEffectBmp.TileDraw(hDC,x,y,cx,cy:Integer);
var
  w, h, hBmp, DeskDC, MemDC: Integer;
begin
  DeskDC := GetWindowDC(0);
  MemDC := CreateCompatibleDC(DeskDC);
  ReleaseDC(0,DeskDC);
  hBmp := CreateCompatibleBitmap(DeskDC,cx,cy);
  SelectObject(MemDC,hBmp);
  Draw(MemDC,0,0);
  w := Width;
  h := Height;
  while h < cy do
  begin
    BitBlt(MemDC,0,h,w,h*2,MemDC,0,0,SRCCOPY);
    Inc(h,h);
  end;
  while w < cx do
  begin
    BitBlt(MemDC,w,0,w*2,cy,MemDC,0,0,SRCCOPY);
    Inc(w,w);
  end;
  BitBlt(hDC,x,y,cx,cy,MemDC,0,0,SRCCOPY);
  DeleteDC(MemDC);
  DeleteObject(hBmp);
end;

procedure TEffectBmp.Tile(Dst:TEffectBmp);
var
  LineOut, LineIn:  PLine;
  x, y, a, b: Integer;
begin
  a := 0;
  b := 0;
  GetMem(LineIn,Width*3);
  GetMem(LineOut,Dst.Width*3);

  for y := 0 to Dst.Height-1 do
  begin
    GetScanLine(b,LineIn);
    for x := 0 to Dst.Width-1 do
    begin
      LineOut^[x].r := LineIn^[a].r;
      LineOut^[x].g := LineIn^[a].g;
      LineOut^[x].b := LineIn^[a].b;
      Inc(a);
      if a = Width then a:=0;
    end;
    Dst.ScanLines[y]:=LineOut;
    a := 0;
    Inc(b);
    if b = Height then b:=0;
  end;
  FreeMem(LineOut,Dst.Width*3);
  FreeMem(LineIn,Width*3);
end;

procedure TEffectBmp.Resize(Dst:TEffectBmp);
var
  xCount, yCount, x,y: Integer;
  xScale, yScale: Double;
begin
  xScale := (Dst.Width-1) / Width;
  yScale := (Dst.Height-1) / Height;

  for y := 0 to Height-1 do
  for x := 0 to Width-1 do
    begin
      for yCount := 0 to Trunc(yScale) do
      for xCount := 0 to Trunc(xScale) do
      begin
        Dst.Pixels[Trunc(xScale*x)+xCount,Trunc(yScale*y)+yCount]:=Pixels[x,y];
      end;
    end;
end;

procedure TEffectBmp.AddColorNoise(Amount:Integer);
var
  x,y,r,g,b: Integer;
  Line: PLine;
begin
  GetMem(Line,Width*3);
  for y := 0 to Height - 1 do
  begin
    GetScanLine(y,Line);
    for x:=0 to Width-1 do
    begin
      r := Line^[x].r+(Random(Amount)-(Amount div 2));
      g := Line^[x].g+(Random(Amount)-(Amount div 2));
      b := Line^[x].b+(Random(Amount)-(Amount div 2));
      if r > 255 then r := 255 else if r < 0 then r := 0;
      if g > 255 then g := 255 else if g < 0 then g := 0;
      if b > 255 then b := 255 else if b < 0 then b:=0;
      Line^[x].r := r;
      Line^[x].g := g;
      Line^[x].b := b;
    end;
    ScanLines[y]:=Line;
  end;
  FreeMem(Line,Width*3);
end;


procedure TEffectBmp.AddMiddleColor(Color: TColor);
var
  x,y,r,g,b: Integer;
  Line: PLine;
  _r, _g, _b: byte;
begin
  GetMem(Line,Width*3);
  _r := GetRValue(ColorToRGB(Color));
  _g := GetGValue(ColorToRGB(Color));
  _b := GetBValue(ColorToRGB(Color));
  for y := 0 to Height-1 do
  begin
    GetScanLine(y,Line);
    for x := 0 to Width-1 do
    begin
      r:=(Line^[x].r + _r) div 2;
      g:=(Line^[x].g + _g) div 2;
      b:=(Line^[x].b + _b) div 2;
      if r > 255 then r := 255 else if r < 0 then r := 0;
      if g > 255 then g := 255 else if g < 0 then g := 0;
      if b > 255 then b := 255 else if b < 0 then b := 0;
      Line^[x].r := r;
      Line^[x].g := g;
      Line^[x].b := b;
    end;
    ScanLines[y] := Line;