home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 September / Chip_2001-09_cd1.bin / zkuste / delphi / kolekce / d56 / RMCTL.ZIP / rmOutLookExtras.pas < prev    next >
Pascal/Delphi Source File  |  2001-06-22  |  23KB  |  807 lines

  1. {================================================================================
  2. Copyright (C) 1997-2001 Mills Enterprise
  3.  
  4. Unit     : rmOutlookExtras
  5. Purpose  : A simple implementation of the M$ Outlook style buttons components
  6. Date     : 03-07-01
  7. Author   : Ryan J. Mills
  8. Version  : 1.80
  9. Notes    : This unit was originally based upon the work of Patrick O'Keeffe.
  10.            It was at his request that I took the component over and rm'ified it.
  11.            
  12.            06-03-01: The TrmOutlookActionLink component was originally written
  13.            by Piotr Jurago of Poland.  He sent the code back to me and I've
  14.            included it here.
  15. ================================================================================}
  16.  
  17. unit rmOutLookExtras;
  18.  
  19. interface
  20.  
  21. {$I CompilerDefines.INC}
  22.  
  23. uses windows, messages, ActnList, controls, classes, rmSpeedBtns, rmOutlook, imglist;
  24.  
  25. type
  26.   TrmOutLookButtonList = class;
  27.   TrmOutlookListButton = class;
  28.  
  29.   TOLButtonStyle = (olbsLarge, olbsSmall);
  30.   TOLViewStyle = (vsSmallIcons, vsLargeIcons);
  31.   TOLButtonClickEvent = procedure(Sender : TObject; Button : TrmOutlookListButton) of Object;
  32.  
  33.   TrmOutlookListBaseButton = class(TrmSpeedButton)
  34.   private
  35.     FOutLookButtonList : TrmOutlookButtonList;
  36.     FMouseInControl : Boolean;
  37.     FCaption: String;
  38.     FButtonStyle: TOLButtonStyle;
  39.     FImageIndex: Integer;
  40.     procedure CMMouseEnter(var Message : TMessage); message CM_MOUSEENTER;
  41.     procedure CMMouseLeave(var Message : TMessage); message CM_MOUSELEAVE;
  42.     procedure SetrmOutlookButtons(Value : TrmOutlookButtonList);
  43.     procedure SetCaption(const Value: String);
  44.     procedure SetButtonStyle(const Value: TOLButtonStyle);
  45.     procedure SetImageIndex(const Value: Integer);
  46.   protected
  47.     { Protected Declarations }
  48.     procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
  49.     procedure EraseBK(var Message : TMessage); message WM_ERASEBKGND;
  50.     procedure Paint; override;
  51.   public
  52.     { Public Declarations }
  53.     constructor create(AOwner:TComponent); override;
  54.     property ImageIndex : Integer read FImageIndex write SetImageIndex;
  55.     property OutLookButtonList : TrmOutlookButtonList read FOutLookButtonList write SeTrmOutlookButtons;
  56.     property ButtonStyle : TOLButtonStyle read FButtonStyle write SetButtonStyle;
  57.     property ButtonCaption : String read FCaption write SetCaption;
  58.   end;
  59.  
  60.   TrmOutlookListButton = class(TCollectionItem)
  61.   private
  62.     FButton : TrmOutlookListBaseButton;
  63.     FData: Pointer;
  64.     procedure ClickButton(Sender : TObject);
  65.     function GetImageIndex: Integer;
  66.     function GetCaption: String;
  67.     function GetAction: TBasicAction;
  68.     procedure SetImageIndex(const Value: Integer);
  69.     procedure SetCaption(const Value: String);
  70.     procedure SetAction(const Value: TBasicAction);
  71.     function GetEnabled: boolean;
  72.     procedure SetEnabled(const Value: boolean);
  73.     function GetHint: string;
  74.     procedure SetHint(const Value: string);
  75.     function GetShowHint: boolean;
  76.     procedure SetShowHint(const Value: boolean);
  77.   public
  78.     constructor Create(Collection : TCollection); override;
  79.     destructor Destroy; override;
  80.     property Data : Pointer read FData write FData;
  81.   published
  82.     property Action: TBasicAction read GetAction write SetAction;
  83.     property ImageIndex : Integer read GetImageIndex write SetImageIndex;
  84.     property Enabled : boolean read GetEnabled write SetEnabled;
  85.     property Hint:string read GetHint write SetHint;
  86.     property Caption : String read GetCaption write SetCaption;
  87.     property ShowHint : boolean read GetShowHint write SetShowHint;
  88.   end;
  89.  
  90.   TrmOutlookButtons = class(TCollection)
  91.   private
  92.     FOLBtnList: TrmOutlookButtonList;
  93.     function GetItem(Index: Integer): TrmOutlookListButton;
  94.     procedure SetItem(Index: Integer; Value: TrmOutlookListButton);
  95.   public
  96.     function Add: TrmOutlookListButton;
  97.     constructor Create(AOwner: TrmOutlookButtonList);
  98.     property Items[Index: Integer]: TrmOutlookListButton read GetItem write SetItem; default;
  99.     property OLBtnList: TrmOutlookButtonList read FOLBtnList;
  100.   end;
  101.  
  102.   TrmOutlookButtonListPanel = class(TCustomControl)
  103.   protected
  104.     procedure Paint; override;
  105.     procedure EraseBK(var Message : TMessage); message WM_ERASEBKGND;
  106.   public
  107.     constructor create(AOwner:TComponent); override;
  108.   end;
  109.  
  110.   TrmOutlookButtonList = class(TCustomControl)
  111.   private
  112.     FButtons : TrmOutlookButtons;
  113.     FUpButton : TrmTimerSpeedButton;
  114.     FDownButton : TrmTimerSpeedButton;
  115.  
  116.     FBasePanel : TrmOutlookButtonListPanel;
  117.  
  118.     FLargeImages : TImageList;
  119.     FSmallImages: TImageList;
  120.     FImageChangeLink : TChangeLink;
  121.  
  122.     FViewStyle: TOLViewStyle;
  123.  
  124.     FTopButton: Integer;
  125.  
  126.     FOnClickButton: TOLButtonClickEvent;
  127.     procedure GoUp(Sender : TObject);
  128.     procedure GoDown(Sender : TObject);
  129.     procedure CMDialogKey(var Message : TCMDialogKey); message CM_DIALOGKEY;
  130.     procedure SetLargeImages(Value : TImageList);
  131.     procedure ImageListChange(Sender : TObject);
  132.     procedure SetViewStyle(const Value: TOLViewStyle);
  133.     procedure SetTopButton(const Value: Integer);
  134.     procedure SetSmallImages(const Value: TImageList);
  135.   protected
  136.     procedure Loaded; override;
  137.     procedure WMSize(var Message : TMessage); message WM_SIZE;
  138.     procedure RefreshButtons;
  139.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  140.   public
  141.     constructor Create(AOwner : TComponent); override;
  142.     destructor Destroy; override;
  143.   published
  144.     property Align;
  145.     property PopUpMenu;
  146.     property Buttons : TrmOutlookButtons read FButtons write FButtons;
  147.     property LargeImages : TImageList read FLargeImages write SetLargeImages;
  148.     property SmallImages : TImageList read FSmallImages write SetSmallImages;
  149.     property ShowHint;
  150.     property ViewStyle : TOLViewStyle read FViewStyle write SetViewStyle;
  151.     property TopButton : Integer read FTopButton write SetTopButton;
  152.     property OnClickButton : TOLButtonClickEvent read FOnClickButton write FOnClickButton;
  153.   end;
  154.  
  155.   TrmOutlookActionLink = class(TComponent)
  156.   private
  157.    { Private declarations }
  158.      FViewStyle: TOLViewStyle;
  159.      FActionList: TActionList;
  160.      FOutlookControl: TrmOutlookControl;
  161.      function BothAssigned: Boolean;
  162.      procedure SetActionList(const Value: TActionList) ;
  163.      procedure SetOutlookControl(const Value: TrmOutlookControl) ;
  164.      procedure SetViewStyle(const Value: TOLViewStyle) ;
  165.   protected
  166.    { Protected }
  167.      procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  168.   public
  169.    { Public declarations }
  170.      procedure AddPagesFromActionCategorys;
  171.      procedure AddButtonsFromActionsInCategory(Category: String) ;
  172.   published
  173.    { Published declarations }
  174.      property ViewStyle: TOLViewStyle read FViewStyle write SetViewStyle;
  175.      property ActionList: TActionList read FActionList write SetActionList;
  176.      property OutlookControl: TrmOutlookControl read FOutlookControl write SetOutlookControl;
  177.   end;
  178.  
  179. implementation
  180.  
  181. uses graphics, ExtCtrls, Dialogs, rmLibrary;
  182.  
  183. { TrmOutlookButtonList }
  184.  
  185. constructor TrmOutlookButtonList.Create(AOwner : TComponent);
  186. begin
  187.   inherited Create(AOwner);
  188.   Caption := '';
  189.   Color := clGray;
  190.   ControlStyle := [csDoubleClicks];
  191.   FBasePanel := TrmOutlookButtonListPanel.Create(Self);
  192.   FBasePanel.Parent := Self;
  193.  
  194.   FUpButton := TrmTimerSpeedButton.Create(Self);
  195.   FUpButton.Parent := Self;
  196.   FUpButton.Width := 17;
  197.   FUpButton.Height := 17;
  198.   FUpButton.OnClick := GoUp;
  199.   FUpButton.Font.Name := 'Marlett';
  200.   FUpButton.Font.size := 10;
  201.   FUpButton.Caption := '5';
  202.   FUpButton.TimeBtnState := [tbAllowTimer];
  203.  
  204.   FDownButton := TrmTimerSpeedButton.Create(Self);
  205.   FDownButton.Parent := Self;
  206.   FDownButton.Width := 17;
  207.   FDownButton.Height := 17;
  208.   FDownButton.OnClick := GoDown;
  209.   FDownButton.Font.Name := 'Marlett';
  210.   FDownButton.Font.size := 10;
  211.   FDownButton.Caption := '6';
  212.   FDownButton.TimeBtnState := [tbAllowTimer];
  213.  
  214.   FButtons := TrmOutlookButtons.Create(Self);
  215.   FImageChangeLink := TChangeLink.Create;
  216.   FImageChangeLink.OnChange := ImageListChange;
  217.   Height := 200;
  218.   Width := 150;
  219. end;
  220.  
  221. destructor TrmOutlookButtonList.Destroy;
  222. begin
  223.   FButtons.Free;
  224.   FImageChangeLink.Free;
  225.   FUpButton.Free;
  226.   FDownButton.Free;
  227.   inherited Destroy;
  228. end;
  229.  
  230. procedure TrmOutlookButtonList.ImageListChange(Sender : TObject);
  231. begin
  232.    Invalidate;
  233. end;
  234.  
  235. procedure TrmOutlookButtonList.Loaded;
  236. begin
  237.   inherited;
  238.   RefreshButtons;
  239. end;
  240.  
  241. procedure TrmOutlookButtonList.WMSize(var Message : TMessage);
  242. begin
  243.   inherited;
  244.   RefreshButtons;
  245. end;
  246.  
  247. procedure TrmOutlookButtonList.CMDialogKey(var Message : TCMDialogKey);
  248. begin
  249.   if (Message.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then
  250.   begin
  251.     Message.Result := 1;
  252.   end
  253.   else
  254.     inherited;
  255. end;
  256.  
  257. procedure TrmOutlookButtonList.SetLargeImages(Value : TImageList);
  258. begin
  259.   if FLargeImages <> nil then
  260.      FLargeImages.UnRegisterChanges(FImageChangeLink);
  261.   FLargeImages := Value;
  262.   if FLargeImages <> nil then
  263.   begin
  264.     FLargeImages.RegisterChanges(FImageChangeLink);
  265.     FLargeImages.FreeNotification(Self);
  266.   end;
  267.   Invalidate;
  268. end;
  269.  
  270. procedure TrmOutlookButtonList.SetSmallImages(const Value: TImageList);
  271. begin
  272.   if FSmallImages <> nil then
  273.      FSmallImages.UnRegisterChanges(FImageChangeLink);
  274.   FSmallImages := Value;
  275.   if FSmallImages <> nil then
  276.   begin
  277.     FSmallImages.RegisterChanges(FImageChangeLink);
  278.     FSmallImages.FreeNotification(Self);
  279.   end;
  280.   Invalidate;
  281. end;
  282.  
  283. procedure TrmOutlookButtonList.RefreshButtons;
  284. var
  285.   loop : Integer;
  286.   TotalHeight : Integer;
  287.   wBtnHeight : integer;
  288.   wTop : integer;
  289.   wBtnStyle : TOLButtonStyle;
  290.  
  291. begin
  292.   if csLoading in ComponentState then
  293.     Exit;
  294.  
  295.   FUpButton.Visible := False;
  296.   FUpButton.Top := 5;
  297.   FUpButton.Left := Width - 16 - 5;
  298.  
  299.   FDownButton.Visible := False;
  300.   FDownButton.Top := Height - 16 - 5;
  301.   FDownButton.Left := Width - 16 - 5;
  302.  
  303.   FBasePanel.Left := 10;
  304.   FBasePanel.Top := 10;
  305.   FBasePanel.Width := ClientWidth - 36;
  306.   FBasePanel.Height := ClientHeight - 20;
  307.  
  308.   if FViewStyle = vsSmallIcons then
  309.   begin
  310.      wBtnHeight := 25;
  311.      wBtnStyle := olbsSmall;
  312.   end
  313.   else
  314.   begin
  315.      wBtnHeight := 65;
  316.      wBtnStyle := olbsLarge;
  317.   end;
  318.  
  319.   TotalHeight := FButtons.Count * wBtnHeight;
  320.   if TotalHeight > FBasePanel.Height then
  321.      wTop := -(FTopButton * wBtnHeight)
  322.   else
  323.      wTop := 0;
  324.  
  325.   for loop := 0 to FButtons.Count - 1 do
  326.   begin
  327.     FButtons.Items[loop].FButton.ButtonStyle := wBtnStyle;
  328.  
  329.     FButtons.Items[loop].FButton.Width := FBasePanel.ClientWidth;
  330.     FButtons.Items[loop].FButton.Height := wBtnHeight;
  331.     FButtons.Items[loop].FButton.Top := wTop;
  332.     FButtons.Items[loop].FButton.Left := 0;
  333.  
  334.     inc(wTop, wBtnHeight);
  335.   end;
  336.  
  337.   FUpButton.Visible := (FTopButton > 0);
  338.   FDownButton.Visible := (((FButtons.Count - FTopButton) * wBtnHeight) > FBasePanel.ClientHeight);
  339.  
  340.   Repaint;
  341. end;
  342.  
  343. procedure TrmOutlookButtonList.SetViewStyle(const Value: TOLViewStyle);
  344. begin
  345.   FViewStyle := Value;
  346.   RefreshButtons;
  347. end;
  348.  
  349. procedure TrmOutlookButtonList.SetTopButton(const Value: Integer);
  350. begin
  351.   FTopButton := Value;
  352.   RefreshButtons;
  353. end;
  354.  
  355. procedure TrmOutlookButtonList.GoDown(Sender : TObject);
  356. begin
  357.   if FDownButton.visible then
  358.   begin
  359.      FTopButton := FTopButton + 1;
  360.      RefreshButtons;
  361.   end;
  362. end;
  363.  
  364. procedure TrmOutlookButtonList.GoUp(Sender : TObject);
  365. begin
  366.   if FUpButton.visible then
  367.   begin
  368.      FTopButton := FTopButton - 1;
  369.      RefreshButtons;
  370.   end;
  371. end;
  372.  
  373. procedure TrmOutlookButtonList.Notification(AComponent: TComponent;
  374.   Operation: TOperation);
  375. begin
  376.   inherited Notification(AComponent, Operation);
  377.   if Operation = opRemove then
  378.   begin
  379.     if AComponent = FLargeImages then
  380.       fLargeImages := nil;
  381.  
  382.     if AComponent = FSmallImages then
  383.       FSmallImages := nil;
  384.   end;
  385. end;
  386.  
  387. { TrmOutlookListBaseButton }
  388.  
  389. procedure TrmOutlookListBaseButton.SeTrmOutlookButtons(Value : TrmOutlookButtonList);
  390. begin
  391.   if FOutLookButtonList <> value then
  392.      FOutLookButtonList := Value;
  393. end;
  394.  
  395. procedure TrmOutlookListBaseButton.CMMouseEnter(var Message : TMessage);
  396. begin
  397.   inherited;
  398.   if not FMouseInControl and Enabled then
  399.   begin
  400.     FMouseInControl := True;
  401.     Invalidate;
  402.   end;
  403. end;
  404.  
  405.  
  406. procedure TrmOutLookListBaseButton.CMMouseLeave(var Message : TMessage);
  407. begin
  408.   inherited;
  409.   if FMouseInControl and Enabled then
  410.   begin
  411.     FMouseInControl := False;
  412.     Invalidate;
  413.   end;
  414. end;
  415.  
  416.  
  417. procedure TrmOutLookListBaseButton.Paint;
  418. var
  419.   wButtonRect : TRect;
  420.   wTextRect : TRect;
  421.   wDrawFlags : integer;
  422.   wTopColor, wBottomColor : TColor;
  423.   wImageList : TImageList;
  424. begin
  425.   //paint the frame..
  426.   if FOutLookButtonList <> nil then
  427.     Canvas.Brush.Color := FOutLookButtonList.Color
  428.   else
  429.     Canvas.Brush.Color := clAppWorkspace;
  430.   Canvas.FillRect(Rect(0, 0, Width, Height));
  431.  
  432.   wImageList := nil;
  433.  
  434.   wDrawFlags := DT_SINGLELINE or DT_END_ELLIPSIS;
  435.  
  436.   case FButtonStyle of
  437.     olbsLarge :
  438.        begin
  439.           wImageList := FOutLookButtonList.FLargeImages;
  440.           wButtonRect := Rect((Width div 2) - 18, 0, (Width div 2) + 18, 36);
  441.           wTextRect := Rect(0, wButtonRect.Bottom + 3, Width, Height);
  442.           wDrawFlags := wDrawFlags or DT_CENTER;
  443.        end;
  444.     olbsSmall :
  445.        begin
  446.           wImageList := FOutLookButtonList.FSmallImages;
  447.           wButtonRect := Rect(0, 0, 20, 20);
  448.           wTextRect := Rect(wButtonRect.Right + 4, 0, Width, wButtonRect.Bottom);
  449.           wDrawFlags := wDrawFlags or DT_VCENTER;
  450.        end;
  451.   end;
  452.  
  453.   if FMouseInControl then
  454.   begin
  455.     if FState in [bsDown] then
  456.     begin
  457.       //the button is pushed...
  458.       wTopColor := cl3dDkShadow;
  459.       wBottomColor := cl3DLight;
  460.     end
  461.     else
  462.     begin
  463.       wTopColor := cl3DLight;
  464.       wBottomColor := cl3dDkShadow;
  465.     end;
  466.  
  467.     Frame3d(Canvas, wButtonRect, wTopColor, wBottomColor, 1);
  468.  
  469.     if (FState in [bsDown]) then
  470.        OffsetRect(wButtonRect, 1, 1);
  471.   end
  472.   else
  473.     InflateRect(wButtonRect, -1, -1);
  474.  
  475.   if (wImageList <> nil) and (FImageIndex > -1) then
  476.   begin
  477.      if assigned(parent) and (csdesigning in Parent.ComponentState) then
  478.         wImageList.Draw(Canvas, wButtonRect.Left + 1, wButtonRect.Top + 1, FImageIndex)
  479.      else
  480.         wImageList.Draw(Canvas, wButtonRect.Left + 1, wButtonRect.Top + 1, FImageIndex, self.enabled)
  481.   end;
  482.  
  483.   Canvas.Font.Color := clCaptionText;
  484.   Canvas.Brush.Color := clAppWorkspace;
  485.   DrawTextEx(Canvas.Handle, PCHar(FCaption), Length(FCaption), wTextRect, wDrawFlags, nil);
  486. end;
  487.  
  488.  
  489.  
  490. procedure TrmOutLookListBaseButton.EraseBK(var Message: TMessage);
  491. begin
  492.   Message.Result := 1;
  493. end;
  494.  
  495. procedure TrmOutLookListBaseButton.SetCaption(const Value: String);
  496. begin
  497.   FCaption := Value;
  498.   Invalidate;
  499. end;
  500.  
  501. procedure TrmOutLookListBaseButton.SetButtonStyle(
  502.   const Value: TOLButtonStyle);
  503. begin
  504.   FButtonStyle := Value;
  505.   Invalidate;
  506. end;
  507.  
  508. constructor TrmOutlookListBaseButton.create(AOwner: TComponent);
  509. begin
  510.   inherited;
  511.   ControlStyle := ControlStyle - [csDesignInteractive];
  512. end;
  513.  
  514. procedure TrmOutlookListBaseButton.SetImageIndex(const Value: Integer);
  515. begin
  516.   FImageIndex := Value;
  517.   invalidate;
  518. end;
  519.  
  520. procedure TrmOutlookListBaseButton.ActionChange(Sender: TObject;
  521.   CheckDefaults: Boolean);
  522. begin
  523.   if Sender is TCustomAction then
  524.     with TCustomAction(Sender) do
  525.     begin
  526.       if not CheckDefaults or (Self.ButtonCaption = '') or (Self.ButtonCaption = Self.Name) then
  527.         Self.ButtonCaption := Caption;
  528.       if not CheckDefaults or (Self.Enabled = True) then
  529.         Self.Enabled := Enabled;
  530.       if not CheckDefaults or (Self.Hint = '') then
  531.         Self.Hint := Hint;
  532.       if not CheckDefaults or (Self.Visible = True) then
  533.         Self.Visible := Visible;
  534.       if not CheckDefaults or not Assigned(Self.OnClick) then
  535.         Self.OnClick := OnExecute;
  536.       Self.ImageIndex := ImageIndex;
  537.     end;
  538. end;
  539.  
  540. { TrmOutLookButtons }
  541.  
  542. function TrmOutLookButtons.Add: TrmOutlookListButton;
  543. begin
  544.   Result := TrmOutlookListButton(inherited Add);
  545. end;
  546.  
  547. constructor TrmOutLookButtons.Create(AOwner: TrmOutlookButtonList);
  548. begin
  549.   inherited Create(TrmOutlookListButton);
  550.   FOLBtnList := AOwner;
  551. end;
  552.  
  553. function TrmOutLookButtons.GetItem(Index: Integer): TrmOutlookListButton;
  554. begin
  555.   Result := TrmOutlookListButton(inherited GetItem(Index));
  556. end;
  557.  
  558. procedure TrmOutLookButtons.SetItem(Index: Integer;
  559.   Value: TrmOutlookListButton);
  560. begin
  561.   inherited SetItem(Index, Value);
  562. end;
  563.  
  564. { TrmOutlookListButton }
  565.  
  566. procedure TrmOutLookListButton.ClickButton(Sender: TObject);
  567. begin
  568.    if Assigned(TrmOutlookButtons(Collection).OLBtnList.FOnClickButton) then
  569.      TrmOutlookButtons(Collection).OLBtnList.FOnClickButton(TrmOutlookButtons(Collection).OLBtnList, Self)
  570.    else
  571.    begin
  572.      if assigned(Action) and assigned(Action.OnExecute) then
  573.      Action.OnExecute(Sender);
  574.    end;
  575. end;
  576.  
  577. constructor TrmOutLookListButton.Create(Collection: TCollection);
  578. begin
  579.   inherited Create(Collection);
  580.  
  581.   FButton := TrmOutlookListBaseButton.Create(nil);
  582.   FButton.OutLookButtonList := TrmOutlookButtons(Collection).OLBtnList;
  583.   FButton.Parent := TrmOutlookButtons(Collection).OLBtnList.FBasePanel;
  584.   FButton.OnClick := ClickButton;
  585.   TrmOutlookButtons(Collection).OLBtnList.RefreshButtons;
  586. end;
  587.  
  588. destructor TrmOutLookListButton.Destroy;
  589. begin
  590.   FButton.Free;
  591.   inherited Destroy;
  592. end;
  593.  
  594. function TrmOutlookListButton.GetAction: TBasicAction;
  595. begin
  596.    result := FButton.Action;
  597. end;
  598.  
  599. function TrmOutlookListButton.GetCaption: String;
  600. begin
  601.    result := FButton.ButtonCaption;
  602. end;
  603.  
  604. function TrmOutlookListButton.GetEnabled: boolean;
  605. begin
  606.    result := fButton.Enabled;  
  607. end;
  608.  
  609. function TrmOutlookListButton.GetHint: string;
  610. begin
  611.    result := FButton.Hint;  
  612. end;
  613.  
  614. function TrmOutlookListButton.GetImageIndex: Integer;
  615. begin
  616.    result := FButton.ImageIndex;  
  617. end;
  618.  
  619. function TrmOutlookListButton.GetShowHint: boolean;
  620. begin
  621.    result := FButton.ShowHint;
  622. end;
  623.  
  624. procedure TrmOutlookListButton.SetAction(const Value: TBasicAction);
  625. begin
  626.   FButton.Action := Value;
  627. end;
  628.  
  629. procedure TrmOutLookListButton.SetCaption(const Value: String);
  630. begin
  631.   FButton.ButtonCaption := Value;
  632. end;
  633.  
  634. procedure TrmOutlookListButton.SetEnabled(const Value: boolean);
  635. begin
  636.    fbutton.enabled := value;
  637. end;
  638.  
  639. procedure TrmOutlookListButton.SetHint(const Value: string);
  640. begin
  641.    fButton.Hint := value;
  642. end;
  643.  
  644. procedure TrmOutLookListButton.SetImageIndex(const Value: Integer);
  645. begin
  646.   FButton.ImageIndex := Value;
  647. end;
  648.  
  649. procedure TrmOutlookListButton.SetShowHint(const Value: boolean);
  650. begin
  651.    FButton.ShowHint := value;
  652. end;
  653.  
  654. { TrmOutlookButtonListPanel }
  655.  
  656. constructor TrmOutlookButtonListPanel.create(AOwner: TComponent);
  657. begin
  658.   inherited;
  659.   ControlStyle := ControlStyle - [csDesignInteractive];
  660. end;
  661.  
  662. procedure TrmOutLookButtonListPanel.EraseBK(var Message: TMessage);
  663. begin
  664.   Message.Result := 1;
  665. end;
  666.  
  667. procedure TrmOutLookButtonListPanel.Paint;
  668. begin
  669.   with Canvas do
  670.   begin
  671.     Brush.Color := Color;
  672.     Brush.Style := bsSolid;
  673.     FillRect(ClientRect);
  674.   end;
  675.   inherited;
  676. end;
  677.  
  678. { TrmOutlookActionLink }
  679.  
  680. procedure TrmOutlookActionLink.AddButtonsFromActionsInCategory(Category: String) ;
  681. var
  682.    i: integer;
  683.    InCategory: integer;
  684.    AOutLookButtonList: TrmOutLookButtonList;
  685.    AOutLookListButton: TrmOutLookListButton;
  686. begin
  687.    if not BothAssigned then
  688.       exit;
  689.  
  690.    InCategory := -1;
  691.  
  692.    for i := 0 to FOutlookControl.PageCount - 1 do
  693.    begin
  694.       if FOutlookControl.Pages[i].Caption = Category then
  695.          InCategory := i;
  696.    end;
  697.  
  698.    if Incategory <> -1 then
  699.    begin
  700.       AOutLookButtonList := TrmOutLookButtonList.Create(Owner) ;
  701.       AOutLookButtonList.Parent := FOutlookControl.Pages[inCategory];
  702.       AOutLookButtonList.Align := AlClient;
  703.       AOutLookButtonList.ViewStyle := FViewStyle;
  704.  
  705.       if FViewStyle = vsSmallIcons then
  706.          AOutLookButtonList.SmallImages := TImageList(FActionList.Images)
  707.       else
  708.          AOutLookButtonList.LargeImages := TImageList(FActionList.Images) ;
  709.  
  710.       for i := 0 to FActionList.ActionCount - 1 do
  711.       begin
  712.          if FActionList.Actions[i].Category = Category then
  713.          begin
  714.             AOutLookListButton := TrmOutLookListButton.Create(AOutLookButtonList.Buttons) ;
  715.             AOutLookListButton.Action := TAction(FActionList.Actions[i]) ;
  716.          end;
  717.       end;
  718.    end;
  719. end;
  720.  
  721. procedure TrmOutlookActionLink.AddPagesFromActionCategorys;
  722. var
  723.    i: integer;
  724.    UniqeCategorys: TStringList;
  725.    Page: TrmOutlookPage;
  726. begin
  727.    if not BothAssigned then
  728.       exit;
  729.  
  730.    Page := nil;
  731.  
  732.    UniqeCategorys := TStringList.Create;
  733.    try
  734.       UniqeCategorys.Sorted := true;
  735.       UniqeCategorys.Duplicates := dupIgnore;
  736.  
  737.       for i := 0 to ActionList.ActionCount - 1 do
  738.          UniqeCategorys.add(ActionList.Actions[i].Category) ;
  739.  
  740.       For i := 0 to UniqeCategorys.Count - 1 do
  741.       begin
  742.          Page := TrmOutlookPage.Create(Owner) ;
  743.          Page.Caption := UniqeCategorys.Strings[i];
  744.          Page.OutlookControl := FOutlookControl;
  745.          AddButtonsFromActionsInCategory(UniqeCategorys.Strings[i]) ;
  746.       end;
  747.  
  748.       if assigned(page) then
  749.          FOutlookControl.ActivePage := Page;
  750.  
  751.       FOutlookControl.Repaint;
  752.    finally
  753.       UniqeCategorys.Free;
  754.    end;
  755. end;
  756.  
  757. function TrmOutlookActionLink.BothAssigned: Boolean;
  758. begin
  759.    result := ((FActionList <> nil) and (FOutlookControl <> nil));
  760.    if not result then
  761.    begin
  762.       if FActionList = nil then
  763.          MessageDlg('An ActionList must be assigned', mtInformation, [mbok], 0);
  764.  
  765.       if FOutlookControl = nil then
  766.          MessageDlg('An rmOutlookControl must be assigned', mtInformation, [mbok], 0);
  767.    end;
  768. end;
  769.  
  770. procedure TrmOutlookActionLink.Notification(AComponent: TComponent;
  771.   Operation: TOperation);
  772. begin
  773.   inherited;
  774.   if Operation = opRemove then
  775.   begin
  776.      if (AComponent is TrmOutlookControl) and (AComponent = FOutlookControl) then
  777.         FOutlookControl := nil;
  778.  
  779.      if (AComponent is TActionList) and (AComponent = FActionList) then
  780.         FActionList := nil;
  781.   end;
  782. end;
  783.  
  784. procedure TrmOutlookActionLink.SetActionList(const Value: TActionList) ;
  785. begin
  786.    FActionList := Value;
  787.    if FActionList <> nil then
  788.       FActionList.FreeNotification(self);
  789. end;
  790.  
  791. procedure TrmOutlookActionLink.SetOutlookControl(const Value: TrmOutlookControl) ;
  792. begin
  793.    FOutlookControl := Value;
  794.    if FOutLookControl <> nil then
  795.       FOutlookControl.FreeNotification(self);
  796. end;
  797.  
  798. procedure TrmOutlookActionLink.SetViewStyle(const Value: TOLViewStyle) ;
  799. begin
  800.    FViewStyle := Value;
  801. end;
  802.  
  803. end.
  804.  
  805.  
  806.  
  807.