stabcontrol.pas

Alpha Controls 界面控件包

        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;
  if SavedDC <> 0 then RestoreDC(FCommonData.FCacheBmp.Canvas.Handle, SavedDC);
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;
    if not Value then FScrollOpposite := False;
  end;
end;

procedure TsCustomTabControl.Loaded;
begin
  inherited Loaded;
  if Images <> nil then UpdateTabImages;
  SkinData.Loaded;
  if FCommonData.Skinned then RebuildTabs;
end;

procedure TsCustomTabControl.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = Images) then Images := nil;
end;

function TsCustomTabControl.PageRect: TRect;
var
  r : TRect;
begin
  Result := Rect(0, 0, Width, Height);
  if Tabs.Count > 0 then begin
    AdjustClientRect(r);
    case TabPosition of
      tpTop : Result.Top := R.Top - TopOffset;
      tpBottom : Result.Bottom := R.Bottom + BottomOffset;
      tpLeft : Result.Left := R.Left - LeftOffset;
      tpRight : Result.Right := R.Right + RightOffset;
    end;
  end;
end;

function TsCustomTabControl.RowCount: Integer;
begin
  Result := TabCtrl_GetRowCount(Handle);
end;

procedure TsCustomTabControl.ScrollTabs(Delta: Integer);
var
  Wnd: HWND;
  P: TPoint;
  Rect: TRect;
  I: Integer;
begin
  Wnd := FindWindowEx(Handle, 0, 'msctls_updown32', nil);
  if Wnd <> 0 then begin
    Windows.GetClientRect(Wnd, Rect);
    if Delta < 0 then P.X := Rect.Left + 2 else P.X := Rect.Right - 2;
    P.Y := Rect.Top + 2;
    for I := 0 to Abs(Delta) - 1 do begin
      SendMessage(Wnd, WM_LBUTTONDOWN, 0, MakeLParam(P.X, P.Y));
      SendMessage(Wnd, WM_LBUTTONUP, 0, MakeLParam(P.X, P.Y));
    end;
  end;
end;

procedure TsCustomTabControl.SetHotTrack(Value: Boolean);
begin
  if FHotTrack <> Value then begin
    FHotTrack := Value;
    RecreateWnd;
  end;
end;

procedure TsCustomTabControl.SetImages(Value: TCustomImageList);
var
  Form : TCustomForm;
begin
  if csDestroying in ComponentState then Exit;
  if Images <> nil then Images.UnRegisterChanges(FImageChangeLink);
  FImages := Value;
  if Images <> nil then begin
    Images.RegisterChanges(FImageChangeLink);
    Images.FreeNotification(Self);
    Perform(TCM_SETIMAGELIST, 0, Images.Handle);
  end
  else Perform(TCM_SETIMAGELIST, 0, 0);
  Form := GetParentForm(Self);
  if (Form <> nil) and not (csDestroying in Form.ComponentState) and not (csDestroying in Parent.ComponentState) and FCommonData.Skinned then begin
    FCommonData.Invalidate; // Changed by Serge - exception arises when projects closes in design-time
//    RecreateWnd;
  end;
end;

procedure TsCustomTabControl.SetMultiLine(Value: Boolean);
begin
  if InternalSetMultiLine(Value) then RecreateWnd;
end;

procedure TsCustomTabControl.SetMultiSelect(Value: Boolean);
begin
  if FMultiSelect <> Value then begin
    FMultiSelect := Value;
    RecreateWnd;
  end;
end;

procedure TsCustomTabControl.SetOwnerDraw(Value: Boolean);
begin
  if FOwnerDraw <> Value then begin
    FOwnerDraw := Value;
    RecreateWnd;
  end;
end;

procedure TsCustomTabControl.SetRaggedRight(Value: Boolean);
begin
  if FRaggedRight <> Value then begin
    FRaggedRight := Value;
    SetComCtlStyle(Self, TCS_RAGGEDRIGHT, Value);
  end;
end;

procedure TsCustomTabControl.SetScrollOpposite(Value: Boolean);
begin
  if FScrollOpposite <> Value then begin
    FScrollOpposite := Value;
    if Value then FMultiLine := Value;
    RecreateWnd;
  end;
end;

procedure TsCustomTabControl.SetStyle(Value: TTabStyle);
begin
  if FStyle <> Value then begin
    if (Value <> tsTabs) and (TabPosition <> tpTop) then raise EInvalidOperation.Create(SInvalidTabStyle);
    FStyle := Value;
    RecreateWnd;
  end;
end;

procedure TsCustomTabControl.SetTabHeight(Value: Smallint);
begin
  if FTabSize.Y <> Value then begin
    if Value < 0 then raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
    FTabSize.Y := Value;
    UpdateTabSize;
    SkinData.Invalidate;
  end;
end;

procedure TsCustomTabControl.SetTabIndex(Value: Integer);
var
  NewValue : integer;
begin
  if OwnCalc then NewValue := Value * integer(ActualIndex(Value) <> -1) else NewValue := Value;
  if FSavedTabIndex = NewValue then Exit;
  FSavedTabIndex := NewValue;
  if OwnCalc then begin
    if not (csLoading in ComponentState) and ((csDesigning in ComponentState) or not (csReading in ComponentState)) then begin
      RebuildTabs;
      FCommonData.BGChanged := True;
      Change;
      SendMessage(Handle, TCM_SETCURSEL, Value, 0); // maybe better to place this before Change???
      Repaint;
    end;
  end else begin
    SendMessage(Handle, TCM_SETCURSEL, Value, 0);
    Change // v4.31 Jacob
  end;
end;

procedure TsCustomTabControl.SetTabPosition(Value: TTabPosition);
begin
  if FTabPosition <> Value then begin
    if (Value <> tpTop) and (Style <> tsTabs) then raise EInvalidOperation.Create(SInvalidTabPosition);
    FTabPosition := Value;
    if not MultiLine and ((Value = tpLeft) or (Value = tpRight)) then InternalSetMultiLine(True);
    RecreateWnd;
  end;
end;

procedure TsCustomTabControl.SetTabs(Value: TStrings);
begin
  FTabs.Assign(Value);
end;

procedure TsCustomTabControl.SetTabWidth(Value: Smallint);
var
  OldValue: Smallint;
begin
  if FTabSize.X <> Value then begin
    if Value < 0 then raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
    OldValue := FTabSize.X;
    FTabSize.X := Value;
    if (OldValue = 0) or (Value = 0)
      then RecreateWnd
      else UpdateTabSize;
  end;
end;

function TsCustomTabControl.TabRect(Index: Integer): TRect;
begin
  TabCtrl_GetItemRect(Handle, Index, Result);
end;

procedure TsCustomTabControl.TabsChanged;
begin
  if csDestroying in ComponentState then Exit;
  if not FUpdating and not (csReading in ComponentState) {and not (csLoading in ComponentState)} then begin
    FillTabs;
    if HandleAllocated then SendMessage(Handle, WM_SIZE, SIZE_RESTORED, Word(Width) or Word(Height) shl 16);
    Realign;
  end;
  if MultiLine and (UpDown <> nil) then FreeAndNil(UpDown);
end;

function TsCustomTabControl.TabsRect: TRect;
var
  r : TRect;
begin
  Result := Rect(0, 0, Width, Height);
  if Tabs.Count > 0 then begin
    AdjustClientRect(r);
    case TabPosition of
      tpTop : Result.Bottom := R.Top - TopOffset;
      tpBottom : Result.Top := R.Bottom + BottomOffset;
      tpLeft : Result.Right := R.Left - LeftOffset;
      tpRight : Result.Left := R.Right + RightOffset;
    end;
  end;
end;

procedure TsCustomTabControl.UpdateTabImages;
var
  I: Integer;
  TCItem: TTCItem;
begin
  TCItem.mask := TCIF_IMAGE;
  for I := 0 to FTabs.Count - 1 do begin
    TCItem.iImage := GetImageIndex(I);
    if SendMessage(Handle, TCM_SETITEM, I, Longint(@TCItem)) = 0 then TabControlError(Format(sTabFailSet, [FTabs[I], I]));
  end;
  TabsChanged;
end;

procedure TsCustomTabControl.UpdateTabSize;
begin
  SendMessage(Handle, TCM_SETITEMSIZE, 0, Integer(FTabSize));
  if not (csReading in ComponentState) then TabsChanged;
end;

procedure TsCustomTabControl.WMDestroy(var Message: TWMDestroy);
var
  FocusHandle: HWnd;
begin