wwbitmap.pas

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

  if (GetDeviceCaps(FDC, BITSPIXEL) <= 8) then begin
     if RespectPalette or UseHalftonePalette then
     begin
       if RespectPalette then
       begin
          PaletteNeeded;
       end
       else if UseHalftonePalette then begin
          DC := GetDC(0);
          FPalette := CreateHalftonePalette(DC);
          ReleaseDC(0, DC);
       end;
       OldPalette := SelectPalette(ACanvas.Handle, FPalette, True);
       RealizePalette(ACanvas.Handle);
    end
  end
end;

procedure TwwBitmap.Draw(ACanvas: TCanvas; const Rect: TRect);
  function Transparent: Boolean;
  begin
    result := self.Transparent and not Assigning;
  end;
  function SmoothStretching: Boolean;
  begin
    result := self.SmoothStretching and not Assigning;
  end;
var OldPalette: HPALETTE;
//    DC: HDC;
begin
  OldPalette := 0;
  if not SkipPalette then SelectBitmapPalette(ACanvas, OldPalette);
{  if (GetDeviceCaps(FDC, BITSPIXEL) <= 8) and (not SkipPalette) then begin
     if RespectPalette or UseHalftonePalette then
     begin
       if RespectPalette then
       begin
          PaletteNeeded;
       end
       else if UseHalftonePalette then begin
          DC := GetDC(0);
          FPalette := CreateHalftonePalette(DC);
          ReleaseDC(0, DC);
       end;
       OldPalette := SelectPalette(ACanvas.Handle, FPalette, True);
       RealizePalette(ACanvas.Handle);
     end
  end;}

  with Rect do
  begin
    if ((Right - Left) = Width) and ((Bottom - Top) = Height) then
    begin
      if Transparent then TransparentDraw(ACanvas, Rect)
      else BitBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top, FDC, 0, 0, SRCCOPY);
    end else begin
      if FSmoothStretching then SmoothStretchDraw(ACanvas, Rect)
      else StretchDraw(ACanvas, Rect);
    end;
  end;
  if not SkipPalette then RestoreBitmapPalette(ACanvas, OldPalette);
{
  if (GetDeviceCaps(FDC, BITSPIXEL) <= 8) and (not SkipPalette)
     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.Initialize;
var x, i: Integer;
    TempDC: HDC;
begin
  GetMem(Pixels, FHeight * SizeOf(PwwLine));
  FRowInc := (FWidth * 3) + FWidth mod 4;
  FGap := FWidth mod 4;
  FSize := FRowInc * FHeight;
  x := Integer(Bits);
  for i := 0 to Height - 1 do
  begin
    Pixels[i] := Pointer(x);
    Inc(x, RowInc);
  end;
  TempDC := GetDC(0);
  FDC := CreateCompatibleDC(TempDC);
  ReleaseDC(0, TempDC);
  SelectObject(FDC, FHandle);
  if Handle = 0 then CleanUp;
  FCanvas.Handle := FDC;
  Changed(self);
end;

procedure TwwBitmap.PaletteNeeded;
var Pal: TMaxLogPalette;
    DC: HDC;
begin
  if (FPalette <> 0) or (Patch[0]=False) then begin
     DC := GetDC(0);
     { 12/4/99 }
     if Patch[1]=true then FPalette := CreateHalftonePalette(DC);
     ReleaseDC(0, DC);
     exit;
  end;
//  if (FPalette <> 0) or (PInteger(@Colors[0])^ = 0) then Exit;

  Pal.palVersion := $300;
  Pal.palNumEntries := 256;
  Move(Colors, Pal.palPalEntry, 256 * 4);

  if (Pal.palNumEntries <> 16) then
    ByteSwapColors(Pal.palPalEntry, Pal.palNumEntries);
  FPalette := CreatePalette(PLogPalette(@Pal)^);
end;

procedure TwwBitmap.SetHeight(Value: Integer);
begin
  SetSizeInternal(Width, Height);
end;

procedure TwwBitmap.SetWidth(Value: Integer);
begin
  SetSizeInternal(Value, Height);
end;

procedure TwwBitmap.CleanUp;
begin
  FCanvas.Handle := 0;
  if FDC <> 0 then DeleteDC(FDC);
  if FHandle <> 0 then DeleteObject(FHandle);
  if Pixels <> nil then FreeMem(Pixels);
  if FMaskBitmap <> nil then FMaskBitmap.Free;
  FDC := 0;
  FHandle := 0;
  Pixels := nil;
  FMaskBitmap := nil;
  FWidth := 0;
  FHeight := 0;
  FSize := 0;
  FBits := nil;
end;

procedure TwwBitmap.Clear;
begin
  CleanUp;
end;

procedure TwwBitmap.FreeMemoryImage;
begin
  FreeMem(FMemoryImage);
  FMemoryImage := nil;
  FMemoryDim := wwSize(0, 0);
  FMemorySize := 0;
end;

procedure TwwBitmap.InitHeader;
begin
  with bmHeader do
  begin
    biSize := SizeOf(bmHeader);
    biWidth := Width;
    biHeight := -Height;
    biPlanes := 1;
    biBitCount := 24;
    biCompression := BI_RGB;
  end;
end;

procedure TwwBitmap.LoadBlank(AWidth, AHeight: Integer);
begin
  CleanUp;
  if (AWidth = 0) or (AHeight = 0) then Exit;

  FWidth := AWidth;
  FHeight := AHeight;

  InitHeader;

  bmInfo.bmiHeader := bmHeader;
  FHandle := CreateDIBSection(0, bmInfo, DIB_RGB_COLORS, FBits, 0, 0);
  Initialize;
  FCanvas.Brush.Color := clWhite;
  FCanvas.FillRect(Rect(0, 0, FWidth, FHeight));
end;

procedure TwwBitmap.LoadFromBitmap(Bitmap: TBitmap);
var MemDC: Integer;
  { RSW - 3/2/99}
  procedure SetPixelFormat;
  var DS: TDIBSection;
  begin
    DS.dsbmih.biSize := 0;
    GetObject(Bitmap.Handle, SizeOf(DS), @DS);
    MemDC := GetDC(0);
    Patch[1]:=  { 12/4/99 }
       ((GetDeviceCaps(MemDC, BITSPIXEL) * GetDeviceCaps(MemDC, PLANES)) <
       ((ds.dsbm.bmBitsPixel * ds.dsbm.bmPlanes)));
    ReleaseDC(0, MemDC);

    FPixelFormat:= Bitmap.PixelFormat;
    if Bitmap.PixelFormat <> pfCustom then exit;

//    DS.dsbmih.biSize := 0;
//    GetObject(Bitmap.Handle, SizeOf(DS), @DS);
    case DS.dsbmih.biBitCount of
    1: FPixelFormat:= pf1bit;
    4: FPixelFormat:= pf4bit;
    8: FPixelFormat:= pf8bit;
    16: FPixelFormat:= pf16bit;
    24: FPixelFormat:= pf24bit;
    32: FPixelFormat:= pf32bit;
    end;
  end;

begin
  CleanUp;
  FWidth := Bitmap.Width;
  FHeight := Bitmap.Height;
  FSize := ((FWidth * 3) + (FWidth mod 4)) * FHeight;

  InitHeader;

  bmInfo.bmiHeader := bmHeader;
  FHandle := CreateDIBSection(0, bmInfo, DIB_RGB_COLORS, FBits, 0, 0);
  MemDC := GetDC(0);
  GetDIBits(MemDC, Bitmap.Handle, 0, FHeight, FBits, bmInfo, DIB_RGB_COLORS);
  ReleaseDC(0, MemDC);
  Initialize;
//  FPixelFormat := Bitmap.PixelFormat;
  SetPixelFormat;
  Patch[0]:= GetDIBColorTable(Bitmap.Canvas.Handle, 0, 256, Colors)<>0;
end;

procedure TwwBitmap.LoadFromJPEG(JPEG: TGraphic);
var ABitmap: TBitmap;
begin
  ABitmap := TBitmap.Create;
  ABitmap.Width := JPEG.Width;
  ABitmap.Height := JPEG.Height;
  ABitmap.Canvas.Draw(0, 0, JPEG);
  LoadFromBitmap(ABitmap);
  ABitmap.Free;
end;

procedure TwwBitmap.LoadFromGraphic(Graphic: TGraphic);
var ABitmap: TBitmap;
begin
  ABitmap := TBitmap.Create;
  ABitmap.Assign(Graphic);
  LoadFromBitmap(ABitmap);
  ABitmap.Free;
end;

procedure TwwBitmap.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  APalette: HPALETTE);
begin
end;

procedure TwwBitmap.LoadFromMemory(ABits: Pointer; ASize: Integer; Dimensions: TSize);
var MemDC: Integer;
    TempBmHandle: HBITMAP;
begin
  CleanUp;
  FWidth := Dimensions.cx;
  FHeight := Dimensions.cy;
  FSize := ASize;

  InitHeader;

  bmInfo.bmiHeader := bmHeader;
  MemDC := GetDC(0);
  FHandle := CreateDIBSection(0, bmInfo, DIB_RGB_COLORS, FBits, 0, 0);
  TempBmHandle := CreateDIBitmap(MemDC, bmHeader, CBM_INIT, ABits, bmInfo, DIB_RGB_COLORS);
  GetDIBits(MemDC, TempBmHandle, 0, FHeight, FBits, bmInfo, DIB_RGB_COLORS);
  DeleteObject(TempBmHandle);
  ReleaseDC(0, MemDC);
  Initialize;
end;

procedure TwwBitmap.LoadFromStream(Stream: TStream);
var Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  try
    Bitmap.LoadFromStream(Stream);
    LoadFromBitmap(Bitmap);
  finally
    Bitmap.Free;
  end;
end;

procedure TwwBitmap.SaveToBitmap(Bitmap: TBitmap);
begin
  Bitmap.PixelFormat := FPixelFormat;
  Bitmap.Width := Width;
  Bitmap.Height := Height;
  SetDIBColorTable(Bitmap.Canvas.Handle, 0, 256, Colors);
  Assigning := True;
  Bitmap.Canvas.Draw(0, 0, self);
  Assigning := False;
end;

procedure TwwBitmap.SetSizeInternal(const AWidth, AHeight: Integer);
begin
  if (AWidth <> Width) or (AHeight <> Height) then
    LoadBlank(AWidth, AHeight);
end;

procedure TwwBitmap.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  var APalette: HPALETTE);
begin
end;

procedure TwwBitmap.SaveToStream(Stream: TStream);
var Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  try
    SaveToBitmap(Bitmap);
    Bitmap.SaveToStream(Stream);
  finally
    Bitmap.Free;
  end;
end;

function TwwBitmap.GetMaskBitmap: TBitmap;
var Bitmap: TwwBitmap;
    TranColor: TwwColor;
begin
  if FMaskBitmap = nil then
  begin
    FMaskBitmap := TBitmap.Create;
    Bitmap := TwwBitmap.Create;
    Bitmap.Assign(self);
    TranColor := Bitmap.Pixels[0, 0];
    if TransparentColor <> clNone then TranColor := wwGetColor(TransparentColor);
    Bitmap.Mask(TranColor);
    FMaskBitmap.Assign(Bitmap);
    FMaskBitmap.Monochrome := True;
    Bitmap.Free;
  end;
  result := FMaskBitmap;
end;

function TwwBitmap.CopyPixels: PwwPLines;
begin
  GetMem(result, FHeight * SizeOf(PwwLine));
  CopyMemory(result, Pixels, FHeight * SizeOf(PwwLine));
end;

procedure TwwBitmap.Fill(Color: TColor);
var Brush: HBRUSH;
begin
  Brush := CreateSolidBrush(ColorToRGB(Color));
  try
    FillRect(FDC, Rect(0, 0, FWidth, FHeight), Brush);
  finally
    DeleteObject(Brush);
  end;
end;

procedure TwwBitmap.Resize(AWidth, AHeight: Integer);
var ABitmap: TwwBitmap;
begin
  if (AWidth = Width) and (AHeight = Height) then Exit;
  ABitmap := TwwBitmap.Create;
  try
    ABitmap.Assign(self);
    LoadBlank(AWidth, AHeight);
    Canvas.StretchDraw(Rect(0, 0, AWidth, AHeight), ABitmap);
  finally
    ABitmap.Free;
  end;
end;

procedure TwwBitmap.SmoothStretchDraw(ACanvas: TCanvas; Rect: TRect);
var x, y, xP, yP, yP2, xP2: Integer;
    Read, Read2: PwwLine;
    t, z, z2, iz2: Integer;
    pc: PwwColor;
    w1,w2,w3,w4: Integer;
    Col1,Col2:   PwwColor;
    Dst: TwwBitmap;
begin
  Dst := TwwBitmap.Create;
  Dst.LoadBlank(wwRectWidth(Rect), wwRectHeight(Rect));
  if(Dst.FWidth<1)or(Dst.FHeight<1)then Exit;
  if(Dst.FWidth=FWidth)and(Dst.FHeight=FHeight)then
  begin
    CopyMemory(Dst.FBits, FBits, FSize);
    Exit;
  end;
  xP2:=((FWidth-1)shl 15)div Dst.FWidth;
  yP2:=((FHeight-1)shl 15)div Dst.FHeight;
  yP:=0;
  for y:=0 to Dst.FHeight-1 do
  begin
    xP:=0;
    Read:=Pixels[yP shr 15];
    if yP shr 16<FHeight-1 then
      Read2:=Pixels[yP shr 15+1]
    else
      Read2:=Pixels[yP shr 15];
    pc:=@Dst.Pixels[y,0];
    z2:=yP and $7FFF;
    iz2:=$8000-z2;
    for x:=0 to Dst.FWidth-1 do
    begin
      t:=xP shr 15;
      Col1:=@Read[t];
      Col2:=@Read2[t];
      z:=xP and $7FFF;
      w2:=(z*iz2)shr 15;
      w1:=iz2-w2;
      w4:=(z*z2)shr 15;
      w3:=z2-w4;
      pc.b:=
        (Col1.b*w1+PwwColor(Integer(Col1)+3).b*w2+
         Col2.b*w3+PwwColor(Integer(Col2)+3).b*w4)shr 15;
      pc.g:=
        (Col1.g*w1+PwwColor(Integer(Col1)+3).g*w2+
         Col2.g*w3+PwwColor(Integer(Col2)+3).g*w4)shr 15;
      pc.r:=
        (Col1.r*w1+PwwColor(Integer(Col1)+3).r*w2+
         Col2.r*w3+PwwColor(Integer(Col2)+3).r*w4)shr 15;
      Inc(pc);
      Inc(xP,xP2);
    end;
    Inc(yP,yP2);
  end;
  if Transparent then Dst.TransparentDraw(ACanvas, Rect)
  else ACanvas.Draw(Rect.Left, Rect.Top, Dst);
  Dst.Free;
end;

procedure TwwBitmap.TileDraw(ACanvas: TCanvas; ARect: TRect);
var RectSize: TSize;
    i, j: Integer;
    OldPalette: HPalette;
begin
  if Empty then exit; { 4/5/99 - RSW }

  { 4/10/99 - RSW - Code changed so that tiledraw paints at least to bottom right of ARect }
  with ARect, RectSize do
  begin
    cx := Right;
    cy := Bottom;
  end;

{  with ARect, RectSize do
  begin
    cx := Right - Left;
    cy := Bottom - Top;
  end;
}
  j := 0;
  SkipPalette:= true;
  SelectBitmapPalette(ACanvas, OldPalette);

  while j < RectSize.cy do
  begin
    i := 0;
    while i < RectSize.cx do
    begin
      ACanvas.Draw(i - ARect.Left, j - ARect.Top, self);
      inc(i, FWidth);
    end;
    inc(j, FHeight);
  end;
  SkipPalette:= False;
  RestoreBitmapPalette(ACanvas, OldPalette);
end;

// Filter Methods

procedure TwwBitmap.Brightness(Amount: Integer);
var x,y: Integer;
    Table: array[0..255] of Byte;
    CurBits: PwwColor;
begin
  if Amount > 0 then
    for x:=0 to 255 do Table[x] := wwIntToByte(x + ((Amount * (x xor 255)) shr 8))
  else for x:=0 to 255 do Table[x] := wwIntToByte(x - ((Abs(Amount) * x) shr 8));

  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.Saturation(Amount: Integer);
var Grays: array[0..255] of Byte;
    Alpha: array[0..255] of Word;
    Gray: Byte;
    x, y, ag: Integer;
    CurBits: TwwColor;
    pc: PwwColor;
begin
  x:=0;
  y:=0;
  for ag := 0 to 85 do
  begin
    Grays[x + 0] := y;
    Grays[x + 1] := y;
    Grays[x + 2] := y;
    Inc(y);
    Inc(x, 3);
  end;

  for x := 0 to 255 do Alpha[x] := (x * Amount) shr 8;
  pc := Bits;
  for y := 0 to FHeight - 1 do
  begin
    for x := 0 to FWidth - 1 do
    begin
      CurBits := pc^;
      Gray := Grays[CurBits.r] + Grays[CurBits.g] + Grays[CurBits.b];
      ag := Alpha[Gray];
      pc.b := wwIntToByte(Gray + (Alpha[CurBits.b] - ag));
      pc.g := wwIntToByte(Gray + (Alpha[CurBits.g] - ag));
      pc.r := wwIntToByte(Gray + (Alpha[CurBits.r] - ag));
      Inc(pc);
    end;
    pc := Pointer(Integer(pc) + Gap);
  end;
end;

procedure TwwBitmap.ColorTint(ra, ga, ba: Integer);