stabcontrol.pas

AlphaControls是一个Delphi标准控件的集合

    if IsAccel(Message.CharCode, FTabs[I]) and CanShowTab(I) and CanFocus then begin
      Message.Result := 1;
      if CanChange then begin
        TabIndex := I;
        Change;
      end;
      Exit;
    end;
  end;
  inherited;
end;

procedure TsCustomTabControl.CMFontChanged(var Message);
begin
  inherited;
  if HandleAllocated then Perform(WM_SIZE, 0, 0);
end;

procedure TsCustomTabControl.CMSysColorChange(var Message: TMessage);
begin
  inherited;
  if not (csLoading in ComponentState) then begin
    Message.Msg := WM_SYSCOLORCHANGE;
    DefaultHandler(Message);
  end;
end;

procedure TsCustomTabControl.CMTabStopChanged(var Message: TMessage);
begin
  if not (csDesigning in ComponentState) then RecreateWnd;
end;

procedure TsCustomTabControl.CNDrawItem(var Message: TWMDrawItem);
var
  SaveIndex: Integer;
begin
  with Message.DrawItemStruct^ do begin
    SaveIndex := SaveDC(hDC);
    FCanvas.Lock;
    try
      FCanvas.Handle := hDC;
      FCanvas.Font := Font;
      FCanvas.Brush := Brush;
      DrawTab(itemID, rcItem, itemState and ODS_SELECTED <> 0);
    finally
      FCanvas.Handle := 0;
      FCanvas.Unlock;
      RestoreDC(hDC, SaveIndex);
    end;
  end;
  Message.Result := 1;
end;

procedure TsCustomTabControl.CNNotify(var Message: TWMNotify);
begin
  with Message do
    case NMHdr^.code of
      TCN_SELCHANGE: begin
        Change;
      end;
      TCN_SELCHANGING: begin
        if OwnCalc
          then Result := 1
          else if CanChange then Result := 0;
      end;
    end;
end;

constructor TsCustomTabControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCommonData := TsCommonData.Create(Self, True);
  FCommonData.COC := COC_TsTabControl;

  Width := 289;
  Height := 100;
  TabStop := True;
  ControlStyle := [csAcceptsControls, csDoubleClicks];
  FTabs := TsTabStrings.Create;
  TsTabStrings(FTabs).FTabControl := Self;
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
//  FTabs.BeginUpdate;
end;

procedure TsCustomTabControl.CreateParams(var Params: TCreateParams);
const
  AlignStyles: array[Boolean, TTabPosition] of DWORD =((0, TCS_BOTTOM, TCS_VERTICAL, TCS_VERTICAL or TCS_RIGHT),
                                                        (0, TCS_BOTTOM, TCS_VERTICAL or TCS_RIGHT, TCS_VERTICAL));
  TabStyles: array[TTabStyle] of DWORD = (TCS_TABS, TCS_BUTTONS, TCS_BUTTONS or TCS_FLATBUTTONS);
  RRStyles: array[Boolean] of DWORD = (0, TCS_RAGGEDRIGHT);
begin
  InitCommonControl(ICC_TAB_CLASSES);
  inherited CreateParams(Params);
  CreateSubClass(Params, WC_TABCONTROL);
  with Params do begin
    Style := Style or WS_CLIPCHILDREN or AlignStyles[UseRightToLeftAlignment, FTabPosition] or TabStyles[FStyle] or RRStyles[FRaggedRight];
    if not TabStop then Style := Style or TCS_FOCUSNEVER;
    if FMultiLine then Style := Style or TCS_MULTILINE;
    if FMultiSelect then Style := Style or TCS_MULTISELECT;
    if FOwnerDraw then Style := Style or TCS_OWNERDRAWFIXED;
    if FTabSize.X <> 0 then Style := Style or TCS_FIXEDWIDTH;
    if FHotTrack and (not (csDesigning in ComponentState)) then Style := Style or TCS_HOTTRACK;
    if FScrollOpposite then Style := Style or TCS_SCROLLOPPOSITE;
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or CS_DBLCLKS;
  end;
end;

procedure TsCustomTabControl.CreateWnd;
begin
  inherited CreateWnd;
  if (Images <> nil) and Images.HandleAllocated then Perform(TCM_SETIMAGELIST, 0, Images.Handle);
  if Integer(FTabSize) <> 0 then UpdateTabSize;

  if FSaveTabs <> nil then begin
    FTabs.Assign(FSaveTabs);
    SetTabIndex(FSaveTabIndex);
    FSaveTabs.Free;
    FSaveTabs := nil;
  end;
end;

destructor TsCustomTabControl.Destroy;
begin
  FreeAndNil(FCanvas);
  FreeAndNil(FTabs);
  FreeAndNil(FSaveTabs);
  FreeAndNil(FImageChangeLink);
  if Assigned(FCommonData) then FreeAndNil(FCommonData);
  inherited Destroy;
end;

procedure TsCustomTabControl.DrawTab(TabIndex: Integer; const Rect: TRect; Active: Boolean);
begin
  if Assigned(FOnDrawTab)
    then FOnDrawTab(Self, TabIndex, Rect, Active)
    else FCanvas.FillRect(Rect);
end;

procedure TsCustomTabControl.DrawSkinTabs(CI: TCacheInfo);
var
  i : integer;
  aRect: TRect;
  l : integer;
begin
  if csDestroying in ComponentState then Exit;

  aRect := TabsRect;
  if not ci.Ready then begin
    inc(aRect.Bottom, 4);
    FCommonData.FCacheBmp.Canvas.Brush.Style := bsSolid;
    FCommonData.FCacheBmp.Canvas.Brush.Color := ColorToRGB(TsHackedControl(Parent).Color);
    FCommonData.FCacheBmp.Canvas.FillRect(aRect);
  end
  else begin
    BitBlt(FCommonData.FCacheBmp.Canvas.Handle, aRect.Left, aRect.Top, aRect.Right, aRect.Bottom, ci.Bmp.Canvas.Handle, ci.X + Left + aRect.Left, ci.Y + Top + aRect.Top, SRCCOPY);
  end;
  // Paint tabs
  l := Length(TabsArray) - 1;
  if MultiLine then begin
    for i := 0 to l do begin
      if CanShowTab(i) and (i <> ActiveTabIndex) then DrawSkinTab(i, 0);
    end;
  end
  else for i := 0 to l do begin
    if CanShowTab(i) and (i <> ActiveTabIndex) then DrawSkinTab(i, 0);
  end;
end;

procedure TsCustomTabControl.DrawSkinTab(Index: Integer; State: integer);
var
  rText, aRect{, rParent} : TRect;
  ActiveTabBorder, InActiveTabBorder : integer;
//  TabPlus : integer;
  VertFont : TLogFont;
  pFont : PLogFontA;
  i, h, w : integer;
  procedure MakeVertFont(Orient : integer);
  begin
    pFont := @VertFont;
    GetObject(FCommonData.FCacheBmp.Canvas.Handle, SizeOf(TLogFont), pFont);
    VertFont.lfEscapement := Orient;
    VertFont.lfHeight := Font.Height;
    VertFont.lfStrikeOut := integer(fsStrikeOut in Font.Style);
    VertFont.lfItalic := integer(fsItalic in Font.Style);
    VertFont.lfUnderline := integer(fsUnderline	in Font.Style);
    VertFont.lfWeight := 1 + integer(fsBold in Font.Style);
    VertFont.lfCharSet := Font.Charset;

    VertFont.lfWidth := 0;
    VertFont.lfOrientation := VertFont.lfEscapement;
    VertFont.lfPitchAndFamily := Default_Pitch;
    VertFont.lfQuality := Default_Quality;
    VertFont.lfFaceName := '';

    FCommonData.FCacheBmp.Canvas.Font.Handle := CreateFontIndirect(VertFont);
    FCommonData.FCacheBmp.Canvas.Font.Color := Font.Color;
  end;
  procedure KillVertFont;
  begin
    FCommonData.FCacheBmp.Canvas.Font.Assign(Font);
  end;
begin
  if Index = - 1 then Exit;
  aRect := SkinTabRect(Index);
  rText := aRect;

  ActiveTabBorder := GetMaskIndex(FCommonData.SkinIndex, ChangedSkinSection, ActiveTab);
  InActiveTabBorder := GetMaskIndex(FCommonData.SkinIndex, ChangedSkinSection, InActiveTab);

  if State = 1 then begin
    if IsValidImgIndex(ActiveTabBorder) then begin
      if (aRect.Left < 0) then Exit;
      if aRect.Right > Width then aRect.Right := Width - 1;
      if IsValidImgIndex(ActiveTabBorder) then DrawMaskRect(FCommonData.FCacheBmp, ma[ActiveTabBorder].Bmp, 0, aRect, ma[ActiveTabBorder].TransparentColor, True, EmptyCI);
    end;
  end
  else begin
    if IsValidImgIndex(InactiveTabBorder) then begin
      DrawMaskRect(FCommonData.FCacheBmp, ma[InactiveTabBorder].Bmp, 0, aRect, ma[InactiveTabBorder].TransparentColor, True, EmptyCI);
    end;
  end;

  if not OwnerDraw then begin
    // Drawing of the tab content
    case TabPosition of
      tpTop, tpBottom : begin
        FCommonData.FCacheBmp.Canvas.Font.Assign(Font);
        if (Images <> nil) and (TabsArray[Index].ImageIndex <= Images.Count - 1) then begin
          Images.Draw(FCommonData.FCacheBmp.Canvas,
                rText.Left + (WidthOf(rText) - (FCommonData.FCacheBmp.Canvas.TextWidth(TabsArray[Index].Caption) + Images.Width + 8)) div 2,
                rText.Top + (HeightOf(rText) - Images.Height) div 2,
                TabsArray[Index].ImageIndex,
                True);
          inc(rText.Left, WidthOf(GlyphRect));
          WriteTextEx(FCommonData.FCacheBmp.Canvas, PChar(TabsArray[Index].Caption),
                      Enabled, rText, DT_CENTER or ta_CENTER, FCommonData.SkinIndex, State <> 0);
        end
        else WriteTextEx(FCommonData.FCacheBmp.Canvas, PChar(TabsArray[Index].Caption), True, rText, DT_CENTER or ta_CENTER, FCommonData.SkinIndex, State <> 0);
        if Focused and (Index = ActiveTabIndex) then begin
          InflateRect(rText, 1, 0);
          FocusRect(FCommonData.FCacheBmp.Canvas, rText);
        end;
      end;
      tpLeft : begin

        FCommonData.FCacheBmp.Canvas.Brush.Style := bsClear;
        MakeVertFont(900);

        h := FCommonData.FCacheBmp.Canvas.TextWidth(TabsArray[Index].Caption);
        w := FCommonData.FCacheBmp.Canvas.TextHeight(TabsArray[Index].Caption);

        if not Enabled then FCommonData.FCacheBmp.Canvas.Font.Color := clGray;
        if (Images <> nil) and (TabsArray[Index].ImageIndex > -1) and (TabsArray[Index].ImageIndex <= Images.Count - 1) then begin
          if Index = ActiveTabIndex then OffsetRect(rText, 2, 0);
          i := rText.Bottom - (HeightOf(rText) - (Images.Height + 4 + h)) div 2 - Images.Height;
          Images.Draw(FCommonData.FCacheBmp.Canvas,
                rText.Left + (WidthOf(rText) - Images.Width) div 2,
                i,
                TabsArray[Index].ImageIndex,
                Enabled);

          FCommonData.FCacheBmp.Canvas.Brush.Style := bsClear;
          FCommonData.FCacheBmp.Canvas.TextRect(rText,
                              rText.Left + (WidthOf(rText) - w) div 2,
                              i - 4,
                              PChar(TabsArray[Index].Caption));
          InflateRect(rText, (w - WidthOf(rText)) div 2, (h - HeightOf(rText)) div 2 + 2);
          OffsetRect(rText, 0, - (4 + Images.Height) div 2);
        end
        else begin
          FCommonData.FCacheBmp.Canvas.Brush.Style := bsClear;
          FCommonData.FCacheBmp.Canvas.TextRect(rText,
                              rText.Left + (WidthOf(rText) - w) div 2,
                              rText.Bottom - (HeightOf(rText) - h) div 2,
                              PChar(TabsArray[Index].Caption));
          InflateRect(rText, (w - WidthOf(rText)) div 2, (h - HeightOf(rText)) div 2);
        end;
        KillVertFont;
        if Focused and (Index = ActiveTabIndex) then begin
          FocusRect(FCommonData.FCacheBmp.Canvas, rText);
        end;
      end;
      tpRight : begin
        FCommonData.FCacheBmp.Canvas.Brush.Style := bsClear;
        MakeVertFont(-900);

        OffsetRect(rText, -2, -1);

        h := FCommonData.FCacheBmp.Canvas.TextWidth(TabsArray[Index].Caption);
        w := FCommonData.FCacheBmp.Canvas.TextHeight(TabsArray[Index].Caption);
        if not Enabled then FCommonData.FCacheBmp.Canvas.Font.Color := clGray;
        if (Images <> nil) and (TabsArray[Index].ImageIndex > -1) and (TabsArray[Index].ImageIndex <= Images.Count - 1) then begin
          if Index = ActiveTabIndex then OffsetRect(rText, 2, 0);
          i := rText.Top + (HeightOf(rText) - (Images.Height + 4 + h)) div 2;//  Images.Height;
          Images.Draw(FCommonData.FCacheBmp.Canvas,
                rText.Left + (WidthOf(rText) - Images.Width) div 2,
                i,
                TabsArray[Index].ImageIndex,
                Enabled);

          FCommonData.FCacheBmp.Canvas.Brush.Style := bsClear;
          FCommonData.FCacheBmp.Canvas.TextRect(rText,
                              rText.Left + (WidthOf(rText) - w) div 2 + FCommonData.FCacheBmp.Canvas.TextHeight(TabsArray[Index].Caption),
                              i + 4 + Images.Height,
                              PChar(TabsArray[Index].Caption));
          InflateRect(rText, (w - WidthOf(rText)) div 2, (h - HeightOf(rText)) div 2 + 2);
          OffsetRect(rText, 0, + (4 + Images.Height) div 2);
        end
        else begin
          FCommonData.FCacheBmp.Canvas.Brush.Style := bsClear;
          FCommonData.FCacheBmp.Canvas.TextRect(rText,
                              rText.Left + (WidthOf(rText) - w) div 2 + FCommonData.FCacheBmp.Canvas.TextHeight(TabsArray[Index].Caption),
                              rText.Top + (HeightOf(rText) - h) div 2,
                              PChar(TabsArray[Index].Caption));
          InflateRect(rText, (w - WidthOf(rText)) div 2, (h - HeightOf(rText)) div 2 + 2);
        end;
        KillVertFont;
        if Focused and (Index = ActiveTabIndex) then begin
          FocusRect(FCommonData.FCacheBmp.Canvas, rText);
        end;
      end;
    end;
  end
  else begin
    if Assigned(FOnDrawTab) then FOnDrawTab(Self, Index, aRect, State <> 0);
  end;                           
end;

function TsCustomTabControl.GetDisplayRect: TRect;
begin
  Result := ClientRect;
  SendMessage(Handle, TCM_ADJUSTRECT, 0, Integer(@Result));
  Inc(Result.Top, 2);
end;

function TsCustomTabControl.GetHitTestInfoAt(X, Y: Integer): THitTests;
var
  HitTest: TTCHitTestInfo;
begin
  Result := [];
  if PtInRect(ClientRect, Point(X, Y)) then with HitTest do begin
    pt.X := X;
    pt.Y := Y;
    if TabCtrl_HitTest(Handle, @HitTest) <> -1 then begin
      if (flags and TCHT_NOWHERE) <> 0 then Include(Result, htNowhere);
      if (flags and TCHT_ONITEM) = TCHT_ONITEM then Include(Result, htOnItem)
      else begin
        if (flags and TCHT_ONITEM) <> 0 then Include(Result, htOnItem);
        if (flags and TCHT_ONITEMICON) <> 0 then Include(Result, htOnIcon);
        if (flags and TCHT_ONITEMLABEL) <> 0 then Include(Result, htOnLabel);
      end;
    end
    else Result := [htNowhere];
  end;
end;

function TsCustomTabControl.GetImageIndex(TabIndex: Integer): Integer;
begin
  Result := TabIndex;
  if Assigned(FOnGetImageIndex) then FOnGetImageIndex(Self, TabIndex, Result);
end;

function TsCustomTabControl.GetTabIndex: Integer;
begin
  if OwnCalc then begin
    if Tabs.Count = 0 then begin
      Result := 0;
    end
    else Result := FSavedTabIndex;
  end
  else Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0);
end;

procedure TsCustomTabControl.ImageListChange(Sender: TObject);
begin
  Perform(TCM_SETIMAGELIST, 0, TCustomImageList(Sender).Handle);
end;

function TsCustomTabControl.IndexOfTabAt(X, Y: Integer): Integer;
var
  HitTest: TTCHitTestInfo;
begin
  Result := -1;
  if PtInRect(ClientRect, Point(X, Y)) then with HitTest do begin
    pt.X := X;
    pt.Y := Y;
    Result := TabCtrl_HitTest(Handle, @HitTest);
  end;
end;

function TsCustomTabControl.InternalSetMultiLine(Value: Boolean): Boolean;
begin
  Result := FMultiLine <> Value;
  if Result then begin
    if not Value and ((TabPosition = tpLeft) or (TabPosition = tpRight)) then TabControlError(sTabMustBeMultiLine);
    FMultiLine := Value;