outlookbar.pas

企业ERP管理系统

  if Index = 0 then
    if Assigned(Parent) then Result := Parent else Result := nil else
    begin
      Result := GetParentList[Index - 1];
      while Result.Count > 0 do Result := Result[Result.Count - 1];
    end;
end;

function TOutlookBarItem.GetPrevVisible: TOutlookBarItem;
begin
  Result := GetPrev;
  while Assigned(Result) and (not Result.CanVisible) do Result := Result.GetPrev;
end;

function TOutlookBarItem.GetNext: TOutlookBarItem;
var
  p: TOutlookBarItem;
begin
  if Count > 0 then Result := Items[0] else
    if Index = GetParentList.Count - 1 then
    begin
      Result := nil;
      p := Self;
      while (Result = nil) and (p <> nil) do
      begin
        p := p.Parent;
        if Assigned(p) then Result := p.GetNextSibling;
      end;
    end
    else
      Result := GetParentList[Index + 1];
end;

function TOutlookBarItem.GetNextSibling: TOutlookBarItem;
begin
  if index = GetParentList.Count - 1 then
    Result := nil else Result := GetParentList[Index + 1];
end;

function TOutlookBarItem.GetNextVisible: TOutlookBarItem;
begin
  Result := GetNext;
  while Assigned(Result) and (not Result.CanVisible) do Result := Result.GetNext;
end;

{TOutlookBarItems}
constructor TOutlookBarItems.Create(AOwner: TOutlookBarPage);
begin
  inherited Create;
  FOwner := AOwner;
  FItems := TList.Create;
end;

destructor TOutlookBarItems.Destroy;
begin
  Clear;
  FItems.Free;
  inherited Destroy;
end;

function TOutlookBarItems.GetCount:Integer;
begin
  Result := FItems.Count;
end;

function TOutlookBarItems.GetItem(Index: Integer): TOutlookBarItem;
begin
  Result := FItems[Index];
end;

procedure TOutlookBarItems.SetItem(Index: Integer; Value: TOutlookBarItem);
begin
  Items[Index].Assign(Value);
end;

function TOutlookBarItems.GetPage: TOutlookBarPage;
begin
  Result := FOwner;
end;

procedure TOutlookBarItems.Assign(Source: TPersistent);
var
  I: Integer;
begin
  if Source is TOutlookBarItems then
  begin
    Clear;
    for I := 0 to TOutlookBarItems(Source).Count - 1 do
      Insert(nil, -1).Assign(TOutlookBarItems(Source)[I]);
    Exit;
  end;
  if Source is TOutlookBarItem then
  begin
    Clear;
    for I := 0 to TOutlookBarItem(Source).Count - 1 do
      Insert(nil, -1).Assign(TOutlookBarItem(Source)[I]);
    Exit;
  end;
  inherited Assign(Source);
end;

function TOutlookBarItems.Insert(Parent: TOutlookBarItem; Index: Integer): TOutlookBarItem;
begin
  Result := TOutlookBarItem.Create(Self);
  Result.FParent := Parent;
  if index = -1 then
    if Assigned(Parent) then Parent.FItems.Add(Result) else FItems.Add(Result)
  else
    if Assigned(Parent) then Parent.FItems.Insert(Index, Result) else FItems.Insert(Index, Result)
end;

procedure TOutlookBarItems.Clear;
var
  i:Integer;
begin
  for i := FItems.Count - 1 downto 0 do TObject(FItems[i]).Free;
  FItems.Clear;
end;

function TOutlookBarItems.GetVisibleItem(Index:Integer): TOutlookBarItem;
begin
  if Count = 0 then Result := nil else
  begin
    Result := Items[0];
    if not Result.CanVisible then Result := Result.GetNextVisible;
    while (Index > 0) and Assigned(Result) do
    begin
      Result := Result.GetNextVisible;
      Dec(Index);
    end;
  end;
end;

{function TOutlookBarItems.GetItemOfAll(Index:Integer): TOutlookBarItem;
var
  i:Integer;
begin
  if Count = 0 then Result := nil else
  begin
    Result := Items[0];
    for i := 0 to Index - 1 do
    begin
      Result := Result.GetNext;
      if Result = nil then Break;
    end;
  end;
end;}

{TOutlookBarPage}
constructor TOutlookBarPage.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FItems := TOutlookBarItems.Create(Self);
end;

destructor TOutlookBarPage.Destroy;
begin
  if OutlookBar.PageIndex = Index then if (Index = Owner.Count - 1) and (Index <> 0) then
    OutlookBar.PageIndex := Index - 1;
  FItems.Free;
  inherited Destroy;
end;

function TOutlookBarPage.GetPages:TOutlookBarPages;
begin
  Result := TOutlookBarPages(Collection);
end;

function TOutlookBarPage.GetOutlookBar:TCustomOutlookBar;
begin
  Result := Owner.Owner;
end;

function TOutlookBarPage.GetTitleRect: TRect;
var
  aw, ah: Integer;
begin
  if IsRectEmpty(FTitleRect) then
  begin
    Owner.Owner.MeasurePageTitle(Self, aw, ah);
    if Index <= Owner.Owner.PageIndex then
    begin
      if Index = 0 then
        Result := Classes.Rect(0, 0, Owner.Owner.ClientWidth, ah)
      else
      begin
        Result := Owner[Index - 1].GetTitleRect;
        with Result do
        begin
          Top := Bottom;
          Inc(Bottom, ah);
        end;
      end;
    end
    else
    begin
      if Index = Owner.Count - 1 then
        with Owner.Owner do
          Result := Classes.Rect(0, ClientHeight - ah, ClientWidth, ClientHeight)
      else
      begin
        Result := Owner[Index + 1].GetTitleRect;
        with Result do
        begin
          Bottom := Top;
          Dec(Top, ah);
        end;
      end;
    end;
  end
  else
    Result := FTitleRect;
end;

procedure TOutlookBarPage.SetCaption(Value: string);
begin
  FCaption := Value;
  OutlookBar.UpdatePage(Self);
end;

procedure TOutlookBarPage.SetItems(Value: TOutlookBarItems);
begin
  FItems.Assign(Value);
end;

{TOutlookBarPages}
function TOutlookBarPages.GetOutlookBar:TCustomOutlookBar;
begin
  Result := FOutlookBar;
end;

constructor TOutlookBarPages.Create(AOwner: TCustomOutlookBar);
begin
  inherited Create(TOutlookBarPage);
  FOutlookBar := AOwner;
end;

function TOutlookBarPages.GetItem(Index: Integer): TOutlookBarPage;
begin
  Result := TOutlookBarPage(inherited Items[Index]);
end;

procedure TOutlookBarPages.SetItem(Index: Integer; Value: TOutlookBarPage);
begin
  inherited Items[Index] := Value;
end;

function TOutlookBarPages.GetOwner: TPersistent;
begin
  Result := FOutlookBar;
end;

procedure TOutlookBarPages.Update(Item: TCollectionItem);
var
  I: Integer;
begin
  for I := 0 to Count - 1 do SetRectEmpty(Items[I].FTitleRect); //?????
  Owner.UpdatePage(TOutlookBarPage(Item));
end;

function TOutlookBarPages.Add: TOutlookBarPage;
begin
  Result := TOutlookBarPage(inherited Add);
end;

{TCustomOutlookBar}
constructor TCustomOutlookBar.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FVisibleItems := TList.Create;
  ControlStyle := ControlStyle + [csOpaque, csReplicatable, csDisplayDragImage];
  FLargeChangeLink := TChangeLink.Create;
  FSmallChangeLink := TChangeLink.Create;
  FPages:=TOutlookBarPages.Create(Self);
  ParentColor := False;
  Color := clAppWorkSpace;

  SetBounds(0, 0, 120, 200);
end;

destructor TCustomOutlookBar.Destroy;
begin
  FPages.Free;
  FLargeChangeLink.Free;
  FSmallChangeLink.Free;
  FVisibleItems.Free;
  inherited Destroy;
end;

function TCustomOutlookBar.CanScrollUp:Boolean;
begin
  Result := (Pages.Count > 0) and not FAnimating and (Pages[PageIndex].FOffset > 0);
end;

function TCustomOutlookBar.CanScrollDown:Boolean;
begin
  Result := not FAnimating and Assigned(GetItemAt(1, GetWorkArea.Bottom-1)); //算法不好
end;

const
  ScrollButtonIndent = 8;

function TCustomOutlookBar.GetScrollUpRect: TRect;
begin
  SetRectEmpty(Result);
  if (Pages.Count = 0) or not CanScrollUp then Exit;
  Result := GetWorkArea;
  with Result do
  begin
    Dec(Right, ScrollButtonIndent);
    Inc(Top, ScrollButtonIndent);
    Result.Left := Result.Right - GetSystemMetrics(SM_CXVSCROLL);
    Result.Bottom := Result.Top + GetSystemMetrics(SM_CYVSCROLL);
  end;
end;

function TCustomOutlookBar.GetScrollDownRect: TRect;
begin
  SetRectEmpty(Result);
  if (Pages.Count = 0) or not CanScrollDown then Exit;
  Result := GetWorkArea;
  with Result do
  begin
    Dec(Right, ScrollButtonIndent);
    Dec(Bottom, ScrollButtonIndent);
    Result.Left := Result.Right - GetSystemMetrics(SM_CXVSCROLL);
    Result.Top := Result.Bottom - GetSystemMetrics(SM_CYVSCROLL);
  end;
end;

procedure TCustomOutlookBar.DrawScrollButtons;
begin
  if CanScrollUp then
    if FScrollUpDown then
      DrawFrameControl(Canvas.Handle, GetScrollUpRect,DFC_SCROLL,DFCS_SCROLLUP or DFCS_PUSHED)
    else
      DrawFrameControl(Canvas.Handle, GetScrollUpRect,DFC_SCROLL,DFCS_SCROLLUP);
  if CanScrollDown then
    if FScrollDownDown then
      DrawFrameControl(Canvas.Handle, GetScrollDownRect,DFC_SCROLL,DFCS_SCROLLDown or DFCS_PUSHED)
    else
      DrawFrameControl(Canvas.Handle, GetScrollDownRect,DFC_SCROLL,DFCS_SCROLLDown);
end;

procedure TCustomOutlookBar.ScrollUp;
begin
  with Pages[PageIndex] do
    if FOffset <> 0 then Dec(FOffset);
  UpdateItem(nil);
end;

procedure TCustomOutlookBar.ScrollDown;
begin
  Inc(Pages[PageIndex].FOffset);
  UpdateItem(nil);
end;

procedure TCustomOutlookBar.SetPages(Value: TOutlookBarPages);
begin
  FPages.Assign(Value);
end;

procedure TCustomOutlookBar.SetPageIndex(Value: Integer);
  procedure Ani(pOrgin, pNew: TOutlookBarPage);
  const
    AniTime = 100;
    AniStep = 20;
    AniStepTiem = AniTime div AniStep;
  var
    i, ATop, dy: Integer;
    rt, rtbm: TRect;
    bm: TBitmap;
  begin
    if pOrgin.Index < pNew.Index then
    begin
      rtbm := GetWorkArea;
      rt.TopLeft := rtbm.TopLeft;
      rt.BottomRight := GetPageTitleRect(PNew).BottomRight;
      rtbm.Top := rtbm.Bottom;
      rtbm.Bottom := rt.Bottom;
      dy := -1;
    end
    else
    begin
      rtbm := GetWorkArea;
      rt.TopLeft := GetPageTitleRect(pNew).BottomRight;
      rt.Left := 0;
      rt.BottomRight := rtbm.BottomRight;
      rtbm.Bottom := rtbm.Top;
      rtbm.Top := rt.Top;
      dy := 1;
    end;
    bm := TBitmap.Create;
    try
      bm.Width := ClientWidth;
      bm.Height := rtbm.Bottom - rtbm.Top;
      bm.Canvas.CopyRect(Rect(0,0,bm.Width,bm.Height), Canvas, rtbm);
      if dy = 1 then
      begin
        Atop := rt.Top;
        rtbm.Bottom := rtbm.Top;
      end
      else
      begin
        ATop := rt.Bottom - bm.Height;
        rtbm.Top := rtbm.Bottom;
      end;
      dy := dy * ((rt.Bottom - rt.Top) div AniStep);
      for i := 0 to AniStep - 1 do
      begin
//        DrawItems(PNew, rtbm);
        Canvas.Brush.Color := Color;
        Canvas.FillRect(rtbm);
        Canvas.Draw(rt.Left, ATop, bm);
        if dy > 0 then
        begin
          Inc(rtbm.Bottom, dy);
        end
        else
        begin
          Inc(rtbm.Top, dy);
        end;