Thema: Delphi Problem mit Vererbung

Einzelnen Beitrag anzeigen

Benutzerbild von xZise
xZise

Registriert seit: 3. Mär 2006
Ort: Waldbronn
4.303 Beiträge
 
Delphi 2009 Professional
 
#16

Re: Problem mit Vererbung

  Alt 2. Okt 2007, 23:08
Okay hier mal der Code Ich habe unwichtiges soweit ein bisschen entfernt.
Der aufruf (s.o.) erfolg weiterhin mit:
<TTabs>.Add(<TExplorer/TMemoTab>.Create(<PageControl>, <Pfad/Dateiname>)) Hier ist die Unit! Aber mit TntControls.
TSheets ist ein Nachfahre von TabSheet mit ein paar Komponenten drauf.
Ich hoffe mal das reicht
Delphi-Quellcode:
unit uCode;

interface

uses
  Windows, ComCtrls, SysUtils, Classes, Contnrs, uTabSheet, ShellAPI, Graphics,
  Controls, TntIniFiles, TntStdCtrls, StdCtrls, TntComCtrls;

type
  TData = (dFile, dDirectory);

  TTabs = class;

  TTab = class(TObject)
  private
    FSheet: TTabSheet;
    FTabs : TTabs;

    procedure SetSheet(const Value: TTabSheet);// virtual; abstract;
  published
    property Sheet : TTabSheet read FSheet write SetSheet;
    property Tabs : TTabs read FTabs;
  public
    //constructor Create(const APageControl : TPageControl);// virtual; abstract;
    destructor Destroy; override;// virtual; abstract;
  end;

  TMemoTab = class(TTab)
  private
    FFileName : string;
    FMemo : TTntMemo;
    procedure SetMemo(const Value: TTntMemo);

// procedure DblClick(Sender : TObject);
// procedure MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

  published
    property FileName : string read FFileName;
    property Memo : TTntMemo read FMemo write SetMemo;
  public
    constructor Create(const APageControl : TPageControl; const AFileName : string); reintroduce;
    destructor Destroy; override;
  end;

  TExplorerTab = class(TTab)
  private
    FImages : TImageList;
    FExt : TStringList;
    FSheet: TSheet;
    FTabs : TTabs;
    FPath : string;
    FData : array of TData;

    procedure DblClick(Sender : TObject);
    procedure MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    
    procedure SetSheet(const Value: TSheet);
    procedure GenerateView(const AFilter : string = '*.*');
  published
    property Path : string read FPath;
    property Sheet : TSheet read FSheet write SetSheet;
    property Tabs : TTabs read FTabs;
  public
    procedure GoUp;

    constructor Create(const APageControl : TPageControl; const APath : string); reintroduce;
    destructor Destroy; override;
  end;

  TTabs = class(TObject)
  private
    FTabs : TObjectList;
    FIcons : TIconList;
    FFileToolBar: TToolBar;
    FDirectoryToolBar: TToolBar;

    function GetTab(idx: Integer): TTab;
    procedure SetTab(idx: Integer; const Value: TTab);
  public
    property Tab[idx : Integer] : TTab read GetTab write SetTab;
    property FileToolBar : TToolBar read FFileToolBar write FFileToolBar;
    property DirectoryToolBar : TToolBar read FDirectoryToolBar write FDirectoryToolBar;

    procedure Add(ATab : TTab); overload;
    procedure Delete(const AIndex : Integer);

    constructor Create;
    destructor Destroy; override;
  end;

implementation

uses ImgList, Consts, CommCtrl;

Procedure ConvertTo32BitImageList(Const ImageList: TImageList);
Const
  Mask: Array[Boolean] Of Longint = (0, ILC_MASK);
Var
  TemporyImageList: TImageList;
Begin
  If Assigned(ImageList) Then
  Begin
    TemporyImageList := TImageList.Create(Nil);
    Try
      TemporyImageList.Assign(ImageList);
      With ImageList Do
      Begin
        ImageList.Handle := ImageList_Create(Width, Height, ILC_COLOR32 Or Mask[Masked], 0, AllocBy);
        If Not ImageList.HandleAllocated Then
        Begin
          Raise EInvalidOperation.Create(SInvalidImageList);
        End;
      End;
      ImageList.AddImages(TemporyImageList);
    Finally
      TemporyImageList.Free;
    End;
  End;
End;

function GetFileIcon(const FileName: string; const Icon: TIcon; const FileMustExist: Boolean): Boolean;
var
  FI: TSHFileInfo;
  Attributes: DWORD;
  Flags: Word;
begin
  if FileMustExist then
  begin
    Attributes := 0;
    Flags := SHGFI_ICON or SHGFI_LARGEICON;
  end
  else
  begin
    Attributes := FILE_ATTRIBUTE_NORMAL;
    Flags := SHGFI_USEFILEATTRIBUTES or SHGFI_ICON or SHGFI_LARGEICON;
  end;

  if SHGetFileInfo(PChar(FileName), Attributes, FI, SizeOf(FI), Flags) <> 0 then
  begin
    Icon.ReleaseHandle;
    Icon.Handle := FI.hIcon;
    Result := True;
  end
  else
    Result := False;
end;

function GetIconFromFile(FileName: string; Index: Integer): Ticon;
begin
  Result := TIcon.Create;
  Result.Handle := ExtractIcon(HInstance, PCHAR(FileName), Index);
end;

function GetIconFromFile2(const Path: String): TIcon;
var
  KommaPos, Len, IconNumber: Integer;
begin
  Len := Length(Path);
  KommaPos := LastDelimiter(',', Path);
  IconNumber := StrToInt(copy(Path,KommaPos + 1, Len));
  Result := GetIconFromFile(Copy(Path, 1, KommaPos - 1), IconNumber);
end;

function GetLastFolder(const APath : string) : string;
var
  i, start: Integer;
begin
  if APath[Length(APath)] = '\then
    start := 1
  else
    start := 0;
  for i := Length(APath) - start downto 1 do
  begin
    if APath[i] <> '\then
      Result := APath[i] + Result
    else
      break;
  end;
end;

{ TExplorerTab }

constructor TExplorerTab.Create(const APageControl: TPageControl; const APath : string);
begin
  inherited Create;
  FSheet := TSheet.Create(APageControl);
  FSheet.Caption := GetLastFolder(APath);
  FPath := APath;

  // Icons einlesen
  FImages := TImageList.Create(APageControl);
  FImages.Width := 32;
  FImages.Height := 32;
  ConvertTo32BitImageList(FImages);
  FExt := TStringList.Create;
  FExt.Add('folder');
  FImages.AddIcon(GetIconFromFile('%SystemRoot%\system32\SHELL32.dll', 3));

  FSheet.lvListView.LargeImages := FImages;
  FSheet.lvListView.OnDblClick := DblClick;
  FSheet.lvListView.OnMouseUp := MouseUp;
  GenerateView;
end;

procedure TExplorerTab.DblClick(Sender: TObject);
begin
// Beep;
  if FData[FSheet.lvListView.ItemIndex] = dDirectory then
  begin
    FPath := FPath + FSheet.lvListView.Selected.Caption + '\';
    FSheet.Caption := GetLastFolder(FPath);
    GenerateView;
  end;
end;

destructor TExplorerTab.Destroy;
begin
  FreeAndNil(FImages);
  FreeAndNil(FExt);
  inherited;
end;

procedure TExplorerTab.GenerateView(const AFilter : string);
begin
  {...}
end;

procedure TExplorerTab.GoUp;
begin
  {...}
end;

procedure TExplorerTab.MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  {...}
end;

procedure TExplorerTab.SetSheet(const Value: TSheet);
begin
  FSheet := Value;
end;

{ TTabs }

procedure TTabs.Add(ATab: TTab);
begin
  FTabs.Add(ATab);
  ATab.FTabs := self;
end;

constructor TTabs.Create;
begin
  inherited;
  FTabs := TObjectList.Create;
  FIcons := TIconList.Create;
end;

procedure TTabs.Delete(const AIndex: Integer);
begin
  if AIndex >= 0 then
    FTabs.Delete(AIndex);
end;

destructor TTabs.Destroy;
begin
  FreeAndNil(FTabs);
  inherited;
end;

function TTabs.GetTab(idx: Integer): TTab;
begin
  if idx >= 0 then
    Result := TTab(FTabs[idx])
  else
    Result := nil;
end;

procedure TTabs.SetTab(idx: Integer; const Value: TTab);
begin
  FTabs[idx] := Value;
end;

{ TMemoTab }

constructor TMemoTab.Create(const APageControl: TPageControl;
  const AFileName: string);
begin
  inherited Create;
  FSheet := TTabSheet.Create(APageControl.Owner);
  FSheet.PageControl := APageControl;
  FSheet.Caption := ExtractFileName(AFileName);

  FMemo := TTntMemo.Create(APageControl.Owner);
  FMemo.Parent := FSheet;
  FMemo.Align := alClient;
  FMemo.ScrollBars := ssBoth;
  FMemo.WordWrap := false;
  FMemo.Lines.LoadFromFile(AFileName);
end;

destructor TMemoTab.Destroy;
begin
  FreeAndNil(FMemo);
  inherited;
end;

procedure TMemoTab.SetMemo(const Value: TTntMemo);
begin
  FMemo := Value;
end;

{ TTab }

destructor TTab.Destroy;
begin
  FreeAndNil(FSheet);
  inherited;
end;

procedure TTab.SetSheet(const Value: TTabSheet);
begin
  FSheet := Value;
end;

end.
Fabian
Eigentlich hat MS Windows ab Vista den Hang zur Selbstzerstörung abgewöhnt – mkinzler
  Mit Zitat antworten Zitat