//die Klasse kann leicht an eigene Datentypen angepaßt werden
//dazu muß lediglich Typname 'DataType' in den neuen Namen
//geändert werden: Ersetzen->Alles Ersetzen->'DataType'->'MeinTypName'
//eigene Typdefinition einsetzen und Datensatzfunktion ggf. anpassen
//QuickSort ggf. modifizieren

unit DataTypeList;

interface

uses
  Windows, Messages, SysUtils, Classes, PrivatClipBrd;

type
  TDataType = record
     Zahl: Integer;
     Text: string[255];
  end;

  TDataTypeArray = array[0..0] of TDataType;
 
  TDataTypeList = class(TObject)
  private
    FCount: LongInt;
    FDataType: ^TDataTypeArray;
    function GetValue(Index: LongInt): TDataType;
    procedure SetValue(Index: LongInt; Value: TDataType);

    procedure QuickSort(L, R: Integer);

  public
    constructor Create;
    destructor Destroy; override;

    function  Add(const Value: TDataType): LongInt;
    procedure Insert(Index: LongInt; const Value: TDataType);
    procedure Delete(Index: LongInt);
    procedure Clear;
    procedure Sort;
    procedure LoadFromFile(fn: string);
    procedure SaveToFile(fn: string);
    procedure CopyToClipBoard(hWnd: THandle; Index: LongInt);
    procedure PasteFromClipBoard(hWnd: THandle; Index: LongInt);

    property Count: LongInt read FCount;
    property Value[Index: LongInt]: TDataType read GetValue write SetValue; default;
  end;

function DataType(za: Integer; te: string): TDataType;

implementation

var ClipBrdFormat: Integer;
      ClipBrdMemory: ^TDataTypeArray;

constructor TDataTypeList.Create;
begin
   inherited Create;

   ClipBrdFormat:=RegisterClipBoardFormat(PChar('DataType')); //Wert bleibt gleich bei mehrfachem Aufruf

   FCount := 0;
   ReAllocMem(FDataType, (FCount + 1) * SizeOf(TDataType));
end;

destructor TDataTypeList.Destroy;
begin
   ReAllocMem(FDataType, 0);

   inherited Destroy;
end;

//Eigenschaften

function TDataTypeList.GetValue(Index: LongInt): TDataType;
begin
   if (not Assigned(Self)) or (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   Result := FDataType^[Index];
end;

procedure TDataTypeList.SetValue(Index: LongInt; Value: TDataType);
begin
   if (not Assigned(Self)) or (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   FDataType^[Index] := Value;
end;

//Methoden

function TDataTypeList.Add(const Value: TDataType): LongInt;
begin
   FDataType^[FCount]:=Value;
   Result:=FCount;

   inc(FCount);
   ReAllocMem(FDataType, (FCount + 1) * SizeOf(TDataType));
end;

procedure TDataTypeList.Insert(Index: LongInt; const Value: TDataType);
begin
   if (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   inc(FCount);
   ReAllocMem(FDataType, (FCount + 1) * SizeOf(TDataType));

   System.Move(FDataType^[Index], FDataType^[Index+1], (FCount-Index)*sizeof(TDataType));

   FDataType^[Index]:=Value;
end;

procedure TDataTypeList.Delete(Index: LongInt);
begin
   if (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   System.Move(FDataType^[Index+1], FDataType^[Index], (FCount-Index-1)*sizeof(TDataType));

   dec(FCount);
   ReAllocMem(FDataType, (FCount + 1) * SizeOf(TDataType));
end;

procedure TDataTypeList.Clear;
begin

   FCount := 0;
   ReAllocMem(FDataType, (FCount + 1) * SizeOf(TDataType));
end;

procedure TDataTypeList.Sort;
begin
   if (FDataType <> nil) and (FCount > 0) then QuickSort(0, FCount - 1);
end;

procedure TDataTypeList.LoadFromFile(fn: string);
var fs: file;
    buffer: Integer;
    cv: Integer;

begin
AssignFile(fs, fn);
{$I-}
Reset(fs, 1);
{$I+}

if IOResult = 0 then
begin

BlockRead(fs, FCount, sizeof(LongInt));
ReAllocMem(FDataType, (FCount + 1) * SizeOf(TDataType));

for cv:=0 to FCount-1 do
  BlockRead(fs, FDataType^[cv], sizeof(TDataType));

end;

CloseFile(fs);
end;

procedure TDataTypeList.SaveToFile(fn: string);
var fs: file;
    cv: Integer;

begin
AssignFile(fs, fn);
{$I-}
Rewrite(fs, 1);
{$I+}

if IOResult = 0 then
begin

BlockWrite(fs, FCount, sizeof(LongInt));

for cv:=0 to FCount-1 do
  BlockWrite(fs, FDataType^[cv], sizeof(TDataType));

end;

CloseFile(fs);
end;

procedure TDataTypeList.CopyToClipBoard(hWnd: THandle; Index: LongInt);
begin
   if (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   ReAllocMem(ClipBrdMemory, SizeOf(TDataType));

   ClipBrdMemory^[0]:=FDataType^[Index];
   SetPrivatClipBroardData(hWnd, ClipBrdFormat, ClipBrdMemory);

   ReAllocMem(ClipBrdMemory, 0);
end;

procedure TDataTypeList.PasteFromClipBoard(hWnd: THandle; Index: LongInt);
begin
   if (Index < 0) or (Index >= FCount) then
   begin MessageBox(0, PChar('Index außerhalb des zulässigen Bereichs.'), PChar('Information'), MB_OK+MB_ICONINFORMATION); Exit; end;

   ReAllocMem(ClipBrdMemory, SizeOf(TDataType));

   if GetPrivatClipBroardData(hWnd, ClipBrdFormat, ClipBrdMemory, sizeof(TDataType)) then
      FDataType^[Index]:=ClipBrdMemory^[0];

   ReAllocMem(ClipBrdMemory, 0);
end;

//Routinen

//modifiziert (siehe TStringList.QuickSort(L, R: Integer);  in Datei classes.pas)
procedure TDataTypeList.QuickSort(L, R: Integer);  //QuickSort(0, FCount - 1);
var I, J: Integer;
    P: string;

    Temp: TDataType;

begin

  repeat
    I := L;
    J := R;
    P := FDataType^[(L + R) shr 1].Text;

    repeat
      while AnsiCompareText(FDataType^[I].Text, P) < 0 do Inc(I);
      while AnsiCompareText(FDataType^[J].Text, P) > 0 do Dec(J);

      if I <= J then
      begin
        Temp:=FDataType^[I]; FDataType^[I]:=FDataType^[J]; FDataType^[J]:=Temp; //Items tauschen
 
        Inc(I);
        Dec(J);
      end;

    until I > J;

    if L < J then QuickSort(L, J);

    L := I;

  until I >= R;

end;

//Funktion DataType gibt einen TDataType-Datensatz zurück (außerhalb der Klasse TDataTypeList)

function DataType(za: Integer; te: string): TDataType;
begin
   result.Zahl:=za;
   result.Text:=te;
end;

end.

//////////////////////////////////////////////////////////////////////////

unit PrivatClipBrd;

//Privates ClipBoard Format definieren >setzen bzw. auslesen

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

function SetPrivatClipBroardData(hWnd: THandle; ClipBrdFormat: Integer; Data: Pointer): Boolean;
function GetPrivatClipBroardData(hWnd: THandle; ClipBrdFormat: Integer; Data: Pointer;
                                  DataSize: Integer): Boolean;

implementation

function SetPrivatClipBroardData(hWnd: THandle; ClipBrdFormat: Integer; Data: Pointer): Boolean;
begin
OpenClipBoard(hWnd);
EmptyClipBoard;
result:=(SetClipBoardData( ClipBrdFormat, Integer(Data))<>0);
CloseClipBoard;
end;

function GetPrivatClipBroardData(hWnd: THandle; ClipBrdFormat: Integer; Data: Pointer;
                                  DataSize: Integer): Boolean;
var hClipMem: THandle;
    lpClip: Pointer;

begin
result:=False;

OpenClipBoard(hWnd);

if IsClipBoardFormatAvailable(ClipBrdFormat) then
begin
hClipMem:=GetClipBoardData(ClipBrdFormat);
lpClip:=GlobalLock(hClipMem);
CopyMemory(Data, lpClip, DataSize);
GlobalUnLock(hClipMem);
result:=True;
end;

CloseClipBoard;

end;

end.

Zurück zur Hauptseite