xpgraphutil.pas

非常好的xp界面控件

  EndColor: TColor; Direction: TFillDirection; Colors: Byte);
var
  BRect : TRect;
begin
  case Direction of
    fdVerticalFromCenter:
      begin
        BRect := ARect;
        BRect.Bottom := BRect.Top +  HeightOf (ARect) div 2;
        GradientSimpleFillRect(Canvas, BRect, StartColor, EndColor, fdTopToBottom, Colors);
        BRect.Top := (BRect.Top + HeightOf (ARect) div 2);
        BRect.Bottom := ARect.Bottom;
        GradientSimpleFillRect(Canvas, BRect, StartColor, EndColor, fdBottomToTop, Colors);
      end;
    fdHorizFromCenter:
      begin
        BRect := ARect;
        BRect.Right := BRect.Left +  WidthOf (ARect) div 2;
        GradientSimpleFillRect(Canvas, BRect, StartColor, EndColor, fdLeftToRight, Colors);
        BRect.Left := (BRect.Left + WidthOf (ARect) div 2);
        BRect.Right := ARect.Right;
        GradientSimpleFillRect(Canvas, BRect, StartColor, EndColor, fdRightToLeft, Colors);
      end;
    fdXP:
      begin
        GradientXPFillRect (Canvas, ARect, StartColor, EndColor, Colors);
      end
    else
      GradientSimpleFillRect(Canvas, ARect, StartColor, EndColor, Direction, Colors);
  end;
end;


procedure GradientVertLine (Canvas : TCanvas; X, Y, Len : Integer; StartColor,
  EndColor: TColor; Direction: TFillDirection; Colors: Byte);
begin
  if Len < 1 then Exit;
end;


procedure TileImage(Canvas: TCanvas; Rect: TRect; Image: TGraphic);
var
  X, Y: Integer;
  SaveIndex: Integer;
begin
  if (Image.Width = 0) or (Image.Height = 0) then Exit;
  SaveIndex := SaveDC(Canvas.Handle);
  try
    with Rect do
      IntersectClipRect(Canvas.Handle, Left, Top, Right, Bottom);
    for X := 0 to (WidthOf(Rect) div Image.Width) do
      for Y := 0 to (HeightOf(Rect) div Image.Height) do
        Canvas.Draw(Rect.Left + X * Image.Width,
          Rect.Top + Y * Image.Height, Image);
  finally
    RestoreDC(Canvas.Handle, SaveIndex);
  end;
end;


function PaletteColor(Color: TColor): Longint;
begin
  Result := ColorToRGB(Color) or PaletteMask;
end;


procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
  SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; Palette: HPalette;
  TransparentColor: TColorRef);
var
  Color: TColorRef;
  bmAndBack, bmAndObject, bmAndMem, bmSave: HBitmap;
  bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBitmap;
  MemDC, BackDC, ObjectDC, SaveDC: HDC;
  palDst, palMem, palSave, palObj: HPalette;
begin
  { Create some DCs to hold temporary data }
  BackDC := CreateCompatibleDC(DstDC);
  ObjectDC := CreateCompatibleDC(DstDC);
  MemDC := CreateCompatibleDC(DstDC);
  SaveDC := CreateCompatibleDC(DstDC);
  { Create a bitmap for each DC }
  bmAndObject := CreateBitmap(SrcW, SrcH, 1, 1, nil);
  bmAndBack := CreateBitmap(SrcW, SrcH, 1, 1, nil);
  bmAndMem := CreateCompatibleBitmap(DstDC, DstW, DstH);
  bmSave := CreateCompatibleBitmap(DstDC, SrcW, SrcH);
  { Each DC must select a bitmap object to store pixel data }
  bmBackOld := SelectObject(BackDC, bmAndBack);
  bmObjectOld := SelectObject(ObjectDC, bmAndObject);
  bmMemOld := SelectObject(MemDC, bmAndMem);
  bmSaveOld := SelectObject(SaveDC, bmSave);
  { Select palette }
  palDst := 0; palMem := 0; palSave := 0; palObj := 0;
  if Palette <> 0 then begin
    palDst := SelectPalette(DstDC, Palette, True);
    RealizePalette(DstDC);
    palSave := SelectPalette(SaveDC, Palette, False);
    RealizePalette(SaveDC);
    palObj := SelectPalette(ObjectDC, Palette, False);
    RealizePalette(ObjectDC);
    palMem := SelectPalette(MemDC, Palette, True);
    RealizePalette(MemDC);
  end;
  { Set proper mapping mode }
  SetMapMode(SrcDC, GetMapMode(DstDC));
  SetMapMode(SaveDC, GetMapMode(DstDC));
  { Save the bitmap sent here }
  BitBlt(SaveDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SRCCOPY);
  { Set the background color of the source DC to the color,         }
  { contained in the parts of the bitmap that should be transparent }
  Color := SetBkColor(SaveDC, PaletteColor(TransparentColor));
  { Create the object mask for the bitmap by performing a BitBlt()  }
  { from the source bitmap to a monochrome bitmap                   }
  BitBlt(ObjectDC, 0, 0, SrcW, SrcH, SaveDC, 0, 0, SRCCOPY);
  { Set the background color of the source DC back to the original  }
  SetBkColor(SaveDC, Color);
  { Create the inverse of the object mask }
  BitBlt(BackDC, 0, 0, SrcW, SrcH, ObjectDC, 0, 0, NOTSRCCOPY);
  { Copy the background of the main DC to the destination }
  BitBlt(MemDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, SRCCOPY);
  { Mask out the places where the bitmap will be placed }
  StretchBlt(MemDC, 0, 0, DstW, DstH, ObjectDC, 0, 0, SrcW, SrcH, SRCAND);
  { Mask out the transparent colored pixels on the bitmap }
  BitBlt(SaveDC, 0, 0, SrcW, SrcH, BackDC, 0, 0, SRCAND);
  { XOR the bitmap with the background on the destination DC }
  StretchBlt(MemDC, 0, 0, DstW, DstH, SaveDC, 0, 0, SrcW, SrcH, SRCPAINT);
  { Copy the destination to the screen }
  BitBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0,
    SRCCOPY);
  { Restore palette }
  if Palette <> 0 then begin
    SelectPalette(MemDC, palMem, False);
    SelectPalette(ObjectDC, palObj, False);
    SelectPalette(SaveDC, palSave, False);
    SelectPalette(DstDC, palDst, True);
  end;
  { Delete the memory bitmaps }
  DeleteObject(SelectObject(BackDC, bmBackOld));
  DeleteObject(SelectObject(ObjectDC, bmObjectOld));
  DeleteObject(SelectObject(MemDC, bmMemOld));
  DeleteObject(SelectObject(SaveDC, bmSaveOld));
  { Delete the memory DCs }
  DeleteDC(MemDC);
  DeleteDC(BackDC);
  DeleteDC(ObjectDC);
  DeleteDC(SaveDC);
end;


procedure StretchBitmapTransparent(Dest: TCanvas; Bitmap: TBitmap;
  TransparentColor: TColor; DstX, DstY, DstW, DstH, SrcX, SrcY,
  SrcW, SrcH: Integer);
var
  CanvasChanging: TNotifyEvent;
begin
  if DstW <= 0 then DstW := Bitmap.Width;
  if DstH <= 0 then DstH := Bitmap.Height;
  if (SrcW <= 0) or (SrcH <= 0) then begin
    SrcX := 0; SrcY := 0;
    SrcW := Bitmap.Width;
    SrcH := Bitmap.Height;
  end;
  if not Bitmap.Monochrome then
    SetStretchBltMode(Dest.Handle, STRETCH_DELETESCANS);
  CanvasChanging := Bitmap.Canvas.OnChanging;
{$IFDEF VER100}
  Bitmap.Canvas.Lock;
{$ENDIF}
  try
    Bitmap.Canvas.OnChanging := nil;
    if TransparentColor = clNone then begin
      StretchBlt(Dest.Handle, DstX, DstY, DstW, DstH, Bitmap.Canvas.Handle,
        SrcX, SrcY, SrcW, SrcH, Dest.CopyMode);
    end
    else begin
{$IFDEF VER100}
      if TransparentColor = clDefault then
        TransparentColor := Bitmap.Canvas.Pixels[0, Bitmap.Height - 1];
{$ENDIF}
      if Bitmap.Monochrome then TransparentColor := clWhite
      else TransparentColor := ColorToRGB(TransparentColor);
      StretchBltTransparent(Dest.Handle, DstX, DstY, DstW, DstH,
        Bitmap.Canvas.Handle, SrcX, SrcY, SrcW, SrcH, Bitmap.Palette,
        TransparentColor);
    end;
  finally
    Bitmap.Canvas.OnChanging := CanvasChanging;
{$IFDEF VER100}
    Bitmap.Canvas.Unlock;
{$ENDIF}
  end;
end;


procedure StretchBitmapRectTransparent(Dest: TCanvas; DstX, DstY,
  DstW, DstH: Integer; SrcRect: TRect; Bitmap: TBitmap;
  TransparentColor: TColor);
begin
  with SrcRect do
    StretchBitmapTransparent(Dest, Bitmap, TransparentColor,
    DstX, DstY, DstW, DstH, Left, Top, Right - Left, Bottom - Top);
end;

procedure DrawBitmapRectTransparent(Dest: TCanvas; DstX, DstY: Integer;
  SrcRect: TRect; Bitmap: TBitmap; TransparentColor: TColor);
begin
  with SrcRect do
    StretchBitmapTransparent(Dest, Bitmap, TransparentColor,
    DstX, DstY, Right - Left, Bottom - Top, Left, Top, Right - Left,
    Bottom - Top);
end;

procedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;
  Bitmap: TBitmap; TransparentColor: TColor);
begin
  StretchBitmapTransparent(Dest, Bitmap, TransparentColor, DstX, DstY,
    Bitmap.Width, Bitmap.Height, 0, 0, Bitmap.Width, Bitmap.Height);
end;


procedure CopyBitmap (const Source : TBitmap; Dest : TBitmap);
begin
  try Dest.FreeImage;
  except
  end;

  Dest.Width := Source.Width;
  Dest.Height := Source.Height;
  Dest.PixelFormat := Source.PixelFormat;

  BitBlt (Dest.Canvas.Handle, Dest.Canvas.ClipRect.Left, Dest.Canvas.ClipRect.Top, Dest.Width, Dest.Height,
    Source.Canvas.Handle, 0, 0, SRCCOPY);
end;


function GetSysColorCount (DC : hDC) : Integer;
begin
  // 1 - monochrome
  // 4 - 16 colors
  // 8 - 256 colors
  //
  Result := GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES);
end;

procedure SmoothImage (ACanvas : TCanvas; ARect : TRect; Transparent : TColor);
var
  X, Y : Integer;
begin
  For Y := ARect.Top to ARect.Bottom do
    For X := ARect.Left to ARect.Right do
    begin
      if ACanvas.Pixels [X, Y] = Transparent then
      begin
        ACanvas.Pixels [X+1, Y+1] := MakeDarkColor (ACanvas.Pixels [X+1, Y+1], 20);
        ACanvas.Pixels [X-1, Y-1] := MakeDarkColor (ACanvas.Pixels [X-1, Y-1], 20);
        ACanvas.Pixels [X, Y+1] := MakeDarkColor (ACanvas.Pixels [X, Y+1], 20);
        ACanvas.Pixels [X+1, Y] := MakeDarkColor (ACanvas.Pixels [X+1, Y], 20);
      end;
    end;
end;

function CreateRegionFromBitmap(Bitmap: TBitmap; TransparentColor: TColor; Range : Integer) : hRgn;
var
  X, Y, FirstX : Integer;
  LastBeen     : Boolean;
  ComplexRGN   : HRgn;
  TempRGN      : HRgn;
begin
  ComplexRgn := CreateRectRgn(0, 0, 1, 1);

  For Y := 0 to Bitmap.Height - 1 do
  begin
    FirstX := 0;
    LastBeen := False;
    For X := 0 to Bitmap.Width -1 do
    begin
      if (Abs (Bitmap.Canvas.Pixels[X, Y] - TransparentColor) > Range) and
         (X <> Pred (Bitmap.Width)) then
      begin
        if not LastBeen then
        begin
          LastBeen := True;
          FirstX := X;
        end;
      end
      else
      begin
        if LastBeen then
        begin
          LastBeen := False;
          TempRGN := CreateRectRgn (FirstX, Y, X, Y + 1);
          CombineRgn (ComplexRGN, ComplexRGN, TempRGN, RGN_OR);
          DeleteObject(TempRGN);
        end;
      end;
    end;
  end;

  Result := ComplexRGN;
end;


function CreateRgnRectFromBitmap(Bitmap: TBitmap; ARect : TRect; TransparentColor: TColor; Range : Integer) : hRgn;
var
  Bmp : TBitmap;
  ResRgn : hRgn;
  OffRect : TRect;
begin
  Result := 0;
  Bmp := TBitmap.Create;
  try
    Bmp.Width := WidthOf (ARect);
    Bmp.Height := HeightOf (ARect);
    OffRect := ARect;
    OffsetRect (OffRect, - OffRect.Left, - OffRect.Top);
    Bmp.Canvas.StretchDraw (OffRect, Bitmap);

    ResRgn := CreateRegionFromBitmap (Bmp, TransparentColor, Range);
    OffsetRgn (ResRgn, ARect.Left, ARect.Top);
    Result := ResRgn;
  finally
    Bmp.Free;
  end;
end;


end.