xppages.pas

非常好的xp界面控件

  ACanvas.Brush.Color := ATabColor;
  ACanvas.Pen.Color := FBorderColor;
  ACanvas.Rectangle (TabRect.Left, TabRect.Top, TabRect.Right-6, TabRect.Bottom);
  ACanvas.RoundRect (TabRect.Right-8, TabRect.Top, TabRect.Right, TabRect.Bottom, 6, 6);
  ACanvas.FillRect (Rect (TabRect.Right-8, TabRect.Top + 1, TabRect.Right-3, TabRect.Bottom-1));

  if AActiveTab then
  begin

    if HotTrack then
    begin
      FCanvas.Pen.Color := $2C8BE6;
      FCanvas.MoveTo (TabRect.Right-2, TabRect.Top + 2);
      FCanvas.LineTo (TabRect.Right-2, TabRect.Bottom -2);
      FCanvas.Pen.Color := $3CC7FF;
      FCanvas.MoveTo (TabRect.Right-1, TabRect.Top + 1);
      FCanvas.LineTo (TabRect.Right-1, TabRect.Bottom - 1);
    end;
  end
  else
  begin
    //Draw tab vertical right shadow line
    ACanvas.Pen.Color := MakeDarkColor (ATabColor, 20);
    ACanvas.Brush.Color := ATabColor;
    ACanvas.MoveTo (TabRect.Right-2, TabRect.Top+2);
    ACanvas.LineTo (TabRect.Right-2, TabRect.Bottom-1);

    ACanvas.Pen.Color := MakeDarkColor (ATabColor, 10);
    ACanvas.MoveTo (TabRect.Right-3, TabRect.Top+4);
    ACanvas.LineTo (TabRect.Right-3, TabRect.Bottom-2);

    //Draw tab horizontal bottom shadow line
    ACanvas.Pen.Color := MakeDarkColor (ATabColor, 20);
    ACanvas.Brush.Color := ATabColor;
    ACanvas.MoveTo (TabRect.Left+2, TabRect.Bottom-2);
    ACanvas.LineTo (TabRect.Right-2, TabRect.Bottom-2);

    ACanvas.Pen.Color := MakeDarkColor (ATabColor, 10);
    ACanvas.MoveTo (TabRect.Left + 3, TabRect.Bottom - 3);
    ACanvas.LineTo (TabRect.Right-3, TabRect.Bottom-4);
  end;


  //Draw text and image
  DrawItemInside (AIndex, ACanvas, TabRect);

end;
//============================================================================//
//=================== End tabs drawing procedures  ===========================//
//============================================================================//



procedure TxpPageControl.DrawBorder (ACanvas : TCanvas);
begin
   FCanvas.Brush.Style := BSCLEAR;
   FCanvas.Pen.Color := FBorderColor;

   FCanvas.Rectangle (FBorderRect.Left, FBorderRect.Top, FBorderRect.Right, FBorderRect.Bottom);
end;

procedure TxpPageControl.WMPaint (var Message : TWMPaint);
var
  DC : hDC;
  PS : TPaintStruct;
  ItemRect : TRect;
  I : Integer;
  Index : Integer;
begin
  if FStyle <> pcsXP then
  begin
    inherited;
    Exit;
  end;

  if Message.DC = 0 then DC := BeginPaint(Handle, PS) else DC := Message.DC;
  try
   FCanvas.Handle := DC;

   DrawBorder (FCanvas);

   if Self.PageCount > 0 then
   begin
     Index := 0;
     For I := 0 to Self.PageCount - 1 do
     begin
       if Pages [I].TabVisible then
       begin
         SendMessage (Handle, TCM_GETITEMRECT, Index, LongInt (@ItemRect));
         if (FOwnerDraw) and (Assigned (OnDrawItem)) then
         begin
           OnDrawItem (Self, I, FCanvas, ItemRect, []);
         end
         else
         begin
           Case TabPosition of
             tpTop: DrawTopTab (ItemRect, FCanvas, I, Index);
             tpBottom: DrawBottomTab (ItemRect, FCanvas, I, Index);
             tpLeft: DrawLeftTab (ItemRect, FCanvas, I, Index);
             tpRight: DrawRightTab (ItemRect, FCanvas, I, Index);
           end;
         end;
         Inc (Index);
       end;
     end;
   end;
  finally
    if Message.DC = 0 then EndPaint(Handle, PS);
  end;
end;

procedure TxpPageControl.WMSIZE (var Message : TWMSIZE);
var
  ActivePage : Integer;
begin
  inherited;
  FBorderRect := Self.BoundsRect;
  OffsetRect (FBorderRect, -FBorderRect.Left, -FBorderRect.Top);
  SendMessage (Handle, TCM_ADJUSTRECT, 0, LongInt (@FBorderRect));
  InflateRect (FBorderRect, 1, 1);
  Inc (FBorderRect.Top);
end;

procedure TxpPageControl.WMMouseMove (var Message : TWMMouseMove);
var
  HitTest : TTCHitTestInfo;
  AActiveTab : Integer;
begin
  if FStyle <> pcsXP then
  begin
    inherited;
    Exit;
  end;
  If not HotTrack then exit;

  HitTest.pt := Point (Message.XPos, Message.YPos);
  AActiveTab := SendMessage (Handle, TCM_HITTEST, 0, LongInt (@HitTest));
  if AActiveTab <> FHotTrackTab then
  begin
    if (FHotTrackTab <> SendMessage (Handle, TCM_GETCURSEL, 0, 0)) then
      DrawHotTrackTab (FHotTrackTab, False);

    FHotTrackTab := AActiveTab;

    if (FHotTrackTab <> -1) and (FHotTrackTab <> SendMessage (Handle, TCM_GETCURSEL, 0, 0)) then
      DrawHotTrackTab (FHotTrackTab, True);
  end;
end;


procedure TxpPageControl.MouseLeave (var Message : TMessage);
begin
  If HotTrack and (FHotTrackTab <> -1) and (FHotTrackTab <> SendMessage (Handle, TCM_GETCURSEL, 0, 0)) then
  begin
    DrawHotTrackTab (FHotTrackTab, False);
    FHotTrackTab := -1;
  end;
end;


procedure TxpPageControl.WMNCCalcSize (var Message : TWMNCCalcSize);
begin
  inherited;
end;

procedure TxpPageControl.CMHintShow(var Message: TMessage);
var
  Tab   : TxpTabsheet;
  ItemRect : TRect;
  HitTest : TTCHitTestInfo;
  AActiveTab : Integer;
  AWinActiveTab : Integer;
begin
  inherited;
  if TCMHintShow (Message).Result=1 then exit; // CanShow = false?

  with TCMHintShow(Message).HintInfo^ do
  begin
    if TControl(Self) <> HintControl then exit;

    HitTest.pt := Point (CursorPos.X, CursorPos.Y);
    AWinActiveTab := SendMessage (Handle, TCM_HITTEST, 0, LongInt (@HitTest));
    AActiveTab := WinIndexToPage (AWinActiveTab);
    Tab := nil;
    if (AActiveTab >= 0) and (AActiveTab < Self.PageCount) then
    begin
       Tab := (Self.Pages [AActiveTab] as TxpTabSheet);
       if not (Assigned(Tab) and (Tab.ShowTabHint) and (Tab.TabHint <> '')) then Exit;
    end
    else
      Exit;

     HintStr := GetShortHint(Tab.TabHint);
     SendMessage (Handle, TCM_GETITEMRECT, AWinActiveTab, LongInt (@ItemRect));
     CursorRect := ItemRect;
  end; //with
end;


function TxpPageControl.PageIndexToWin (AIndex : Integer) : Integer;
var
  I : Integer;
begin
  Result := -1;
  if (Self.PageCount <= 0) or (AIndex >= Self.PageCount) then Exit;
  if not Self.Pages[AIndex].TabVisible then Exit;
  For I := 0 to AIndex do
    if Self.Pages[I].TabVisible then Inc (Result);
end;


function TxpPageControl.WinIndexToPage (AIndex : Integer) : Integer;
var
  I : Integer;
begin
  Result := -1;
  if (Self.PageCount <= 0) or (AIndex >= Self.PageCount) then Exit;
  I := 0;
  Result := 0;
  While (I <= AIndex) and (Result < Self.PageCount) do
  begin
    if Self.Pages[Result].TabVisible then Inc (I);
    Inc (Result);
  end;
  Dec (Result);
end;


procedure TxpPageControl.WMSysColorChange (var Message: TMessage);
begin
  invalidate;
  inherited;
end;


procedure TxpPageControl.Loaded;
begin
  inherited;
  SendMessage (Handle, WM_SIZE, 0, 0);
end;

procedure TxpPageControl.SetBorderColor (Value : TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    Invalidate;
  end;
end;

procedure TxpPageControl.SetTabPosition (Value : TxpTabPosition);
var
  Style : LongInt;
  OldSize : LongInt;
  Size : LongInt;
begin
  if FTabPosition <> Value then
  begin
    if (FStyle in [pcsButtons, pcsFlatButtons]) and (Value <> tpTop) then
      raise Exception.Create ('Tab position incompatible with current tab style');
    FTabPosition := Value;
    RecreateWnd;
    SendMessage (Handle, WM_SIZE, 0, 0);
    if (Self.PageCount > 0) and (ActivePage <> nil) then
      ActivePage.Invalidate;
  end;
end;

procedure TxpPageControl.SetTabTextAlignment (Value : TAlignment);
begin
  if Value <> FTabTextAlignment then
  begin
    FTabTextAlignment := Value;
    Invalidate;
  end;
end;


procedure TxpPageControl.SetStyle (Value : TxpPageControlStyle);
begin
  if FStyle <> Value then
  begin
    if (Value in [pcsButtons, pcsFlatButtons]) then TabPosition := tpTop;
    FStyle := Value;
    RecreateWnd;
    SendMessage (Handle, WM_SIZE, 0, 0);
    if (Self.PageCount > 0) and (ActivePage <> nil) then
      ActivePage.Invalidate;
  end;
end;

////////////////////////////////////////////////////////////////////////////////


constructor TxpTabSheet.Create(AOwner: TComponent);
begin
  inherited;
  FColor := clWhite;
  FImageIndex := -1;
  FShowTabHint := False;
  FTabHint := '';
  FCanvas := TControlCanvas.Create;
  FBGImage := TBitmap.Create;
  FBGStyle := bgsNone;
  FGradientStartColor := clWhite;
  FGradientEndColor := clSilver;
  FGradientFillDir := fdTopToBottom;
end;

destructor TxpTabSheet.Destroy;
begin
  try FCanvas.Free;
  except
  end;

  try FBGImage.Free;
  except
  end;

  inherited;
end;

procedure TxpTabSheet.SetBGImage (AValue : TBitmap);
begin
  FBGImage.Assign (AValue);
  Invalidate;
  if (FBGImage.Empty) and (FBGStyle in [bgsTileImage, bgsStrechImage]) then
    FBGStyle := bgsNone;
end;

procedure TxpTabSheet.SetBGStyle (AValue : TxpTabBGStyle);
begin
  if FBGStyle <> AValue then
  begin
    FBGStyle := AValue;
    Invalidate;
  end;
end;

procedure TxpTabSheet.SetColor (AValue : TColor);
begin
  if FColor <> AValue then
  begin
    FColor := AValue;
    Invalidate;
    if Assigned (PageControl) then
    try
      PageControl.Invalidate;
    except
    end;
  end;
end;

procedure TxpTabSheet.SetGradientStartColor (AValue : TColor);
begin
  if FGradientStartColor <> AValue then
  begin
    FGradientStartColor := AValue;
    Invalidate;
  end;
end;

procedure TxpTabSheet.SetGradientEndColor (AValue : TColor);
begin
  if FGradientEndColor <> AValue then
  begin
    FGradientEndColor := AValue;
    Invalidate;
  end;
end;

procedure TxpTabSheet.SetGradientFillDir (AValue : TFillDirection);
begin
  if FGradientFillDir <> AValue then
  begin
    FGradientFillDir := AValue;
    Invalidate;
  end;
end;

procedure TxpTabSheet.WMPaint (var Message : TWMPaint);
begin
  Brush.Color := FColor;
  inherited;
end;

procedure TxpTabSheet.WMEraseBkgnd (var Message : TWMEraseBkgnd);
var
  DC : hDC;
  PS : TPaintStruct;
begin
  if Message.DC = 0 then DC := BeginPaint(Handle, PS) else DC := Message.DC;
  try
    FCanvas.Handle := DC;
    Brush.Color := FColor;
    case FBGStyle of
      bgsNone: begin
                 FCanvas.Brush.Color := FColor;
                 FCanvas.FillRect (ClientRect);
               end;
      bgsGradient:
               begin
                 GradientFillRect (FCanvas, ClientRect, FGradientStartColor, FGradientEndColor, FGradientFillDir, 60);
               end;
      bgsTileImage:
               if not FBGImage.Empty then
               begin
                 TileImage(FCanvas, ClientRect, FBGImage);
               end
               else
               begin
                 FCanvas.Brush.Color := FColor;
                 FCanvas.FillRect (ClientRect);
               end;
      bgsStrechImage:
               if not FBGImage.Empty then
               begin
                 FCanvas.StretchDraw (ClientRect, FBGImage);
               end
               else
               begin
                 FCanvas.Brush.Color := FColor;
                 FCanvas.FillRect (ClientRect);
               end;
    end;
  finally
    if Message.DC = 0 then EndPaint(Handle, PS);
  end;
end;



procedure TxpTabSheet.WMNCPaint (var Message : TWMNCPaint);
begin
  Brush.Color := FColor;
  inherited;
end;

procedure TxpTabSheet.SetImageIndex (AIndex : Integer);
var
  Item : TTCItem;
begin
  if AIndex < -1 then AIndex := -1;
  if (FImageIndex <> AIndex) and Assigned (PageControl) then
  begin
    FImageIndex := AIndex;
    Item.iImage := FImageIndex;
    Item.mask := TCIF_IMAGE;
    SendMessage (PageControl.Handle, TCM_SETITEM, PageIndex, LongInt (@Item));
  end;
end;


end.