bmbmp.pas

地址档案管理系统

Unit BmBmp;

interface

uses
  WinTypes, WinProcs, Graphics;

{ Drawing of a bitmap on a canvas, with transparency
  (adapted from code found in the Microsoft Knowledge Base)}

procedure DrawTransparentBitmap (canvas: TCanvas; bmp: TBitmap;
                                 aRect : tRect;
                                 cTransparentColor: LongInt;
                                 Stretched : Boolean);
procedure DrawLine(Canvas: TCanvas; X1, Y1, X2, Y2: integer);
function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
                           var Rect: TRect;  Format: Word): Integer;

implementation

{ Drawing of a bitmap on a canvas, with transparency
  (adapted from code found in the Microsoft Knowledge Base)}

{****************** Draw Transparent Bitmap ***************
 ***** This function draws a bitmap with              *****
 *****  a transparent color.                          *****
 **********************************************************}
procedure DrawTransparentBitmap (canvas: TCanvas; bmp: TBitmap;
                                 aRect: tRect;
                                 cTransparentColor: LongInt;
                                 Stretched : Boolean);
var bm: WinTypes.TBitmap;
  cColor: TColorRef;
  bmAndBack, bmAndObject, bmAndMem, bmSave, oldBmp: HBITMAP;
  bmBackOld, bmObjectOld, bmMemOld, bmSaveOld, hBmp: HBITMAP;
  hdcMem, hdcBack, hdcObject, hdcTemp, hdcSave, dc: HDC;
  ptSize: WinTypes.TPoint;
  temp_bitmap: TBitmap;
begin
  temp_bitmap := TBitmap.Create;
  temp_bitmap.Assign(bmp);
  try
    dc := canvas.Handle;
    hBmp := temp_bitmap.Handle;
    hdcTemp := CreateCompatibleDC(dc);
    oldBmp := SelectObject(hdcTemp, hBmp);

    GetObject(hBmp, SizeOf(bm), @bm);
    ptSize.x := bm.bmWidth;
    ptSize.y := bm.bmHeight;

    hdcBack   := CreateCompatibleDC(dc);
    hdcObject := CreateCompatibleDC(dc);
    hdcMem    := CreateCompatibleDC(dc);
    hdcSave   := CreateCompatibleDC(dc);

    bmAndBack   := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);

    bmAndObject := CreateBitmap(ptSize.x, ptSize.y, 1, 1, nil);

    bmAndMem    := CreateCompatibleBitmap(dc, ptSize.x, ptSize.y);
    bmSave      := CreateCompatibleBitmap(dc, ptSize.x, ptSize.y);

    bmBackOld   := SelectObject(hdcBack, bmAndBack);
    bmObjectOld := SelectObject(hdcObject, bmAndObject);
    bmMemOld    := SelectObject(hdcMem, bmAndMem);
    bmSaveOld   := SelectObject(hdcSave, bmSave);

    SetMapMode(hdcTemp, GetMapMode(dc));

    BitBlt(hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);

    cColor := SetBkColor(hdcTemp, cTransparentColor);

    BitBlt(hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);

    SetBkColor(hdcTemp, cColor);

    BitBlt(hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);
    If not Stretched
      then BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y,
                   dc, aRect.Left, aRect.Top, SRCCOPY)
      else StretchBlt (hdcMem, 0, 0, ptSize.x, ptSize.y,
                       dc, aRect.Left, aRect.Top,
                       aRect.Right-aRect.Left, aRect.Bottom-aRect.Top, SRCCOPY);
    BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);
    BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);
    BitBlt(hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCPAINT);
    If not Stretched
      then BitBlt (dc, aRect.Left, aRect.Top, ptSize.x, ptSize.y,
                   hdcMem, 0, 0, SRCCOPY)
      else StretchBlt (dc, aRect.Left, aRect.Top,
                       aRect.Right-aRect.Left, aRect.Bottom-aRect.Top,
                       hdcMem, 0, 0, ptSize.x, ptSize.y, SRCCOPY);
    BitBlt(hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);

    DeleteObject(SelectObject(hdcBack, bmBackOld));
    DeleteObject(SelectObject(hdcObject, bmObjectOld));
    DeleteObject(SelectObject(hdcMem, bmMemOld));
    DeleteObject(SelectObject(hdcSave, bmSaveOld));

    SelectObject(hdcTemp, oldBmp);

    DeleteDC(hdcMem);
    DeleteDC(hdcBack);
    DeleteDC(hdcObject);
    DeleteDC(hdcSave);
    DeleteDC(hdcTemp);
    finally
      temp_bitmap.Free;
  end;
end;

{********************** Draw Line *************************
 *****  Draw a line from point X1, Y1                 *****
 *****  to point X2, Y2.                              *****
 **********************************************************}
procedure DrawLine(Canvas: TCanvas; X1, Y1, X2, Y2: integer);
begin
  Canvas.MoveTo(X1,Y1);
  Canvas.LineTo(X2,Y2);
end;

{************************ Draw Disabled Text **************
 ***** This function draws text in "disabled" style.  *****
 ***** i.e. the text is grayed .                      *****
 **********************************************************}
function DrawDisabledText (Canvas : tCanvas; Str: PChar; Count: Integer;
                           var Rect: TRect;  Format: Word): Integer;
begin
  SetBkMode(Canvas.Handle, TRANSPARENT);

  OffsetRect(Rect, 1, 1);
  Canvas.Font.color:= ClbtnHighlight;
  DrawText (Canvas.Handle, Str, Count, Rect,Format);

  Canvas.Font.Color:= ClbtnShadow;
  OffsetRect(Rect, -1, -1);
  Result := DrawText (Canvas.Handle, Str, Count, Rect, Format);
end;

end.