fcoutlooklist.pas

一套及时通讯的原码

  end;
end;

function TfcCustomOutlookList.GetItemAt(x, y: Integer): TfcOutlookListItem;
var i: Integer;
begin
  result := nil;
  for i := 0 to Items.Count - 1 do
    //3/24/2000 - PYW - Made sure Item is visible when checking if point is in ItemRect.
    if (Items[i].IsVisible(True)) and (PtInRect(Items[i].ItemRect, Point(x, y))) then
    begin
      result := Items[i];
      Break;
    end;
end;

procedure TfcCustomOutlookList.PaintScrollButton(Button: TfcScrollButtonStyle);
const ButtonStates: array[Boolean] of Integer = (0, DFCS_PUSHED);
var bm: TBitmap;
    resName: string;
    Down: Boolean;
    Offset: TPoint;
    r: TRect;
//    Details: TThemedElementDetails;
//    Style: TThemedScrollBar;
begin
  if not ScrollButtonVisible(Button) or not ScrollButtonsVisible then Exit;

  if Button = sbUp then r := FUpButtonRect else r := FDownButtonRect;

  Down := (MouseInScrollButton = Button) and (FScrollButtonDown = Button);

  case Button of
     sbUp: if Layout = loVertical then resName := 'FCDROPUP' else resName := 'FCDROPLEFT';
     sbDown: if Layout = loVertical then resName := 'FCDROPDOWN' else resName := 'FCDROPRIGHT';
  end;

{  if ThemeServices.ThemesEnabled then
  begin
      if resName = 'FCDROPUP' then style:= tsArrowBtnUpNormal
      else if resName = 'FCDROPDOWN' then style:= tsArrowBtnDownNormal
      else if resName = 'FCDROPLEFT' then style:= tsArrowBtnLeftNormal
      else if resName = 'FCDROPRIGHT' then style:= tsArrowBtnRightNormal;
      Details := ThemeServices.GetElementDetails(Style);
      ThemeServices.DrawElement(PaintCanvas.Handle, Details, r);
      ThemeServices.DrawParentBackground(Handle, PaintCanvas.Handle, nil, False, @r);
      exit;
  end;
}
  DrawFrameControl(PaintCanvas.Handle, r, DFC_BUTTON, DFCS_BUTTONPUSH or ButtonStates[Down]);
//  case Button of
//    sbUp: if Layout = loVertical then resName := 'FCDROPUP' else resName := 'FCDROPLEFT';
//    sbDown: if Layout = loVertical then resName := 'FCDROPDOWN' else resName := 'FCDROPRIGHT';
//  end;
  bm := TBitmap.Create;
  bm.Transparent := True;
  bm.LoadFromResourceName(HINSTANCE, resName);
  if Layout = loVertical then Offset := Point(r.Left + 2, r.Top + 5)
  else Offset := Point(r.Left + 5, r.Top + 3);
  if Down then with Offset do Offset := Point(x + 1, y + 1);
  PaintCanvas.Draw(Offset.x, Offset.y, bm);
  bm.Free;
end;

procedure TfcCustomOutlookList.ItemClick(Item: TfcOutlookListItem);
begin
  if (ClickStyle = csSelect) and not Item.Selected then
  begin
    Item.Selected := True;
    if Assigned(FOnItemChange) then FOnItemChange(self, Item);
  end;
  if Assigned(FOnItemClick) then FOnItemClick(self, Item);

  { 4/14/99 - RSW - Added following 2 lines }
  if Assigned(Item.FOnClick) then Item.FOnClick(self, Item);
  if Assigned(Item.Action) and Assigned(Item.Action.OnExecute) then
     Item.Action.OnExecute(Item);
  UpdateMouseOnItem;

end;

function TfcCustomOutlookList.GetNextVisibleItem(item: TfcOutlookListItem): TfcOutlookListItem;
var curIndex: integer;
begin
  result:= nil;
  if item=nil then exit;
  curIndex:= item.index;
  repeat
     inc(curIndex);
     if curIndex>items.count-1 then exit;
     if items[curIndex].visible then
     begin
        result:= items[curIndex];
        exit;
     end;
  until (curIndex>=items.count-1);
end;

function TfcCustomOutlookList.GetPriorVisibleItem(item: TfcOutlookListItem): TfcOutlookListItem;
var curIndex: integer;
begin
  result:= nil;
  if item=nil then exit;
  curIndex:= item.index;
  repeat
     dec(curIndex);
     if curIndex<0 then exit;
     if items[curIndex].visible then
     begin
        result:= items[curIndex];
        exit;
     end;
  until (curIndex<0);
end;

procedure TfcCustomOutlookList.ScrollButtonClick;
begin
  case FScrollButtonDown of
    sbUp: if (TopItem <> nil) and (TopItem.Index > 0) then TopItem := GetPriorVisibleItem(TopItem); //Items[TopItem.Index - 1];
    sbDown: if (TopItem <> nil) and (TopItem.Index < Items.Count - 1) then TopItem := GetNextVisibleItem(TopItem); //Items[TopItem.Index + 1];
  end;
  UpdateButtonRects;  // Moved, Insures that the hotrack rect is on the correct item; previously prevented OnDrawText from working properly -ksw (4/30/99)
  UpdateMouseOnItem;
end;

procedure TfcCustomOutlookList.UpdateMouseOnItem;
var i: Integer;
    pt: TPoint;
begin
  pt := ScreenToClient(fcGetCursorPos);
  if TopItem <> nil then for i := TopItem.Index to BottomItem.Index do
  begin
    if not Items[i].visible then continue; // 5/5/03
    Items[i].MouseOnItem := PtInRect(Items[i].ButtonRect, pt);
  end
end;

procedure TfcCustomOutlookList.UpdateScrollButtonsRect;
begin
  if Layout = loVertical then
  begin
    FUpButtonRect := Rect(Width - 25, 10, Width - 10, 25);
    FDownButtonRect := Rect(Width - 25, Height - 25, Width - 10, Height - 10);
  end else begin
    FUpButtonRect := Rect(10, 10, 25, 25);
    FDownButtonRect := Rect(Width - 25, 10, Width - 10, 25);
  end;
end;

procedure TfcCustomOutlookList.Paint;
var i: Integer;
begin
  inherited;

  if not Transparent then { 5/2/99 - Transparent fills in with parent outlookbar color }
  begin
    PaintCanvas.Brush.Color := Color;
    PaintCanvas.FillRect(Rect(0, 0, ClientWidth, ClientHeight));
  end else begin
     if GetImager<>nil then
     begin
        if GetImager.DrawStyle=dsTile then
           GetImager.WorkBitmap.TileDraw(PaintCanvas, Parent.BoundsRect)
        else
           PaintCanvas.StretchDraw(Parent.ClientRect, GetImager.WorkBitmap);
     end
     else begin
        PaintCanvas.Brush.Color := TfcOutlookPage(OutlookPage).OutlookBar.Color;
        PaintCanvas.FillRect(Rect(0, 0, ClientWidth, ClientHeight));
     end
  end;

  PaintCanvas.Font.Assign(Font);

  if TopItem <> nil then
  begin
    for i := TopItem.Index to BottomItem.Index do
    begin
      if not Items[i].visible then continue;
      Items[i].Paint;
    end;
    PaintScrollButton(sbUp);
    PaintScrollButton(sbDown);
  end;
  Canvas.CopyRect(Rect(0, 0, ClientWidth, ClientHeight), PaintCanvas, Rect(0, 0, ClientWidth, ClientHeight));
end;

procedure TfcCustomOutlookList.UpdateButtonRects;
var i: Integer;
begin
  for i := TopItem.Index to BottomItem.Index do
    if not IsEffectiveItemHilite then Items[i].FButtonRect := Items[i].DisplayRect(drIcon, -1)
    else Items[i].FButtonRect := Items[i].DisplayRect(drBounds, -1);
end;

procedure TfcCustomOutlookList.ValidateInsert(AComponent: TComponent);
begin
  raise EInvalidOperation.Create('TfcCustomOutlookList does not accept child controls.  Delete ' +
    'TfcCustomOutlookList and/or set the options property of the TfcControlBar, "cboAutoCreateOutlookList", to False');
end;

function TfcCustomOutlookList.IsEffectiveItemHilite: boolean;
begin
   result:= (HotTrackStyle=hsItemHilite) or (Images=nil)
end;

function TfcOutlookListItem.GetAction: TBasicAction;
begin
  if ActionLink <> nil then
    Result := ActionLink.Action else
    Result := nil;
end;

procedure TfcOutlookListItem.SetAction(Value: TBasicAction);
begin
  if Value = nil then
  begin
    ActionLink.Free;
    ActionLink := nil;
  end
  else
  begin
    if ActionLink = nil then
      ActionLink := TfcOutlookItemActionLinkClass.Create(Self);
    ActionLink.Action := Value;
    ActionLink.OnChange := DoActionChange;
    ActionChange(Value, csLoading in Value.ComponentState);
    Value.FreeNotification(OutlookList);
  end;
end;

procedure TfcOutlookListItem.ActionChange(Sender: TObject; CheckDefaults: Boolean);
begin
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      if not CheckDefaults or (Self.text = '') then
        Self.Text := Caption;
      if not CheckDefaults or (Self.Enabled = True) then
        Self.Enabled := Enabled;
      if not CheckDefaults or (Self.Hint = '') then
        Self.Hint := Hint;
      if not CheckDefaults or (Self.Visible = True) then
        Self.Visible := Visible;
//      if not CheckDefaults or not Assigned(Self.OnClick) then
//        Self.OnExecuteAction := OnExecute;
    end;
end;

procedure TfcOutlookListItem.DoActionChange(Sender: TObject);
begin
  if Sender = Action then ActionChange(Sender, False);
end;


procedure TfcOutlookItemActionLink.AssignClient(AClient: TObject);
begin
   FItem:= AClient as TfcOutlookListItem;
end;

function TfcOutlookItemActionLink.IsCaptionLinked: Boolean;
begin
   result:= true;
end;

function TfcOutlookItemActionLink.IsEnabledLinked: Boolean;
begin
   result:= true;
end;

function TfcOutlookItemActionLink.IsHintLinked: Boolean;
begin
   result:= true;
end;

function TfcOutlookItemActionLink.IsVisibleLinked: Boolean;
begin
   result:= true;
end;

function TfcOutlookItemActionLink.IsOnExecuteLinked: Boolean;
begin
   result:= true;
end;

{function TfcOutlookItemActionLink.DoShowHint(var HintStr: string): Boolean;
begin
end;
}
procedure TfcOutlookItemActionLink.SetCaption(const Value: string);
begin
  if IsCaptionLinked and (Value<>'') then FItem.Text := Value;
end;

procedure TfcOutlookItemActionLink.SetEnabled(Value: Boolean);
begin
   FItem.Enabled:= Value;
end;

procedure TfcOutlookItemActionLink.SetHint(const Value: string);
begin
   FItem.Hint:= Value;
end;

procedure TfcOutlookItemActionLink.SetVisible(Value: Boolean);
begin
   FItem.Visible:= Value;
end;

{procedure TfcOutlookItemActionLink.SetOnExecute(Value: TNotifyEvent);
begin
  FItem.OnExecuteAction:= Value;
end;
}

procedure TfcCustomOutlookList.HintTimerEvent(Sender: TObject);
var
    sp, cp: TPoint;
    OutsideClient: boolean;
    hintTimerInterval: integer;
    i: integer;
begin
   if (HintWindow=nil) then exit;

   GetCursorPos(cp);
   sp:= self.ScreenToClient(cp);

   if TopItem <> nil then
    for i := TopItem.Index to BottomItem.Index do
    begin
      if not Items[i].visible then continue; // 5/5/03
      if i>=Items.Count then break;  // 2/7/2002-Added to handle case where ItemClick deletes an item.
      if Items[i].MouseOnItem then
      begin
         if (not PtInRect(Items[i].ButtonRect, sp)) then
         begin
            Items[i].MouseOnItem := False;
            FreeHintWindow;
         end
         else begin
           if HintTimerCount=1 then
           begin
              HintWindow.ActivateHint(TOutlookListHintWindow(HintWindow).HintRect,
                   TOutlookListHintWindow(HintWindow).HintItem.Hint);
              exit;
           end
         end
      end
    end;

   sp:= self.ClientToScreen(Point(0, 0));
   if (cp.x<sp.x) or (cp.x>sp.x+ClientRect.Right-ClientRect.Left) or
      (cp.y<sp.y) or (cp.y>sp.y+ClientRect.Bottom-ClientRect.Top) then
   begin
      OutsideClient:= True;
   end
   else OutsideClient:= False;

   { Process Hint Timer clean-up}
   if OutsideClient then
   begin
      FreeHintWindow;
   end
   else begin
      inc(HintTimerCount);
      HintTimerInterval:= HintTimer.interval;
      if HintTimerCount>
         fcMax(Application.HintHidePause div HintTimerInterval, 10) then
      begin
        FreeHintWindow;
      end
   end

end;

procedure TfcCustomOutlookList.FreeHintWindow;
begin
   HintTimerCount:= 0;
   HintWindow.Free;
   HintWindow:= nil;
   if HintTimer<>nil then HintTimer.enabled:= False;
end;

initialization
  RegisterClasses([TfcOutlookList]);
end.