xpbarmenu.pas

xpmenu,一个可以使界面美化的控件.你可以设置成你自己所喜欢的.

    TextRect, TextFormat, nil);

end;

procedure TXPBarMenu.DrawIcon(Sender: TObject; ACanvas: TCanvas; B: TBitmap;
  IconRect: Trect; Hot, Selected, Enabled, Checked, FTopMenu,
  IsRightToLeft: boolean);
var
  DefColor          : TColor;
  X1, X2            : integer;
begin
  if B <> nil then
  begin
    X1 := IconRect.Left;
    X2 := IconRect.Top + 2;
    if Sender is TMenuItem then
    begin
      inc(X2, 2);
      if FIconWidth >= B.Width then
        X1 := X1 + ((FIconWidth - B.Width) div 2) - 1
      else
      begin
        if IsRightToLeft then
          X1 := IconRect.Right - b.Width - 2
        else
          X1 := IconRect.Left + 2;
      end;
    end;

    if (Hot) and (not FTopMenu) and (Enabled) and (not Checked) then
      if not Selected then
      begin
        dec(X1, 1);
        dec(X2, 1);
      end;

{$IFDEF WIN32} /// This Line Add By Kingron
/// Under Lines Cause some Problam in Win9x,Bitmap Transparent Bug
    if (not Hot) and (Enabled) and (not Checked) and _IsOSoK then
      if Is16Bit then
        DimBitmap(B, 30);

/// Under Two Line Cause some problam in Win9x
    if not Enabled and _IsOSoK then
        GrayBitmap(B, 70);
{$ENDIF} /// This Line Add By Kingron
    if (Hot) and (Enabled) and (not Checked) then
    begin
      if (Is16Bit) and (not UseSystemColors) and (Sender is TToolButton) then
        DefColor := NewColor(ACanvas, FSelectColor, 68)
      else
        DefColor := FFSelectColor;

      DefColor := GetShadeColor(ACanvas, DefColor, 50);
      DrawBitmapShadow(B, ACanvas, X1 + 2, X2 + 2, DefColor);
    end;

    B.Transparent := True;
    ACanvas.Draw(X1, X2, B);

  end;

end;

procedure TXPBarMenu.DrawArrow(ACanvas: TCanvas; X, Y: integer);
begin
  ACanvas.MoveTo(X, Y);
  ACanvas.LineTo(X + 4, Y);

  ACanvas.MoveTo(X + 1, Y + 1);
  ACanvas.LineTo(X + 4, Y);

  ACanvas.MoveTo(X + 2, Y + 2);
  ACanvas.LineTo(X + 3, Y);

end;

function TXPBarMenu.TopMenuFontColor(ACanvas: TCanvas; Color: TColor): TColor;
var
  r, g, b, avg      : integer;
begin

  Color := ColorToRGB(Color);
  r := Color and $000000FF;
  g := (Color and $0000FF00) shr 8;
  b := (Color and $00FF0000) shr 16;

  Avg := (r + b) div 2;

  if (Avg > 150) or (g > 200) then
    Result := FFont.Color
  else
    Result := NewColor(ACanvas, Color, 90);
   // Result := FColor;
end;

procedure TXPBarMenu.SetActive(const Value: boolean);
begin

  FActive := Value;

  if FActive then
  begin
    InitMenueItems(FForm, false);
    InitMenueItems(FForm, true);
  end
  else
    InitMenueItems(FForm, false);

  if FForm <> nil then
    Windows.DrawMenuBar(FForm.Handle);
end;

procedure TXPBarMenu.SetForm(const Value: TForm);
var
  Hold              : boolean;
begin
  if Value <> FForm then
  begin
    Hold := Active;
    Active := false;
    FForm := Value;
    if Hold then
      Active := True;
  end;
end;

procedure TXPBarMenu.SetFont(const Value: TFont);
begin
  FFont.Assign(Value);
  DrawMenuBar(FForm.Handle);
end;

procedure TXPBarMenu.SetMenuBarColor(const Value: TColor);
begin
  FMenuBarColor := Value;
  Windows.DrawMenuBar(FForm.Handle);
end;

procedure TXPBarMenu.SetOverrideOwnerDraw(const Value: boolean);
begin
  FOverrideOwnerDraw := Value;
  if FActive then
    Active := True;
end;

procedure TXPBarMenu.SetUseSystemColors(const Value: boolean);
begin
  FUseSystemColors := Value;
  Windows.DrawMenuBar(FForm.Handle);
end;

procedure GetSystemMenuFont(Font: TFont);
var
  FNonCLientMetrics : TNonCLientMetrics;
  FFont:TFont;
begin
  FFont:=TFont.Create;
  FNonCLientMetrics.cbSize := Sizeof(TNonCLientMetrics);
  if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @FNonCLientMetrics, 0) then
  begin
    FFont.Handle := CreateFontIndirect(FNonCLientMetrics.lfMenuFont);
    FFont.Color := clMenuText;
    if FFont.Name = 'MS Sans Serif' then
      FFont.Name := 'Tahoma';
  end;
  Font.Assign(FFont);
  FFont.Free;
end;

procedure TXPBarMenu.DrawGradient(ACanvas: TCanvas; ARect: TRect;
  IsRightToLeft: boolean);
var
  i                 : integer;
  v                 : integer;
  BRect             : TRect;
  B                 : TBitmap;
begin
  /// The modify by Kingron,Use Double Buffer to improce the Draw Speed
  B:=TBitmap.Create;
  V := 0;
  B.Height :=ARect.Bottom - ARect.Top;
  B.Width := ARect.Right - ARect.Left;
  BRect := Rect(0,0,B.Width -1 ,B.Height -1);
  if IsRightToLeft then
  begin
    BRect.Left := BRect.Right -1 ;
    for i := ARect.Right downto ARect.Left do
    begin
      if (BRect.Left < ARect.Right)
        and (BRect.Left > ARect.Right - FIconWidth + 5) then
        inc(v, 3)
      else
        inc(v, 1);

      if v > 96 then v := 96;
      B.Canvas.Brush.Color := NewColor(B.Canvas, FFIconBackColor, v);
      B.Canvas.FillRect(BRect);

      Dec(BRect.Left);
      BRect.Right := BRect.Left - 1;
    end;
    ACanvas.CopyRect(ARect,B.Canvas,Rect(0,0,B.Width -1 ,B.Height -1));
  end
  else
  begin
    BRect.Right := BRect.Left +1;
    for i := ARect.Left to ARect.Right do
    begin
      if (BRect.Left > ARect.Left)
        and (BRect.Left < ARect.Left + FIconWidth + 5) then
        inc(v, 3)
      else
        inc(v, 1);

      if v > 96 then v := 96;
      B.Canvas.Brush.Color := NewColor(B.Canvas, FFIconBackColor, v);
      B.Canvas.FillRect(BRect);

      Inc(BRect.Left);
      BRect.Right := BRect.Left + 1;
    end;
    ACanvas.CopyRect(ARect,B.Canvas,Rect(0,0,B.Width -1 ,B.Height -1));
  end;
  B.Free;

end;

procedure TXPBarMenu.DrawWindowBorder(hWnd: HWND; IsRightToLeft: boolean);
var
  WRect, CRect      : TRect;
  dCanvas           : TCanvas;
begin

  if hWnd <= 0 then exit;
  dCanvas := nil;
  try
    dCanvas := TCanvas.Create;
    dCanvas.Handle := GetDc(0);

    GetClientRect(hWnd, CRect);
    GetWindowRect(hWnd, WRect);

    ExcludeClipRect(dCanvas.Handle, CRect.Left, CRect.Top, CRect.Right,
      CRect.Bottom);

    dCanvas.Brush.Style := bsClear;

    Dec(WRect.Right, 2);
    Dec(WRect.Bottom, 2);

    dCanvas.Pen.Color := FMenuBorderColor;
    dCanvas.Rectangle(WRect.Left, WRect.Top, WRect.Right, WRect.Bottom);

    if IsRightToLeft then
    begin
      dCanvas.Pen.Color := FFColor;
      dCanvas.Rectangle(WRect.Left + 1, WRect.Top + 1, WRect.Right - 2,
        WRect.Top + 3);

      dCanvas.MoveTo(WRect.Left + 2, WRect.Top + 2);
      dCanvas.LineTo(WRect.Left + 2, WRect.Bottom - 2);

      dCanvas.Pen.Color := FFIconBackColor;
      dCanvas.MoveTo(WRect.Right - 2, WRect.Top + 2);
      dCanvas.LineTo(WRect.Right - 2, WRect.Bottom - 2);

      dCanvas.MoveTo(WRect.Right - 2, WRect.Top + 2);
      dCanvas.LineTo(WRect.Right - 1 - FIconWidth, WRect.Top + 2);
    end
    else
    begin
      if not FGradient then
      begin
        dCanvas.Pen.Color := FFColor;
        dCanvas.Rectangle(WRect.Left + 1, WRect.Top + 1, WRect.Right - 2,
          WRect.Top + 3);

        dCanvas.Pen.Color := FFIconBackColor;
        dCanvas.MoveTo(WRect.Left + 1, WRect.Top + 2);
        dCanvas.LineTo(WRect.Left + 2 + FIconWidth, WRect.Top + 2);
      end;

      dCanvas.Pen.Color := FFIconBackColor;
      dCanvas.MoveTo(WRect.Left + 1, WRect.Top + 1);
      dCanvas.LineTo(WRect.Left + 1, WRect.Bottom - 2);

    end;

    Inc(WRect.Right, 2);
    Inc(WRect.Bottom, 2);

    dCanvas.Pen.Color := FMenuShadowColor;
    dCanvas.Rectangle(WRect.Left + 2, WRect.Bottom, WRect.Right, WRect.Bottom - 2);
    dCanvas.Rectangle(WRect.Right - 2, WRect.Bottom, WRect.Right, WRect.Top + 2);

    dCanvas.Pen.Color := FFIconBackColor;
    dCanvas.Rectangle(WRect.Left, WRect.Bottom - 2, WRect.Left + 2, WRect.Bottom);
    dCanvas.Rectangle(WRect.Right - 2, WRect.Top, WRect.Right, WRect.Top + 2);
  finally
    IntersectClipRect(dCanvas.Handle, WRect.Left, WRect.Top, WRect.Right, WRect.Bottom);
    /// Under Line Add By Kingron ,to Fix Memory Hole Bug!!!!!
    ReleaseDC(0,dCanvas.Handle);
    dCanvas.Free;
  end;

end;

procedure TXPBarMenu.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if not FAutoDetect then exit;
  if (Operation = opInsert) and
    ((AComponent is TMenuItem) or (AComponent is TToolButton)) then
  begin
    if (csDesigning in ComponentState) then
      Active := true
    else
     //if ComponentState = [] then
      Active := true;
  end;

end;

function GetShadeColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
var
  r, g, b           : integer;

begin
  clr := ColorToRGB(clr);
  r := Clr and $000000FF;
  g := (Clr and $0000FF00) shr 8;
  b := (Clr and $00FF0000) shr 16;

  r := (r - value);
  if r < 0 then r := 0;
  if r > 255 then r := 255;

  g := (g - value) + 2;
  if g < 0 then g := 0;
  if g > 255 then g := 255;

  b := (b - value);
  if b < 0 then b := 0;
  if b > 255 then b := 255;

  Result := Windows.GetNearestColor(ACanvas.Handle, RGB(r, g, b));
end;

function NewColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
var
  r, g, b           : integer;

begin
  if Value > 100 then Value := 100;
  clr := ColorToRGB(clr);
  r := Clr and $000000FF;
  g := (Clr and $0000FF00) shr 8;
  b := (Clr and $00FF0000) shr 16;

  r := r + Round((255 - r) * (value / 100));
  g := g + Round((255 - g) * (value / 100));
  b := b + Round((255 - b) * (value / 100));

  Result := Windows.GetNearestColor(ACanvas.Handle, RGB(r, g, b));
end;

function GrayColor(ACanvas: TCanvas; clr: TColor; Value: integer): TColor;
var
  r, g, b, avg      : integer;

begin
  if Value > 100 then Value := 100;
  clr := ColorToRGB(clr);
  r := Clr and $000000FF;
  g := (Clr and $0000FF00) shr 8;
  b := (Clr and $00FF0000) shr 16;

  Avg := (r + g + b) div 3;
  Avg := Avg + Value;

  if Avg > 240 then Avg := 240;

  Result := Windows.GetNearestColor(ACanvas.Handle, RGB(Avg, avg, avg));
end;

procedure GrayBitmap(ABitmap: TBitmap; Value: integer);
var
  x, y              : integer;
  LastColor1, LastColor2, Color: TColor;
begin
  LastColor1 := 0;
  LastColor2 := 0;

  for y := 0 to ABitmap.Height do
    for x := 0 to ABitmap.Width do
    begin
      Color := ABitmap.Canvas.Pixels[x, y];
      if Color = LastColor1 then
        ABitmap.Canvas.Pixels[x, y] := LastColor2
      else
      begin
        LastColor2 := GrayColor(ABitmap.Canvas, Color, Value);
        ABitmap.Canvas.Pixels[x, y] := LastColor2;
        LastColor1 := Color;
      end;
    end;
end;

procedure DimBitmap(ABitmap: TBitmap; Value: integer);
var
  x, y              : integer;
  LastColor1, LastColor2, Color: TColor;
begin
  if Value > 100 then Value := 100;
  LastColor1 := -1;
  LastColor2 := -1;

  for y := 0 to ABitmap.Height - 1 do
    for x := 0 to ABitmap.Width - 1 do
    begin
      Color := ABitmap.Canvas.Pixels[x, y];
      if Color = LastColor1 then
        ABitmap.Canvas.Pixels[x, y] := LastColor2
      else
      begin
        LastColor2 := NewColor(ABitmap.Canvas, Color, Value);
        ABitmap.Canvas.Pixels[x, y] := LastColor2;
        LastColor1 := Color;
      end;
    end;
end;

procedure DrawBitmapShadow(B: TBitmap; ACanvas: TCanvas; X, Y: integer;
  ShadowColor: TColor);
var
  BX, BY            : integer;
  TransparentColor  : TColor;
begin
  TransparentColor := B.Canvas.Pixels[0, B.Height - 1];
  for BY