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 >
Wrap
Pascal/Delphi Source File
|
2001-06-22
|
23KB
|
807 lines
{================================================================================
Copyright (C) 1997-2001 Mills Enterprise
Unit : rmOutlookExtras
Purpose : A simple implementation of the M$ Outlook style buttons components
Date : 03-07-01
Author : Ryan J. Mills
Version : 1.80
Notes : This unit was originally based upon the work of Patrick O'Keeffe.
It was at his request that I took the component over and rm'ified it.
06-03-01: The TrmOutlookActionLink component was originally written
by Piotr Jurago of Poland. He sent the code back to me and I've
included it here.
================================================================================}
unit rmOutLookExtras;
interface
{$I CompilerDefines.INC}
uses windows, messages, ActnList, controls, classes, rmSpeedBtns, rmOutlook, imglist;
type
TrmOutLookButtonList = class;
TrmOutlookListButton = class;
TOLButtonStyle = (olbsLarge, olbsSmall);
TOLViewStyle = (vsSmallIcons, vsLargeIcons);
TOLButtonClickEvent = procedure(Sender : TObject; Button : TrmOutlookListButton) of Object;
TrmOutlookListBaseButton = class(TrmSpeedButton)
private
FOutLookButtonList : TrmOutlookButtonList;
FMouseInControl : Boolean;
FCaption: String;
FButtonStyle: TOLButtonStyle;
FImageIndex: Integer;
procedure CMMouseEnter(var Message : TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message : TMessage); message CM_MOUSELEAVE;
procedure SetrmOutlookButtons(Value : TrmOutlookButtonList);
procedure SetCaption(const Value: String);
procedure SetButtonStyle(const Value: TOLButtonStyle);
procedure SetImageIndex(const Value: Integer);
protected
{ Protected Declarations }
procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
procedure EraseBK(var Message : TMessage); message WM_ERASEBKGND;
procedure Paint; override;
public
{ Public Declarations }
constructor create(AOwner:TComponent); override;
property ImageIndex : Integer read FImageIndex write SetImageIndex;
property OutLookButtonList : TrmOutlookButtonList read FOutLookButtonList write SeTrmOutlookButtons;
property ButtonStyle : TOLButtonStyle read FButtonStyle write SetButtonStyle;
property ButtonCaption : String read FCaption write SetCaption;
end;
TrmOutlookListButton = class(TCollectionItem)
private
FButton : TrmOutlookListBaseButton;
FData: Pointer;
procedure ClickButton(Sender : TObject);
function GetImageIndex: Integer;
function GetCaption: String;
function GetAction: TBasicAction;
procedure SetImageIndex(const Value: Integer);
procedure SetCaption(const Value: String);
procedure SetAction(const Value: TBasicAction);
function GetEnabled: boolean;
procedure SetEnabled(const Value: boolean);
function GetHint: string;
procedure SetHint(const Value: string);
function GetShowHint: boolean;
procedure SetShowHint(const Value: boolean);
public
constructor Create(Collection : TCollection); override;
destructor Destroy; override;
property Data : Pointer read FData write FData;
published
property Action: TBasicAction read GetAction write SetAction;
property ImageIndex : Integer read GetImageIndex write SetImageIndex;
property Enabled : boolean read GetEnabled write SetEnabled;
property Hint:string read GetHint write SetHint;
property Caption : String read GetCaption write SetCaption;
property ShowHint : boolean read GetShowHint write SetShowHint;
end;
TrmOutlookButtons = class(TCollection)
private
FOLBtnList: TrmOutlookButtonList;
function GetItem(Index: Integer): TrmOutlookListButton;
procedure SetItem(Index: Integer; Value: TrmOutlookListButton);
public
function Add: TrmOutlookListButton;
constructor Create(AOwner: TrmOutlookButtonList);
property Items[Index: Integer]: TrmOutlookListButton read GetItem write SetItem; default;
property OLBtnList: TrmOutlookButtonList read FOLBtnList;
end;
TrmOutlookButtonListPanel = class(TCustomControl)
protected
procedure Paint; override;
procedure EraseBK(var Message : TMessage); message WM_ERASEBKGND;
public
constructor create(AOwner:TComponent); override;
end;
TrmOutlookButtonList = class(TCustomControl)
private
FButtons : TrmOutlookButtons;
FUpButton : TrmTimerSpeedButton;
FDownButton : TrmTimerSpeedButton;
FBasePanel : TrmOutlookButtonListPanel;
FLargeImages : TImageList;
FSmallImages: TImageList;
FImageChangeLink : TChangeLink;
FViewStyle: TOLViewStyle;
FTopButton: Integer;
FOnClickButton: TOLButtonClickEvent;
procedure GoUp(Sender : TObject);
procedure GoDown(Sender : TObject);
procedure CMDialogKey(var Message : TCMDialogKey); message CM_DIALOGKEY;
procedure SetLargeImages(Value : TImageList);
procedure ImageListChange(Sender : TObject);
procedure SetViewStyle(const Value: TOLViewStyle);
procedure SetTopButton(const Value: Integer);
procedure SetSmallImages(const Value: TImageList);
protected
procedure Loaded; override;
procedure WMSize(var Message : TMessage); message WM_SIZE;
procedure RefreshButtons;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
published
property Align;
property PopUpMenu;
property Buttons : TrmOutlookButtons read FButtons write FButtons;
property LargeImages : TImageList read FLargeImages write SetLargeImages;
property SmallImages : TImageList read FSmallImages write SetSmallImages;
property ShowHint;
property ViewStyle : TOLViewStyle read FViewStyle write SetViewStyle;
property TopButton : Integer read FTopButton write SetTopButton;
property OnClickButton : TOLButtonClickEvent read FOnClickButton write FOnClickButton;
end;
TrmOutlookActionLink = class(TComponent)
private
{ Private declarations }
FViewStyle: TOLViewStyle;
FActionList: TActionList;
FOutlookControl: TrmOutlookControl;
function BothAssigned: Boolean;
procedure SetActionList(const Value: TActionList) ;
procedure SetOutlookControl(const Value: TrmOutlookControl) ;
procedure SetViewStyle(const Value: TOLViewStyle) ;
protected
{ Protected }
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
{ Public declarations }
procedure AddPagesFromActionCategorys;
procedure AddButtonsFromActionsInCategory(Category: String) ;
published
{ Published declarations }
property ViewStyle: TOLViewStyle read FViewStyle write SetViewStyle;
property ActionList: TActionList read FActionList write SetActionList;
property OutlookControl: TrmOutlookControl read FOutlookControl write SetOutlookControl;
end;
implementation
uses graphics, ExtCtrls, Dialogs, rmLibrary;
{ TrmOutlookButtonList }
constructor TrmOutlookButtonList.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
Caption := '';
Color := clGray;
ControlStyle := [csDoubleClicks];
FBasePanel := TrmOutlookButtonListPanel.Create(Self);
FBasePanel.Parent := Self;
FUpButton := TrmTimerSpeedButton.Create(Self);
FUpButton.Parent := Self;
FUpButton.Width := 17;
FUpButton.Height := 17;
FUpButton.OnClick := GoUp;
FUpButton.Font.Name := 'Marlett';
FUpButton.Font.size := 10;
FUpButton.Caption := '5';
FUpButton.TimeBtnState := [tbAllowTimer];
FDownButton := TrmTimerSpeedButton.Create(Self);
FDownButton.Parent := Self;
FDownButton.Width := 17;
FDownButton.Height := 17;
FDownButton.OnClick := GoDown;
FDownButton.Font.Name := 'Marlett';
FDownButton.Font.size := 10;
FDownButton.Caption := '6';
FDownButton.TimeBtnState := [tbAllowTimer];
FButtons := TrmOutlookButtons.Create(Self);
FImageChangeLink := TChangeLink.Create;
FImageChangeLink.OnChange := ImageListChange;
Height := 200;
Width := 150;
end;
destructor TrmOutlookButtonList.Destroy;
begin
FButtons.Free;
FImageChangeLink.Free;
FUpButton.Free;
FDownButton.Free;
inherited Destroy;
end;
procedure TrmOutlookButtonList.ImageListChange(Sender : TObject);
begin
Invalidate;
end;
procedure TrmOutlookButtonList.Loaded;
begin
inherited;
RefreshButtons;
end;
procedure TrmOutlookButtonList.WMSize(var Message : TMessage);
begin
inherited;
RefreshButtons;
end;
procedure TrmOutlookButtonList.CMDialogKey(var Message : TCMDialogKey);
begin
if (Message.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then
begin
Message.Result := 1;
end
else
inherited;
end;
procedure TrmOutlookButtonList.SetLargeImages(Value : TImageList);
begin
if FLargeImages <> nil then
FLargeImages.UnRegisterChanges(FImageChangeLink);
FLargeImages := Value;
if FLargeImages <> nil then
begin
FLargeImages.RegisterChanges(FImageChangeLink);
FLargeImages.FreeNotification(Self);
end;
Invalidate;
end;
procedure TrmOutlookButtonList.SetSmallImages(const Value: TImageList);
begin
if FSmallImages <> nil then
FSmallImages.UnRegisterChanges(FImageChangeLink);
FSmallImages := Value;
if FSmallImages <> nil then
begin
FSmallImages.RegisterChanges(FImageChangeLink);
FSmallImages.FreeNotification(Self);
end;
Invalidate;
end;
procedure TrmOutlookButtonList.RefreshButtons;
var
loop : Integer;
TotalHeight : Integer;
wBtnHeight : integer;
wTop : integer;
wBtnStyle : TOLButtonStyle;
begin
if csLoading in ComponentState then
Exit;
FUpButton.Visible := False;
FUpButton.Top := 5;
FUpButton.Left := Width - 16 - 5;
FDownButton.Visible := False;
FDownButton.Top := Height - 16 - 5;
FDownButton.Left := Width - 16 - 5;
FBasePanel.Left := 10;
FBasePanel.Top := 10;
FBasePanel.Width := ClientWidth - 36;
FBasePanel.Height := ClientHeight - 20;
if FViewStyle = vsSmallIcons then
begin
wBtnHeight := 25;
wBtnStyle := olbsSmall;
end
else
begin
wBtnHeight := 65;
wBtnStyle := olbsLarge;
end;
TotalHeight := FButtons.Count * wBtnHeight;
if TotalHeight > FBasePanel.Height then
wTop := -(FTopButton * wBtnHeight)
else
wTop := 0;
for loop := 0 to FButtons.Count - 1 do
begin
FButtons.Items[loop].FButton.ButtonStyle := wBtnStyle;
FButtons.Items[loop].FButton.Width := FBasePanel.ClientWidth;
FButtons.Items[loop].FButton.Height := wBtnHeight;
FButtons.Items[loop].FButton.Top := wTop;
FButtons.Items[loop].FButton.Left := 0;
inc(wTop, wBtnHeight);
end;
FUpButton.Visible := (FTopButton > 0);
FDownButton.Visible := (((FButtons.Count - FTopButton) * wBtnHeight) > FBasePanel.ClientHeight);
Repaint;
end;
procedure TrmOutlookButtonList.SetViewStyle(const Value: TOLViewStyle);
begin
FViewStyle := Value;
RefreshButtons;
end;
procedure TrmOutlookButtonList.SetTopButton(const Value: Integer);
begin
FTopButton := Value;
RefreshButtons;
end;
procedure TrmOutlookButtonList.GoDown(Sender : TObject);
begin
if FDownButton.visible then
begin
FTopButton := FTopButton + 1;
RefreshButtons;
end;
end;
procedure TrmOutlookButtonList.GoUp(Sender : TObject);
begin
if FUpButton.visible then
begin
FTopButton := FTopButton - 1;
RefreshButtons;
end;
end;
procedure TrmOutlookButtonList.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then
begin
if AComponent = FLargeImages then
fLargeImages := nil;
if AComponent = FSmallImages then
FSmallImages := nil;
end;
end;
{ TrmOutlookListBaseButton }
procedure TrmOutlookListBaseButton.SeTrmOutlookButtons(Value : TrmOutlookButtonList);
begin
if FOutLookButtonList <> value then
FOutLookButtonList := Value;
end;
procedure TrmOutlookListBaseButton.CMMouseEnter(var Message : TMessage);
begin
inherited;
if not FMouseInControl and Enabled then
begin
FMouseInControl := True;
Invalidate;
end;
end;
procedure TrmOutLookListBaseButton.CMMouseLeave(var Message : TMessage);
begin
inherited;
if FMouseInControl and Enabled then
begin
FMouseInControl := False;
Invalidate;
end;
end;
procedure TrmOutLookListBaseButton.Paint;
var
wButtonRect : TRect;
wTextRect : TRect;
wDrawFlags : integer;
wTopColor, wBottomColor : TColor;
wImageList : TImageList;
begin
//paint the frame..
if FOutLookButtonList <> nil then
Canvas.Brush.Color := FOutLookButtonList.Color
else
Canvas.Brush.Color := clAppWorkspace;
Canvas.FillRect(Rect(0, 0, Width, Height));
wImageList := nil;
wDrawFlags := DT_SINGLELINE or DT_END_ELLIPSIS;
case FButtonStyle of
olbsLarge :
begin
wImageList := FOutLookButtonList.FLargeImages;
wButtonRect := Rect((Width div 2) - 18, 0, (Width div 2) + 18, 36);
wTextRect := Rect(0, wButtonRect.Bottom + 3, Width, Height);
wDrawFlags := wDrawFlags or DT_CENTER;
end;
olbsSmall :
begin
wImageList := FOutLookButtonList.FSmallImages;
wButtonRect := Rect(0, 0, 20, 20);
wTextRect := Rect(wButtonRect.Right + 4, 0, Width, wButtonRect.Bottom);
wDrawFlags := wDrawFlags or DT_VCENTER;
end;
end;
if FMouseInControl then
begin
if FState in [bsDown] then
begin
//the button is pushed...
wTopColor := cl3dDkShadow;
wBottomColor := cl3DLight;
end
else
begin
wTopColor := cl3DLight;
wBottomColor := cl3dDkShadow;
end;
Frame3d(Canvas, wButtonRect, wTopColor, wBottomColor, 1);
if (FState in [bsDown]) then
OffsetRect(wButtonRect, 1, 1);
end
else
InflateRect(wButtonRect, -1, -1);
if (wImageList <> nil) and (FImageIndex > -1) then
begin
if assigned(parent) and (csdesigning in Parent.ComponentState) then
wImageList.Draw(Canvas, wButtonRect.Left + 1, wButtonRect.Top + 1, FImageIndex)
else
wImageList.Draw(Canvas, wButtonRect.Left + 1, wButtonRect.Top + 1, FImageIndex, self.enabled)
end;
Canvas.Font.Color := clCaptionText;
Canvas.Brush.Color := clAppWorkspace;
DrawTextEx(Canvas.Handle, PCHar(FCaption), Length(FCaption), wTextRect, wDrawFlags, nil);
end;
procedure TrmOutLookListBaseButton.EraseBK(var Message: TMessage);
begin
Message.Result := 1;
end;
procedure TrmOutLookListBaseButton.SetCaption(const Value: String);
begin
FCaption := Value;
Invalidate;
end;
procedure TrmOutLookListBaseButton.SetButtonStyle(
const Value: TOLButtonStyle);
begin
FButtonStyle := Value;
Invalidate;
end;
constructor TrmOutlookListBaseButton.create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle - [csDesignInteractive];
end;
procedure TrmOutlookListBaseButton.SetImageIndex(const Value: Integer);
begin
FImageIndex := Value;
invalidate;
end;
procedure TrmOutlookListBaseButton.ActionChange(Sender: TObject;
CheckDefaults: Boolean);
begin
if Sender is TCustomAction then
with TCustomAction(Sender) do
begin
if not CheckDefaults or (Self.ButtonCaption = '') or (Self.ButtonCaption = Self.Name) then
Self.ButtonCaption := 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.OnClick := OnExecute;
Self.ImageIndex := ImageIndex;
end;
end;
{ TrmOutLookButtons }
function TrmOutLookButtons.Add: TrmOutlookListButton;
begin
Result := TrmOutlookListButton(inherited Add);
end;
constructor TrmOutLookButtons.Create(AOwner: TrmOutlookButtonList);
begin
inherited Create(TrmOutlookListButton);
FOLBtnList := AOwner;
end;
function TrmOutLookButtons.GetItem(Index: Integer): TrmOutlookListButton;
begin
Result := TrmOutlookListButton(inherited GetItem(Index));
end;
procedure TrmOutLookButtons.SetItem(Index: Integer;
Value: TrmOutlookListButton);
begin
inherited SetItem(Index, Value);
end;
{ TrmOutlookListButton }
procedure TrmOutLookListButton.ClickButton(Sender: TObject);
begin
if Assigned(TrmOutlookButtons(Collection).OLBtnList.FOnClickButton) then
TrmOutlookButtons(Collection).OLBtnList.FOnClickButton(TrmOutlookButtons(Collection).OLBtnList, Self)
else
begin
if assigned(Action) and assigned(Action.OnExecute) then
Action.OnExecute(Sender);
end;
end;
constructor TrmOutLookListButton.Create(Collection: TCollection);
begin
inherited Create(Collection);
FButton := TrmOutlookListBaseButton.Create(nil);
FButton.OutLookButtonList := TrmOutlookButtons(Collection).OLBtnList;
FButton.Parent := TrmOutlookButtons(Collection).OLBtnList.FBasePanel;
FButton.OnClick := ClickButton;
TrmOutlookButtons(Collection).OLBtnList.RefreshButtons;
end;
destructor TrmOutLookListButton.Destroy;
begin
FButton.Free;
inherited Destroy;
end;
function TrmOutlookListButton.GetAction: TBasicAction;
begin
result := FButton.Action;
end;
function TrmOutlookListButton.GetCaption: String;
begin
result := FButton.ButtonCaption;
end;
function TrmOutlookListButton.GetEnabled: boolean;
begin
result := fButton.Enabled;
end;
function TrmOutlookListButton.GetHint: string;
begin
result := FButton.Hint;
end;
function TrmOutlookListButton.GetImageIndex: Integer;
begin
result := FButton.ImageIndex;
end;
function TrmOutlookListButton.GetShowHint: boolean;
begin
result := FButton.ShowHint;
end;
procedure TrmOutlookListButton.SetAction(const Value: TBasicAction);
begin
FButton.Action := Value;
end;
procedure TrmOutLookListButton.SetCaption(const Value: String);
begin
FButton.ButtonCaption := Value;
end;
procedure TrmOutlookListButton.SetEnabled(const Value: boolean);
begin
fbutton.enabled := value;
end;
procedure TrmOutlookListButton.SetHint(const Value: string);
begin
fButton.Hint := value;
end;
procedure TrmOutLookListButton.SetImageIndex(const Value: Integer);
begin
FButton.ImageIndex := Value;
end;
procedure TrmOutlookListButton.SetShowHint(const Value: boolean);
begin
FButton.ShowHint := value;
end;
{ TrmOutlookButtonListPanel }
constructor TrmOutlookButtonListPanel.create(AOwner: TComponent);
begin
inherited;
ControlStyle := ControlStyle - [csDesignInteractive];
end;
procedure TrmOutLookButtonListPanel.EraseBK(var Message: TMessage);
begin
Message.Result := 1;
end;
procedure TrmOutLookButtonListPanel.Paint;
begin
with Canvas do
begin
Brush.Color := Color;
Brush.Style := bsSolid;
FillRect(ClientRect);
end;
inherited;
end;
{ TrmOutlookActionLink }
procedure TrmOutlookActionLink.AddButtonsFromActionsInCategory(Category: String) ;
var
i: integer;
InCategory: integer;
AOutLookButtonList: TrmOutLookButtonList;
AOutLookListButton: TrmOutLookListButton;
begin
if not BothAssigned then
exit;
InCategory := -1;
for i := 0 to FOutlookControl.PageCount - 1 do
begin
if FOutlookControl.Pages[i].Caption = Category then
InCategory := i;
end;
if Incategory <> -1 then
begin
AOutLookButtonList := TrmOutLookButtonList.Create(Owner) ;
AOutLookButtonList.Parent := FOutlookControl.Pages[inCategory];
AOutLookButtonList.Align := AlClient;
AOutLookButtonList.ViewStyle := FViewStyle;
if FViewStyle = vsSmallIcons then
AOutLookButtonList.SmallImages := TImageList(FActionList.Images)
else
AOutLookButtonList.LargeImages := TImageList(FActionList.Images) ;
for i := 0 to FActionList.ActionCount - 1 do
begin
if FActionList.Actions[i].Category = Category then
begin
AOutLookListButton := TrmOutLookListButton.Create(AOutLookButtonList.Buttons) ;
AOutLookListButton.Action := TAction(FActionList.Actions[i]) ;
end;
end;
end;
end;
procedure TrmOutlookActionLink.AddPagesFromActionCategorys;
var
i: integer;
UniqeCategorys: TStringList;
Page: TrmOutlookPage;
begin
if not BothAssigned then
exit;
Page := nil;
UniqeCategorys := TStringList.Create;
try
UniqeCategorys.Sorted := true;
UniqeCategorys.Duplicates := dupIgnore;
for i := 0 to ActionList.ActionCount - 1 do
UniqeCategorys.add(ActionList.Actions[i].Category) ;
For i := 0 to UniqeCategorys.Count - 1 do
begin
Page := TrmOutlookPage.Create(Owner) ;
Page.Caption := UniqeCategorys.Strings[i];
Page.OutlookControl := FOutlookControl;
AddButtonsFromActionsInCategory(UniqeCategorys.Strings[i]) ;
end;
if assigned(page) then
FOutlookControl.ActivePage := Page;
FOutlookControl.Repaint;
finally
UniqeCategorys.Free;
end;
end;
function TrmOutlookActionLink.BothAssigned: Boolean;
begin
result := ((FActionList <> nil) and (FOutlookControl <> nil));
if not result then
begin
if FActionList = nil then
MessageDlg('An ActionList must be assigned', mtInformation, [mbok], 0);
if FOutlookControl = nil then
MessageDlg('An rmOutlookControl must be assigned', mtInformation, [mbok], 0);
end;
end;
procedure TrmOutlookActionLink.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if Operation = opRemove then
begin
if (AComponent is TrmOutlookControl) and (AComponent = FOutlookControl) then
FOutlookControl := nil;
if (AComponent is TActionList) and (AComponent = FActionList) then
FActionList := nil;
end;
end;
procedure TrmOutlookActionLink.SetActionList(const Value: TActionList) ;
begin
FActionList := Value;
if FActionList <> nil then
FActionList.FreeNotification(self);
end;
procedure TrmOutlookActionLink.SetOutlookControl(const Value: TrmOutlookControl) ;
begin
FOutlookControl := Value;
if FOutLookControl <> nil then
FOutlookControl.FreeNotification(self);
end;
procedure TrmOutlookActionLink.SetViewStyle(const Value: TOLViewStyle) ;
begin
FViewStyle := Value;
end;
end.