wwbitmap.pas

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

var Table: array[0..255] of TwwColor;
    x, y, i: Integer;
    CurBits: PwwColor;
begin
  for i := 0 to 255 do
  begin
    Table[i].b := wwIntToByte(i + ba);
    Table[i].g := wwIntToByte(i + ga);
    Table[i].r := wwIntToByte(i + ra);
  end;
  CurBits := Bits;
  for y := 0 to Height - 1 do
  begin
    for x := 0 to Width - 1 do
    begin
      CurBits.b := Table[CurBits.b].b;
      CurBits.g := Table[CurBits.g].g;
      CurBits.r := Table[CurBits.r].r;
      Inc(CurBits);
    end;
    CurBits := Pointer(Integer(CurBits) + Gap);
  end;
end;

procedure TwwBitmap.Colorize(ra, ga, ba: Integer);
const Alpha = 0.5;
      Offset = 128;
var x, y: Integer;
    CurBits: PwwColor;
    Tran: Boolean;
    TranColor: TwwColor;
    Pixel: TPixel24;
begin
  CurBits := Bits;
  Tran := FTransparentColor <> clNone;
  TranColor := wwGetColor(FTransparentColor);

  Pixel.Red := wwIntToByte(Trunc(Alpha*ra));
  Pixel.Blue := wwIntToByte(Trunc(Alpha*ba));
  Pixel.Green := wwIntToByte(Trunc(Alpha*ga));

  for y := 0 to Height - 1 do
  begin
    for x := 0 to Width - 1 do
    begin
      with TranColor do if not Tran or (Tran and not ((r = Pixels[y, x].r) and (g = Pixels[y, x].g) and (b = Pixels[y, x].b))) then
      begin
        CurBits.b := wwIntToByte((CurBits.b - Offset) + pixel.Blue);
        CurBits.g := wwIntToByte((CurBits.g - Offset) + pixel.Green);
        CurBits.r := wwIntToByte((CurBits.r - Offset) + pixel.Red);
      end;
      Inc(CurBits);
    end;
    CurBits := Pointer(Integer(CurBits) + Gap);
  end;
end;

{procedure TwwBitmap.Colorize2(ra, ga, ba: Integer;
   ARect: TRect);
var x, y: Integer;
    CurBits: PfcColor;
    Tran: Boolean;
    TranColor: TfcColor;
begin
  CurBits := Bits;
  Tran := FTransparentColor <> clNone;
  TranColor := wwGetColor(FTransparentColor);
  for y:= ARect.Top to ARect.Bottom-1 do
//  for y := 0 to Height - 1 do
  begin
    CurBits := Bits;
    Inc(CurBits, (Width+Gap)*(Height-1-y) + ARect.Left);

    for X := ARect.Left to ARect.Right-1 do
//    for x := 0 to Width - 1 do
    begin
      with TranColor do if not Tran or (Tran and not ((r = Pixels[y, x].r) and (g = Pixels[y, x].g) and (b = Pixels[y, x].b))) then
      begin
        CurBits.b := wwIntToByte((CurBits.b - 192) + ba);
        CurBits.g := wwIntToByte((CurBits.g - 192) + ga);
        CurBits.r := wwIntToByte((CurBits.r - 192) + ra);
      end;
      Inc(CurBits);
    end;
    CurBits := Pointer(Integer(CurBits) + Gap);
  end;
end;
}
procedure TwwBitmap.Contrast(Amount: Integer);
var x, y: Integer;
    Table: array[0..255] of Byte;
    CurBits: PwwColor;
begin
  for x := 0 to 126 do
  begin
    y := (Abs(128 - x) * Amount) div 256;
    y := x - y;
    Table[x] := wwIntToByte(y);
  end;
  for x := 127 to 255 do
  begin
    y := (Abs(128 - x) * Amount) div 256;
    y := x + y;
    Table[x] := wwIntToByte(y);
  end;
  CurBits := Bits;
  for y := 1 to FHeight do
  begin
    for x := 1 to FWidth do
    begin
      CurBits.b := Table[CurBits.b];
      CurBits.g := Table[CurBits.g];
      CurBits.r := Table[CurBits.r];
      Inc(CurBits);
    end;
    CurBits := Pointer(Integer(CurBits) + Gap);
  end;
end;

procedure TwwBitmap.AlphaBlend(Bitmap: TwwBitmap; Alpha: Integer; Stretch: Boolean);
var x, y, i: Integer;
    c1, c2, c3: PwwColor;
    Table: array[-255..255] of Integer;
    TranColor: TwwColor;
    Tran: Boolean;
    PassedBm: TwwBitmap;
begin
  PassedBm := nil;
  if (Width <> Bitmap.Width) or (Height <> Bitmap.Height) then
  begin
    if not Stretch then raise EInvalidOperation.Create('In Alpha Blend, Blend Bitmap must be same dimensions as Current Bitmap')
    else begin
      PassedBm := Bitmap;
      Tran := PassedBm.Transparent;
      PassedBm.Transparent := False;
      Bitmap := TwwBitmap.Create;
      Bitmap.Transparent := Tran;
      Bitmap.LoadBlank(Width, Height);
      Bitmap.Canvas.StretchDraw(Rect(0, 0, Width - 1, Height - 1), PassedBm);
      PassedBm.Transparent := Tran;
    end;
  end;

  for i := -255 to 255 do Table[i] := (Alpha * i) shr 8;
  TranColor := wwGetColor(0);
  c1 := Bits;
  c2 := Bitmap.Bits;
  c3 := Bits;

  Tran := Bitmap.Transparent and (Bitmap.Height = Height) and (Bitmap.Width = Width);
  if Tran then
  begin
{    if TransparentColor = clNone then TranColor := c2^
    else TranColor := fcGetColor(TransparentColor);}
    TranColor := c2^;
  end;

  for y := 0 to FHeight - 1 do
  begin
    for x := 0 to FWidth - 1 do
    begin
      if not Tran or (Tran and not ((c2.r = TranColor.r) and (c2.g = TranColor.g) and (c2.b = TranColor.b))) then
      begin
        c1.b := Table[c2.b - c3.b] + c3.b;
        c1.g := Table[c2.g - c3.g] + c3.g;
        c1.r := Table[c2.r - c3.r] + c3.r;
      end;
      Inc(c1);
      Inc(c2);
      Inc(c3);
    end;
    c1 := Pointer(Integer(c1) + Gap);
    c2 := Pointer(Integer(c2) + Bitmap.Gap);
    c3 := Pointer(Integer(c3) + Gap);
  end;
  if PassedBm <> nil then Bitmap.Free;
end;

procedure TwwBitmap.Grayscale;
var Grays: array[0..256] of Byte;
    i, x, y: Integer;
    CurBits: PwwColor;
begin
  x := 0; y := 0;
  for i := 0 to 85 do
  begin
    Grays[x + 0] := y;
    Grays[x + 1] := y;
    Grays[x + 2] := y;
    Inc(y);
    Inc(x, 3);
  end;
  CurBits := Bits;
  for y := 0 to FHeight - 1 do
  begin
    for x := 0 to FWidth - 1 do
    begin
      i := Grays[CurBits.b] + Grays[CurBits.g] + Grays[CurBits.r];
      CurBits.b := i;
      CurBits.g := i;
      CurBits.r := i;
      Inc(CurBits);
    end;
    CurBits := Pointer(Integer(CurBits) + Gap);
  end;
end;

procedure TwwBitmap.Invert;
var x, y: Integer;
    CurBits: PwwColor;
begin
  CurBits := Bits;
  for y := 0 to FHeight - 1 do
  begin
    for x := 0 to Width - 1 do
    begin
      CurBits.b := CurBits.b xor 255;
      CurBits.g := CurBits.g xor 255;
      CurBits.r := CurBits.r xor 255;
      Inc(CurBits);
    end;
    CurBits := Pointer(Integer(CurBits) + Gap);
  end;
end;

procedure TwwBitmap.Flip(Horizontal: Boolean);
var w, h, x, y: Integer;
    CurBits:  TwwColor;
    TmpLine, TmpLine2, Line: PwwLine;
    TopY: Integer;
begin
  TmpLine := nil;
  w := FWidth - 1;
  h := FHeight - 1;

  TopY := FHeight - 1;
  if not Horizontal then
  begin
    TopY := h div 2;
    GetMem(TmpLine, RowInc);
  end;

  try
    Line := Bits;
    for y := 0 to TopY do
    begin
      if Horizontal then for x := 0 to w div 2 do
      begin
        CurBits := Line[x];
        Line[x] := Line[w - x];
        Line[w - x] := CurBits;
      end else begin
        TmpLine2 := Pointer(Integer(Bits) + (h - y) * RowInc);
        CopyMemory(TmpLine, Line, RowInc);
        CopyMemory(Line, TmpLine2, RowInc);
        CopyMemory(TmpLine2, TmpLine, RowInc);
      end;
      Line := Pointer(Integer(Line) + RowInc);
    end;
  finally
    if not Horizontal then FreeMem(TmpLine);
  end;
end;

procedure TwwBitmap.Blur(Amount: Integer);
var Lin1, Lin2: PwwLine;
    pc: PwwColor;
    cx, x, y: Integer;
    Buf: array[0..3] of TwwColor;
begin
  pc := Bits;
  for y := 0 to FHeight - 1 do
  begin
    Lin1 := Pixels[wwTrimInt(y + Amount, 0, FHeight - 1)];
    Lin2 := Pixels[wwTrimInt(y - Amount, 0, FHeight - 1)];
    for x := 0 to FWidth - 1 do
    begin
      cx := wwTrimInt(x + Amount, 0, FWidth - 1);
      Buf[0] := Lin1[cx];
      Buf[1] := Lin2[cx];
      cx := wwTrimInt(x - Amount, 0, Width - 1);
      Buf[2] := Lin1[cx];
      Buf[3] := Lin2[cx];
      pc.b := (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b) shr 2;
      pc.g := (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g) shr 2;
      pc.r := (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r) shr 2;
      Inc(pc);
    end;
    pc := Pointer(Integer(pc) + Gap);
  end;
end;

procedure TwwBitmap.GaussianBlur(Amount: Integer);
var i: Integer;
begin
  for i := Amount downto 1 do
  Blur(i);
end;

procedure TwwBitmap.Sharpen(Amount: Integer);
var Lin0, Lin1, Lin2: PwwLine;
    pc: PwwColor;
    cx, x, y: Integer;
    Buf: array[0..8] of TwwColor;
begin
  pc := Bits;
  for y := 0 to FHeight - 1 do
  begin
    Lin0 := Pixels[wwTrimInt(y - Amount, 0, Height - 1)];
    Lin1 := Pixels[y];
    Lin2 := Pixels[wwTrimInt(y + Amount, 0, FHeight - 1)];
    for x := 0 to FWidth - 1 do
    begin
      cx := wwTrimInt(x - Amount, 0, FWidth - 1);
      Buf[0]:=Lin0[cx];
      Buf[1]:=Lin1[cx];
      Buf[2]:=Lin2[cx];
      Buf[3]:=Lin0[x];
      Buf[4]:=Lin1[x];
      Buf[5]:=Lin2[x];
      cx := wwTrimInt(x + Amount, 0, FWidth - 1);
      Buf[6]:=Lin0[cx];
      Buf[7]:=Lin1[cx];
      Buf[8]:=Lin2[cx];
      pc.b := wwIntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b +
        Buf[2].b + Buf[3].b + Buf[5].b + Buf[6].b + Buf[7].b +
        Buf[8].b) * 16) div 128);
      pc.g := wwIntToByte((256*Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g +
        Buf[3].g + Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16)
        div 128);
      pc.r := wwIntToByte((256*Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r +
        Buf[3].r + Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16)
        div 128);
      Inc(pc);
    end;
    pc := Pointer(Integer(pc) + Gap);
  end;
end;

procedure TwwBitmap.Sponge(Amount: Integer);
var r, x, y: Integer;
begin
  for y := 0 to FHeight - 1 do
    for x := 0 to FWidth - 1 do
    begin
      r := Random(Amount);
      Pixels[y, x] := Pixels[
        wwTrimInt(y + (r - Random(r * 2)), 0, FHeight - 1),
        wwTrimInt(x + (r - Random(r * 2)), 0, FWidth - 1)
      ];
    end;
end;

procedure TwwBitmap.Emboss;
var x, y: Integer;
    p1, p2: PwwColor;
    Line: PwwLine;
begin
  p1 := Bits;
  p2 := Pointer(Integer(p1) + RowInc + 3);
  GetMem(Line, RowInc);
  CopyMemory(Line, Pixels[FHeight - 1], RowInc);
  for y := 0 to Height - 1 do
  begin
    for x := 0 to Width - 1 do
    begin
      p1.b := (p1.b + (p2.b xor $FF)) shr 1;
      p1.g := (p1.g + (p2.g xor $FF)) shr 1;
      p1.r := (p1.r + (p2.r xor $FF)) shr 1;
      Inc(p1);
      if(y < FHeight - 2) and (x < FWidth - 2) then Inc(p2);
    end;
    p1 := Pointer(Integer(p1) + FGap);
    if y < FHeight - 2 then p2 := Pointer(Integer(p2) + Gap + 6)
    else p2 := Pointer(Integer(Line) + 3);
  end;
  FreeMem(Line);
end;

procedure TwwBitmap.Mask(MaskColor: TwwColor);
var x, y: Integer;
begin
  for y := 0 to FHeight - 1 do
    for x := 0 to FWidth - 1 do
      with Pixels[y, x] do
    begin
      if (r = MaskColor.r) and (g = MaskColor.g) and (b = MaskColor.b) then
        Pixels[y, x] := wwRGB(0, 0, 0)
      else Pixels[y, x] := wwRGB(255, 255, 255);
    end;
end;

procedure TwwBitmap.ChangeColor(OldColor: TwwColor; NewColor: TwwColor);
var x, y: Integer;
begin
  for y := 0 to FHeight - 1 do
    for x := 0 to FWidth - 1 do
      with Pixels[y, x] do
    begin
      if (r = OldColor.r) and (g = OldColor.g) and (b = OldColor.b) then
        Pixels[y, x] := NewColor;
    end;
end;

procedure TwwBitmap.Wave(XDiv, YDiv, RatioVal: Extended; Wrap: Boolean);
type
  TArray = array[0..0]of Integer;
  PArray = ^TArray;
var i, j, XSrc, YSrc: Integer;
    st: PArray;
    Pix: PwwColor;
    Line: PwwLine;
    Dst: TwwBitmap;
    Max: Integer;
    PInt: PInteger;
begin
  if (YDiv = 0) or (XDiv = 0) then Exit;
  Line := nil;
  Max := 0;

  Dst := TwwBitmap.Create;
  Dst.LoadBlank(FWidth, FHeight);
  GetMem(st, 4 * FHeight);

  try
    for j := 0 to FHeight - 1 do
      st[j] := Round(RatioVal * Sin(j / YDiv));

    if Wrap then Max := Integer(Pixels[FHeight - 1]) + RowInc;

    for i := 0 to FWidth - 1 do
    begin
      YSrc := Round(RatioVal * Sin(i / XDiv));

      if Wrap then
      begin
        if YSrc < 0 then YSrc := FHeight - 1 - (-YSrc mod FHeight)
        else if YSrc >= FHeight then YSrc := YSrc mod (FHeight - 1);
      end;

      Pix := Pointer(Integer(Dst.Bits) + i * 3);
      if ((YSrc >= 0) and (YSrc < FHeight)) or Wrap then Line := Pixels[YSrc];
      PInt := PInteger(st);

      for j := 0 to FHeight - 1 do
      begin
        if Wrap then
        begin
          XSrc := i + PInt^;
          Inc(PInt);
          if XSrc < 0 then
            XSrc := FWidth - 1 - (-XSrc mod FWidth)
          else if XSrc >= FWidth then
            XSrc := XSrc mod FWidth;
          Pix^ := Line[XSrc];
          Pix := Pointer(Integer(Pix) + Dst.RowInc);
          Line := Pointer(Integer(Line) + FRowInc);
          if Integer(Line) >= Max then Line := FBits;
        end else begin
          if (YSrc >= FHeight) then Break;
          XSrc := i + st[j];
          if (XSrc > -1) and (XSrc < FWidth) and (YSrc > -1) then
            Pix^ := Line^[XSrc]
          else if YSrc = -1 then
          begin
            Pix := Pointer(Integer(Pix) + Dst.RowInc);
            Line := FBits;
            YSrc:=0;
            Continue;
          end;
          Pix := Pointer(Integer(Pix) + Dst.RowInc);
          Line := Pointer(Integer(Line) + RowInc);
          Inc(YSrc);
        end;
      end;
    end;
    CopyMemory(FBits, Dst.Bits, FSize);
  finally
    FreeMem(st);
    Dst.Free;
  end;
end;

procedure TwwBitmap.Rotate(Center: TPoint; Angle: Extended);
var cAngle, sAngle: Double;                   // Cos Angle, Sin Angle, respectively
    SrcX, SrcY, px, py, x, y: Integer;
    CurBits: PwwColor;
    Dst: TwwBitmap;
begin
  if Center.x < 0 then Center.X := FWidth div 2;
  if Center.y < 0 then Center.Y := FHeight div 2;

  Dst := TwwBitmap.Create;
  Dst.LoadBlank(Width, Height);
  Dst.Canvas.Brush.Color := wwGetStdColor(Pixels[0, 0]);
  Dst.Canvas.FillRect(Rect(0, 0, Dst.Width, Dst.Height));
  Angle := -Angle * Pi / 180;
  sAngle := Sin(Angle);
  cAngle := Cos(Angle);
  CurBits := Dst.Bits;
  for y := 0 to Dst.Height - 1 do
  begin
    py := 2 * (y - Center.y) + 1;
    for x := 0 to Dst.Width - 1 do
    begin
      px := 2 * (x - Center.x) + 1;
      SrcX := ((Round(px * cAngle - py * sAngle) - 1) div 2 + Center.x);
      SrcY:= ((Round(px * sAngle + py * cAngle) - 1) div 2 + Center.y);
      if (SrcX > -1) and (SrcX < FWidth) and (SrcY > -1) and (SrcY < FHeight) then
        CurBits^ := Pixels[SrcY, SrcX];
      Inc(CurBits);
    end;
    CurBits := Pointer(Integer(CurBits) + Dst.Gap);
  end;
  CopyMemory(FBits, Dst.Bits, FSize);
  Dst.Free;
end;

procedure TwwBitmap.Sleep;
begin
  if Sleeping then FreeMemoryImage;

  FMemorySize := FSize;
  FMemoryDim := wwSize(Width, Height);
  GetMem(FMemoryImage, FMemorySize);
  CopyMemory(FMemoryImage, FBits, FMemorySize);
  CleanUp;
end;

procedure TwwBitmap.Wake;
begin
  if (FMemoryImage = nil) or (FMemorySize = 0) then Exit;

  LoadFromMemory(FMemoryImage, FMemorySize, FMemoryDim);
  FreeMemoryImage;
end;

{$R+}

end.