Programalama > DELPHI

unit Outlook;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons,ExtCtrls,FlatImage,StdCtrls,Spin,CommCtrl,Consts,DsgnIntf,
  OLITemsProp;

type
  TCntButton = TSpeedButton;
  TEventProc= Procedure (Sender: TObject; Item: string) of Object;

  TOutlook = class;
  TOutlookItems = class (TPersistent)
  private
    FHeaders : TStringList;
    FItems   : TList;
    FImages  : TList;
    AllImages : TImageList;
    Owner: TOutlook;
    function GetImage(HeaderIndex, ItemIndex: integer): TPicture;
    function GetItem(HeaderIndex, ItemIndex: integer): String;
    procedure SetImage(HeaderIndex, ItemIndex: integer;
      const Value: TPicture);
    procedure SetItem(HeaderIndex, ItemIndex: integer;
      const Value: String);
    function GetHeader(HeaderIndex: integer): string;
    procedure SetHeader(HeaderIndex: integer; const Value: string);
    function GetCounts(idx: integer): integer;
    Procedure SaveToImageList(IList: TImageList);
    Procedure LoadFromImageList(IList: TImageList);
    Procedure DefineProperties(Filer:TFiler);override;
    Procedure WriteHeaders(Writer:TWriter);
    Procedure ReadHeaders(Reader:TReader);
    Procedure WriteItems(Writer:TWriter);
    Procedure ReadItems(Reader:TReader);
    Procedure ReadImages(Stream: TStream);
    Procedure WriteImages(Stream:TStream);
  public
    Constructor Create(AOwner: TOutlook);
    Destructor Destroy;
    Procedure AssignContent(value : TOutlookItems);
    Procedure DeleteHeader(HeaderIndex: integer);
    Procedure DeleteItem(HeaderIndex,ItemIndex: integer);
    Procedure ExchangeHeader(idx1,idx2: integer);
    Procedure ExchangeItem(HeaderIdx,idx1,idx2: integer);
    Property Headers[HeaderIndex: integer]:string read GetHeader write SetHeader;
    Property Items[HeaderIndex,ItemIndex:integer]: String read GetItem write SetItem;
    Property Images[HeaderIndex,ItemIndex:integer]: TPicture read GetImage write SetImage;
    Property Counts[idx: integer]: integer read GetCounts;
  end;

  TOutlook = class(TScrollBox)
  private
    FItems : TOutlookItems;
    FItemCab : TScrollBox;
    CNTButs : TList;
    Panels  : TList;
    TempImages: TList;
    TempLabels: TList;
    FActiveTab: integer;
    SpinButton : TSpinButton;
    ScrollPanel: TPanel;
    FOnTabChange : TEventProc;
    FOnItemClick : TEventProc;
    procedure setActiveTab(const Value: integer);
    procedure WhenClick(Sender: TObject);
    Procedure ScrollDown(Sender: TObject);
    Procedure ScrollUp(Sender: TObject);
    function GetItems: TOutlookItems;
    procedure SetItems(const Value: TOutlookItems);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    { Private declarations }
  protected
    { Protected declarations }

  public
    { Public declarations }
    Procedure RefreshDisplay;
    Procedure RefreshItems;
  published
    { Published declarations }
    Constructor Create(AOwner : TComponent);override;
    Property Items: TOutlookItems read GetItems write SetItems;
    Property ActiveTab: integer read FActiveTab write setActiveTab;
    Property OnTabChange:TEventProc read FOnTabChange write FOnTabChange;
    Property OnItemClick:TEventProc read FOnItemClick write FOnItemClick;
  end;

procedure Register;

implementation

var startitem: integer;
    itemcount : integer;
    visibles  : integer;

procedure Register;
begin
  RegisterComponents('Samples', [TOutlook]);
  RegisterPropertyEditor (TypeInfo(TOutlookItems),
      TOutlook, 'Items', TOLITemsProperty);

end;

{ TOutlook }

constructor TOutlook.Create(AOwner: TComponent);
var BotPanel: TPanel;
begin
  inherited create(AOwner);
  Align := alLeft;
  Width := 110;
  CNTButs := TList.create;
  PAnels := TList.create;
  TempImages := TList.create;
  TempLabels := TList.create;
  Color := clGray;
  FActiveTAb := 0;
  StartItem := 1;
  FItemCab := TScrollBox.Create(self);
  FItemcab.parent := self;
  FItemCab.BorderStyle := bsNone;
  FItemCab.align := alClient;
  HorzScrollBar.Visible := false;
  VertScrollBar.Visible := false;
  FItemCab.HorzScrollBar.Visible := false;
  FItemCab.VertScrollBar.Visible := false;
  ScrollPanel := TPanel.create(self);
  ScrollPanel.align := alRight;
  ScrollPanel.Width := 14;
  ScrollPanel.bevelInner := bvNone;
  ScrollPanel.bevelOuter := bvNone;
  ScrollPanel.color := FitemCab.Color;
  BotPanel := TPanel.Create(self);
  BotPanel.Parent := ScrollPanel;
  BotPanel.Align := alBottom;
  BotPanel.Height := 45;
  BotPanel.BevelInner := bvNone;
  BotPanel.BevelOuter := bvNone;
  BotPanel.color := FitemCab.Color;
  SpinButton := TSpinButton.create(self);
  SpinButton.align := alClient;
  SpinButton.Parent := BotPanel;
  SpinButton.OnDownClick := ScrollDown;
  SpinButton.OnupClick := ScrollUp;

  FItems := TOutlookItems.Create(self);;

end;


function TOutlook.GetItems: TOutlookItems;
begin
  Result := FItems;
end;

procedure TOutlook.RefreshDisplay;
var a,b: integer;
    CNTButton : TCNtButton;
    Panel : TPanel;
    Image : TFlatImage;
    Labelx: TLabel;
begin

  try
    For a := 0 to CNTButs.Count -1 do
    begin
      TCNtButton(CNTButs[a]).Free;
    End;
    For a := 0 to Panels.Count -1 do
    begin
      TPanel(Panels[a]).Free;
    End;
  except
  end;

  TempImages.Clear;
  TempLabels.Clear;
  Panels.Clear;
  CNTButs.Clear;

  For a := 1 to Items.Counts[0] do
  begin
    CntButton := TCNtButton.create(self);
    CntButton.parent := self;
    CntButton.Font.Name := 'Tahoma';
    CntButton.Caption := Items.Headers[a];
    CNtButton.Align := alBottom;
    CNTButton.Visible := true;
    CNTButton.Tag := a;
    CNTButton.Height := 22;
    CNTButton.OnClick := WhenClick;
    CNTButs.add(CNTButton);
    For b := 1 to Items.Counts[a] do
    begin
      Panel := TPanel.Create(self);
      Panel.Tag := a;
      Panel.Height := 60;
      Panel.Width := FItemCab.width;
      Panel.Left := 0;
      Panel.Color := ClGray;
      Panel.BevelOuter := bvNone;
      Panel.BevelInner := bvNone;
      Panels.add(Panel);

      Image := TFlatImage.Create(self);
      Image.Parent := panel;
      Image.SetBounds((width-40) div 2,5,40,40);
      Image.StrValue := Items.Items[a,b];
      Image.OnClick := WhenClick;
      Image.Picture := Items.Images[a,b];
      TempImages.Add(Image);

      Labelx := TLabel.create(self);
      Labelx.Parent := Panel;
      Labelx.Top := 45;
      Labelx.Font.Name := 'Tahoma';
      Labelx.Font.Color := clWhite;
      LabelX.Caption := Items.Items[a,b];
      Labelx.Left := (width - labelx.width) div 2;
      TempLabels.Add(LabelX);
    end;
  end;
//  FActiveTab := 0;
//  startitem  := 1;
  RefreshItems;
end;

procedure TOutlook.RefreshItems;
var a,ItemHeight: integer;
begin
  If CNTButs.Count = 0 then exit;
  If FActiveTab > Items.Counts[0] then FActiveTab := 0;
  If FActiveTab = 0 then
  begin
    For a := 0 to CNTButs.count -1 do
    begin
      TCNTButton(CNTButs[a]).align := alBottom;
    end;
    exit;
  end;
  For a := 0 to FActiveTAb -1 do
  begin
    TCNTButton(CNTButs[a]).align := alTop;
  end;
  For a := 1 to CNTButs.count - FactiveTab do
  begin
    TCNTButton(CNTButs[CNTButs.count-a]).align := alBottom;
  end;

  itemcount := 0;
  visibles := 0;

  ItemHeight := Height - (CNTButs.count*TCNTButton(CNTButs[0]).Height);

  For a := 0 to Panels.count -1 do
  begin
    if TPanel(Panels[a]).tag = FActiveTab then
    begin
      inc(itemcount);
      if ((itemcount-startitem+1)*60 < ItemHeight) and
         (itemcount >= startitem) then
      begin
        inc(visibles);
        TPanel(Panels[a]).parent := FItemCab;
        TPanel(Panels[a]).top := (visibles-1)*60;
      end
      else
        TPanel(Panels[a]).parent := nil;
    end
    else
    begin
      TPanel(Panels[a]).parent := nil;
    end;
  end;
    if (itemcount*60 > ItemHeight)
    then
      ScrollPanel.Parent := Self
    else
      ScrollPanel.parent := nil;
end;


procedure TOutlook.ScrollDown(Sender: TObject);
begin
  If StartItem > 1 then
  begin
    StartItem := StartItem-1;
    RefreshItems;
  end;
end;

procedure TOutlook.ScrollUp(Sender: TObject);
begin
  If StartItem <= (ItemCount-visibles) then
  begin
    StartItem := StartItem+1;
    RefreshItems;
  end;
end;

procedure TOutlook.setActiveTab(const Value: integer);
begin
  if (value > CNTButs.count) then exit;
  FActiveTab := Value;
  StartItem := 1;
  RefreshItems;
end;

procedure TOutlook.SetItems(const Value: TOutlookItems);
begin
  FItems.AssignContent(Value);
end;

procedure TOutlook.WhenClick(Sender: TObject);
begin
  If Sender is TCNTButton then
  begin
    ActiveTab := (Sender as TCNTButton).Tag;
    if assigned(FOnTabChange) then FOnTabChange(Self,(Sender as TCNTButton).caption);
  end
  else if Sender is TFlatImage then
  begin
    if assigned(FOnItemClick) then FOnItemClick(Self,(Sender as TFlatImage).StrValue);
  end;
end;

procedure TOutlook.WMSize(var Message: TWMSize);
var a: integer;
begin
   For a := 0 to Panels.count -1 do
     TPanel(Panels[a]).Width := FItemCab.width;
   For a := 0 to TempImages.count -1 do
     TImage(TempImages[a]).Left := (width-40) div 2;
   For a := 0 to TempLabels.count -1 do
     TLabel(TempLabels[a]).Left :=
            (width - TLabel(TempLabels[a]).width) div 2;
  RefreshItems;
end;

{ TOutlookItems }

constructor TOutlookItems.create(AOwner: TOutLook);
var a,b : integer;
begin
  Inherited Create;
  Owner := AOwner;
  FHeaders := TStringList.Create;
  FItems := TList.Create;
  FImages:= TList.Create;
  AllImages := TImageList.Create(nil);
  AllImages.Height := 32;
  AllImages.Width := 32;
end;

procedure TOutlookItems.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('Headers',ReadHeaders,WriteHeaders,True);
  Filer.DefineProperty('Contents',ReadItems,WriteItems,True);
  Filer.DefineBinaryProperty('Images', ReadImages, WriteImages,True);
end;

destructor TOutlookItems.destroy;
var a,b : integer;
begin
  FHeaders.Free;
  FItems.Free;
  FImages.Free;
  AllImages.Free;
  Inherited Destroy;
end;

function TOutlookItems.GetCounts(idx: integer): integer;
begin
  result := 0;
  if idx = 0 then
    result := FHeaders.Count
  else
  begin
    if Idx > FHeaders.Count then
      result := 0
    else
      result := TstringList(FItems[idx-1]).count;
  end;
end;

function TOutlookItems.GetHeader(HeaderIndex: integer): string;
begin
  If (HeaderIndex > FHeaders.Count) or (HeaderIndex = 0) then
    result := ''
  else
    result := FHeaders[HeaderIndex-1];
end;

function TOutlookItems.GetImage(HeaderIndex, ItemIndex: integer): TPicture;
var List : TList;
    Pict : TPicture;
begin
  If (HeaderIndex > FHeaders.Count) or (HeaderIndex = 0) then
  begin
    result := nil;
  end
  else
  begin
    List := TList(FImages[HeaderIndex-1]);
    if (ItemIndex > List.Count) or (ItemIndex =0) then
      result := nil
    else
      Result := TPicture(List[ItemIndex-1]);
  end;
end;

function TOutlookItems.GetItem(HeaderIndex, ItemIndex: integer): String;
var List : TStringlIst;
begin
  If (HeaderIndex > FHeaders.Count) or (HeaderIndex = 0) then
  begin
    result := '';
  end
  else
  begin
    List := TStringList(FItems[HeaderIndex-1]);
    if (ItemIndex > List.Count) or (ItemIndex =0) then
      result := ''
    else
      Result := List[ItemIndex-1];
  end;

end;

procedure TOutlookItems.LoadFromImageList(IList: TImageList);
var a,b,x: integer;
    Picture : TPicture;
begin
  x := 0;
  For a := 1 to Counts[0] do
  begin
    TList(FImages[a-1]).Clear;
    For b:= 1 to Counts[a] do
    begin
      Picture := TPicture.Create;
      IList.GetIcon(x,Picture.Icon);
      TList(FImages[a-1]).Add(Picture);
      inc(x);
    end;
  end;

end;

procedure TOutlookItems.AssignContent(value: TOutlookItems);
begin
  FHeaders := Value.FHeaders;
  FItems := Value.FItems;
  FImages := Value.FImages;
end;

procedure TOutlookItems.ReadHeaders(Reader: TReader);
var a: integer;
begin
  FHeaders.Text := Reader.ReadString;
  For a := 0 to FHeaders.Count -1 do
  begin
    FItems.Add(TStringList.Create);
    FImages.Add(TList.Create);
  end;
end;

procedure TOutlookItems.ReadItems(Reader: TReader);
var TotalItems,list: TStringList;
    a,x: integer;
begin
  TotalItems := TstringList.Create;
  TotalItems.Text := Reader.ReadString;
  x := 0;
  List := Nil;
  For a := 0 to TotalItems.Count- 1 do
  begin
    if inttostr(x) = TotalItems[a] then
    begin
      List := TstringList(FItems[x]);
      x := x+1;
    end
    else
    begin
      If List <> nil then List.Add(TotalItems[a]);
    end;
  end;
end;

procedure TOutlookItems.ReadImages(Stream: TStream);
var
  SA: TStreamAdapter;
begin
  SA := TStreamAdapter.Create(Stream);
  try
    AllImages.Handle := ImageList_Read(SA);
    if AllImages.Handle = 0 then
      raise EReadError.Create(SImageReadFail);
    LoadFromImageList(AllImages);
  finally
    SA.Free;
  end;
  If owner <> nil then Owner.RefreshDisplay;
end;


procedure TOutlookItems.SaveToImageList(IList: TImageList);
Var
  a,b: integer;
  Picture: TPicture;
Begin
  For a := 1 to Counts[0] do
  begin
    For b:= 1 to Counts[a] do
    begin
      Picture := Images[a,b];
      IList.AddIcon(Picture.Icon)
    end;
  end;
end;

procedure TOutlookItems.SetHeader(HeaderIndex: integer;
  const Value: string);
var a,dif : integer;
begin
  If HeaderIndex = 0 then exit;
  Dif := HeaderIndex-FHeaders.Count;
  If (HeaderIndex > FHeaders.Count) then
  begin
    for a := 1 to dif do
    begin
      FHeaders.Add('');
      FItems.Add(TStringList.Create());
      FImages.Add(TList.Create());
    end;
  end;
  FHeaders[HeaderIndex -1] := value;
end;

procedure TOutlookItems.SetImage(HeaderIndex, ItemIndex: integer;
  const Value: TPicture);
var List : TlIst;
begin
  If (HeaderIndex > FHeaders.Count) or (HeaderIndex = 0) then
    exit
  else
  begin
    List := TList(FImages[HeaderIndex-1]);
    if (ItemIndex > List.Count) or (ItemIndex =0) then
      exit
    else
      List[ItemIndex-1] := Value;
  end;
end;

procedure TOutlookItems.SetItem(HeaderIndex, ItemIndex: integer;
  const Value: String);
var List : TStringlIst;
    a,dif : integer;
begin
  If (HeaderIndex > FHeaders.Count) or (HeaderIndex = 0) then
  begin
    exit;
  end
  else
  begin
    List := TStringList(FItems[HeaderIndex-1]);
    if ItemIndex = 0 then exit;
    Dif := ItemIndex - List.Count;
    if (ItemIndex > List.Count)then
    begin
      for a := 1 to dif do
      begin
        List.Add('');
        TList(FImages[HeaderIndex-1]).Add(TPicture.Create);
      end;
    end;
    List[ItemIndex-1] := Value;
  end;
end;

procedure TOutlookItems.WriteHeaders(Writer: TWriter);
begin
  Writer.WriteString(FHeaders.Text);
end;

procedure TOutlookItems.WriteImages(Stream: TStream);
var
  SA: TStreamAdapter;
begin
  SA := TStreamAdapter.Create(Stream);
  AllImages.Clear;
  SaveToImageList(AllImages);
  try
    if not ImageList_Write(AllImages.Handle, SA) then
      raise EWriteError.Create(SImageWriteFail);
  finally
    SA.Free;
  end;
end;

procedure TOutlookItems.WriteItems(Writer: TWriter);
var TotalItems,List: TstringList;
    a,b : integer;
begin
  TotalItems := TstringList.Create;
  For a := 0 to FHeaders.Count -1 do
  begin
     TotalItems.Add(inttostr(a));
     List := TStringList(FItems[a]);
     For b := 0 to List.Count -1 do
       TotalItems.Add(List[b]);
  end;
  Writer.WriteString(TotalItems.Text);
  TotalItems.Free;
end;


procedure TOutlookItems.DeleteHeader(HeaderIndex: integer);
begin
  If (HeaderIndex > FHeaders.Count) or (HeaderIndex = 0) then exit;
  FHeaders.Delete(HeaderIndex-1);
  TStringList(FItems[HeaderIndex-1]).Destroy;
  FItems.Delete(HeaderIndex-1);
  TList(FImages[HeaderIndex-1]).Destroy;
  FImages.Delete(HeaderIndex-1);
end;

procedure TOutlookItems.DeleteItem(HeaderIndex, ItemIndex: integer);
begin
  If (HeaderIndex > FHeaders.Count) or (HeaderIndex = 0) then exit;
  TStringList(FItems[HeaderIndex-1]).Delete(ItemIndex-1);
  TList(FImages[HeaderIndex-1]).Delete(ItemIndex-1);
end;

procedure TOutlookItems.ExchangeHeader(idx1, idx2: integer);
begin
  If (idx1 = 0) or (idx2 = 0) then exit;
  if (idx1 > Fheaders.Count) or (idx2 > Fheaders.Count) then exit;
  FHeaders.Exchange(idx1-1,idx2-1);
  FItems.Exchange(idx1-1,idx2-1);
  FImages.Exchange(idx1-1,idx2-1);
end;

procedure TOutlookItems.ExchangeItem(HeaderIdx, idx1, idx2: integer);
begin
  if (HeaderIdx = 0) or (idx1=0) or (idx2=0) then exit;
  if HeaderIdx > counts[0] then exit;
  if (idx1 > Counts[HeaderIdx]) or
     (idx2 > Counts[HeaderIdx]) then exit;
  TstringList(FItems[HeaderIdx-1]).Exchange(idx1-1,idx2-1);
  TList(FImages[HeaderIdx-1]).Exchange(idx1-1,idx2-1);
end;

end.