lbbmputils.pas

天涯進銷存系統

unit LBBMPUtils;

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

interface

Uses Windows, Classes, Graphics, Controls,Forms;

function GetTransparentColor(B: TBitMap): TColor;
procedure DrawBitmapTransparent(Dest: TCanvas; XOrigin, YOrigin: Integer;
  Bitmap: TBitmap; TransparentColor: TColor);
procedure DrawBitmapRectTransparent(Dest: TCanvas; XOrigin, YOrigin: Integer;
  Rect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
procedure StretchBitmapRectTransparent(Dest: TCanvas; X, Y, W, H: Integer;
  Rect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBitmap;
  xStart, yStart: Integer; TransparentColor: TColorRef);

procedure PaintGlyph(Cnvs: TCanvas; xg, yg: Integer; Glyph: TBitMap;
                    Index: Byte; NumGlyphs: Byte);

function CreateRFromBmp(B: TBitmap; var RgnData: PRgnData): integer;

implementation

Uses SysUtils, Messages, Consts;

const
  TransparentMask = $02000000;

function Max(A, B: Longint): Longint;
begin
  if A > B then Result := A
  else Result := B;
end;

function Min(A, B: Longint): Longint;
begin
  if A < B then Result := A
  else Result := B;
end;

function WidthOf(R: TRect): Integer;
begin
  Result := R.Right - R.Left;
end;

function HeightOf(R: TRect): Integer;
begin
  Result := R.Bottom - R.Top;
end;


{Transparent bitmap}

function GetTransparentColor(B: TBitMap): TColor;
begin
  Result := B.Canvas.Pixels[0, B.Height - 1];
end;

procedure DrawTransparentBitmapRect(DC: HDC; Bitmap: HBitmap; xStart, yStart,
  Width, Height: Integer; Rect: TRect; TransparentColor: TColorRef);
var
  BM: Windows.TBitmap;
  cColor: TColorRef;
  bmAndBack, bmAndObject, bmAndMem, bmSave: HBitmap;
  bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBitmap;
  hdcMem, hdcBack, hdcObject, hdcTemp, hdcSave: HDC;
  ptSize, ptRealSize, ptBitSize, ptOrigin: TPoint;
begin
  hdcTemp := CreateCompatibleDC(DC);
  SelectObject(hdcTemp, Bitmap);
  GetObject(Bitmap, SizeOf(BM), @BM);
  ptRealSize.x := Min(Rect.Right - Rect.Left, BM.bmWidth - Rect.Left);
  ptRealSize.y := Min(Rect.Bottom - Rect.Top, BM.bmHeight - Rect.Top);
  DPtoLP(hdcTemp, ptRealSize, 1);
  ptOrigin.x := Rect.Left;
  ptOrigin.y := Rect.Top;
  DPtoLP(hdcTemp, ptOrigin, 1);

  ptBitSize.x := BM.bmWidth;
  ptBitSize.y := BM.bmHeight;
  DPtoLP(hdcTemp, ptBitSize, 1);
  if (ptRealSize.x = 0) or (ptRealSize.y = 0) then begin
    ptSize := ptBitSize;
    ptRealSize := ptSize;
  end
  else ptSize := ptRealSize;
  if (Width = 0) or (Height = 0) then begin
    Width := ptSize.x;
    Height := ptSize.y;
  end;

  { Create some DCs to hold temporary data }
  hdcBack   := CreateCompatibleDC(DC);
  hdcObject := CreateCompatibleDC(DC);
  hdcMem    := CreateCompatibleDC(DC);
  hdcSave   := CreateCompatibleDC(DC);
  { Create a bitmap for each DC. DCs are required for a number of }
  { GDI functions                                                 }
  { Monochrome DC }
  bmAndBack   := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
  bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);
  bmAndMem    := CreateCompatibleBitmap(DC, Max(ptSize.x, Width), Max(ptSize.y, Height));
  bmSave      := CreateCompatibleBitmap(DC, ptBitSize.x, ptBitSize.y);
  { Each DC must select a bitmap object to store pixel data }
  bmBackOld   := SelectObject(hdcBack, bmAndBack);
  bmObjectOld := SelectObject(hdcObject, bmAndObject);
  bmMemOld    := SelectObject(hdcMem, bmAndMem);
  bmSaveOld   := SelectObject(hdcSave, bmSave);
  { Set proper mapping mode }
  SetMapMode(hdcTemp, GetMapMode(DC));

  { Save the bitmap sent here, because it will be overwritten }
  BitBlt(hdcSave, 0, 0, ptBitSize.x, ptBitSize.y, hdcTemp, 0, 0, SRCCOPY);
  { Set the background color of the source DC to the color,         }
  { contained in the parts of the bitmap that should be transparent }
  cColor := SetBkColor(hdcTemp, TransparentColor);
  { Create the object mask for the bitmap by performing a BitBlt()  }
  { from the source bitmap to a monochrome bitmap                   }
  BitBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, ptOrigin.x, ptOrigin.y,
    SRCCOPY);
  { Set the background color of the source DC back to the original  }
  { color                                                           }
  SetBkColor(hdcTemp, cColor);
  { Create the inverse of the object mask }
  BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0,
    NOTSRCCOPY);
  { Copy the background of the main DC to the destination }
  BitBlt(hdcMem, 0, 0, Width, Height, DC, xStart, yStart,
    SRCCOPY);
  { Mask out the places where the bitmap will be placed }
  StretchBlt(hdcMem, 0, 0, Width, Height, hdcObject, 0, 0,
    ptSize.x, ptSize.y, SRCAND);
  {BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);}
  { Mask out the transparent colored pixels on the bitmap }
  BitBlt(hdcTemp, ptOrigin.x, ptOrigin.y, ptSize.x, ptSize.y, hdcBack, 0, 0,
    SRCAND);
  { XOR the bitmap with the background on the destination DC }
  StretchBlt(hdcMem, 0, 0, Width, Height, hdcTemp, ptOrigin.x, ptOrigin.y,
    ptSize.x, ptSize.y, SRCPAINT);
  {BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, ptOrigin.x, ptOrigin.y,
    SRCPAINT);}
  { Copy the destination to the screen }
  BitBlt(DC, xStart, yStart, Max(ptRealSize.x, Width), Max(ptRealSize.y, Height),
    hdcMem, 0, 0, SRCCOPY);
  { Place the original bitmap back into the bitmap sent here }
  BitBlt(hdcTemp, 0, 0, ptBitSize.x, ptBitSize.y, hdcSave, 0, 0, SRCCOPY);

  { Delete the memory bitmaps }
  DeleteObject(SelectObject(hdcBack, bmBackOld));
  DeleteObject(SelectObject(hdcObject, bmObjectOld));
  DeleteObject(SelectObject(hdcMem, bmMemOld));
  DeleteObject(SelectObject(hdcSave, bmSaveOld));
  { Delete the memory DCs }
  DeleteDC(hdcMem);
  DeleteDC(hdcBack);
  DeleteDC(hdcObject);
  DeleteDC(hdcSave);
  DeleteDC(hdcTemp);
end;

procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBitmap;
  xStart, yStart: Integer; TransparentColor: TColorRef);
begin
  DrawTransparentBitmapRect(DC, Bitmap, xStart, yStart, 0, 0,
    Rect(0, 0, 0, 0), TransparentColor);
end;

procedure InternalDrawTransBmpRect(Dest: TCanvas; X, Y, W, H: Integer;
  Rect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
var
  MemImage: TBitmap;
  R: TRect;
begin
  MemImage := TBitmap.Create;
  try
    R := Bounds(0, 0, Bitmap.Width, Bitmap.Height);
    if TransparentColor = clNone then begin
      if (WidthOf(Rect) <> 0) and (HeightOf(Rect) <> 0) then R := Rect;
      MemImage.Width := WidthOf(R);
      MemImage.Height := HeightOf(R);
      MemImage.Canvas.CopyRect(Bounds(0, 0, MemImage.Width, MemImage.Height),
        Bitmap.Canvas, R);
      if (W = 0) or (H = 0) then Dest.Draw(X, Y, MemImage)
      else Dest.StretchDraw(Bounds(X, Y, W, H), MemImage);
    end
    else  begin
      MemImage.Width := WidthOf(R);
      MemImage.Height := HeightOf(R);
      MemImage.Canvas.CopyRect(R, Bitmap.Canvas, R);
      if TransparentColor = clDefault then
        TransparentColor := MemImage.Canvas.Pixels[0, MemImage.Height - 1];
      DrawTransparentBitmapRect(Dest.Handle, MemImage.Handle, X, Y, W, H,
        Rect, ColorToRGB(TransparentColor and not TransparentMask));
      { TBitmap.TransparentColor property return TColor value equal   }
      { to (Bitmap.Canvas.Pixels[0, Height - 1] or TransparentMask).  }
    end;
  finally
    MemImage.Free;
  end;
end;

procedure StretchBitmapRectTransparent(Dest: TCanvas; X, Y, W, H: Integer;
  Rect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
begin
  InternalDrawTransBmpRect(Dest, X, Y, W, H, Rect, Bitmap,
    TransparentColor);
end;

procedure DrawBitmapRectTransparent(Dest: TCanvas; XOrigin, YOrigin: Integer;
  Rect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
begin
  InternalDrawTransBmpRect(Dest, XOrigin, YOrigin, 0, 0, Rect, Bitmap,
    TransparentColor);
end;

procedure DrawBitmapTransparent(Dest: TCanvas; XOrigin, YOrigin: Integer;
  Bitmap: TBitmap; TransparentColor: TColor);
begin
  InternalDrawTransBmpRect(Dest, XOrigin, YOrigin, 0, 0, Rect(0, 0, 0, 0),
    Bitmap, TransparentColor);
end;

procedure PaintGlyph (Cnvs: TCanvas; xg, yg: Integer; Glyph: TBitMap;
                     Index: Byte; NumGlyphs: Byte);
var
  Gl: TBitMap;
  R1, R2: TRect;
  W: Integer;
begin
  if Glyph.Empty then Exit;
  W := Glyph.Width div NumGlyphs;
  Gl := TBitMap.Create;
  Gl.Width := W;
  Gl.Height := Glyph.Height;
  R1 := Rect(0,0,Gl.Width,Gl.Height);
  R2 := Rect((Index - 1)*W,0,(Index - 1)* W + W,GLyph.Height);
  Gl.Canvas.CopyRect(R1,Glyph.Canvas,R2);
  DrawBitmapTransparent(Cnvs,xg,yg,Gl,GetTransparentColor(GL));
  Gl.Free;
end;


function CreateRFromBmp(B: TBitmap; var RgnData: PRgnData): integer;
const
  max = 10000;
var
  j, i, i1: integer;
  Rts: array [0..max] of TRect;
  Count: integer;
  TrC,C: TColor;
begin
  Result := 0;
  If B.Empty Then Exit;
  Count := 0;
  TRC := B.Canvas.Pixels[0, B.Height - 2];
  for j := 0 to B.Height-1 do
  begin
    i := 0;
{    i1 := 0;}
    while i < B.Width do
    begin
      C := B.Canvas.Pixels[i,j];
      If C <> TRC then
      begin
        i1 := i;
        C := B.Canvas.Pixels[i1,j];
        while C <> TRC do
        begin
          Inc(i1);
          C := B.Canvas.Pixels[i1,j];
          If i1 >= B.Width Then Break;
        end;
        Rts[Count] := Rect(i, j, i1, j+1);
        Inc(Count);
        i := i1;
        Continue;
      end;
      Inc(i);
    end;
  end;
  // Make Region data
  Result := Count*SizeOf(TRect);
  GetMem(Rgndata, SizeOf(TRgnDataHeader)+Result);
  FillChar(Rgndata^, SizeOf(TRgnDataHeader)+Result, 0);
  RgnData^.rdh.dwSize := SizeOf(TRgnDataHeader);
  RgnData^.rdh.iType := RDH_RECTANGLES;
  RgnData^.rdh.nCount := Count;
  RgnData^.rdh.nRgnSize := 0;
  RgnData^.rdh.rcBound := Rect(0, 0, B.Width, B.Height);
  // Update New Region
  Move(Rts, RgnData^.Buffer, Result);
  Result := SizeOf(TRgnDataHeader)+Count*SizeOf(TRect);
end;

end.