tabfrm.pas

文件包含程序源原文件

unit TabFrm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls, ComCtrls, ImgList, Ex2NmEdt, Mask;

const
  cMAX_UNDO = 20;

type
  // UNDO--
  PLSUNDO = ^TLSUNDO;
  TLSUNDO = record
    Value: Variant;
    Control: TWinControl;
    Recid: LongInt;
  end;

  PUPDATE_LIST = ^TUPDATE_LIST;
  TUPDATE_LIST = record
    REC_ID: LongInt;
    TARGET: Pointer; //-- update object
    INDEX,
    LEVEL: Integer;
    PARENT: Pointer; //-- parent
  end;

  PCONTROL_LIST = ^TCONTROL_LIST;
  TCONTROL_LIST = record
    Index,
    UpdateIndex: Integer;
    Target,
    Prior,
    Next: TWinControl;
    Focused: Boolean;
    Address,
    Parent: Pointer;
  end;

  TTabForm = class(TForm)
    TabControl: TTabControl;
    TopPanel: TPanel;
    ClientPanel: TPanel;
    ImageList: TImageList;

    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);

    procedure TabControlChange(Sender: TObject);
    procedure TabControlChanging(Sender: TObject; var AllowChange: Boolean);

    procedure ControlEnter(Sender: TObject); virtual;
    procedure ControlKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); virtual;

  private
    { Private }
    FUpdateListList: TList;

    FOnTabChange,
    FReturnNextTab: Boolean;

    function  SearchUpdateList(Target: Pointer): Boolean;

    procedure UpdateListListDisposeClear;

    function  SearchUpdateListList(Target: PUPDATE_LIST): TList;
    //-- Form TabStop false
    procedure TabStopClear;

    //-- set Ctrl List Focus
    procedure SetCtrlListFocus(CtrlList: PCONTROL_LIST);

    //-- move to next Cursor
    procedure PriorNextMoveProc(Key: Word; ShiftState: TShiftState);

    //-- cursor from current to Next
    procedure SetCtrlFocusPriorNext(Target: TWinControl; ShiftState: TShiftState);

    procedure SetTagMemory;
    procedure DisposeTagMemory;

  protected
    FUpdateList: TList;

    FCtrlList: array[0..99]of  PCONTROL_LIST;
    FCtrlListCount: Integer;

    FUndoBuffer: array[0..cMAX_UNDO-1] of PLSUndo;

    FNewMode,
    FOnUndo: Boolean;

    FEntryCtrl: PCONTROL_LIST;
    FShiftState: TShiftState;

    FNewRecId: Longint;

    FEditError: Boolean;

    // CtrlList
    procedure ResetCtrlList; //-- init ctrl list data
    procedure InitCtrlList(Target: TWinControl; Index, UpdateIndex: Integer; Prior, Next: TWinControl);
    procedure PostCtrlList;
    function  GetCtrlListTarget(Sender: TWinControl): PCONTROL_LIST;
    procedure ResetCtrllistAddress;

    // --
    function  ReturnFocus: Boolean;

    //--
    procedure SetCtrlFocusFromIndex(Index: Integer);

    procedure ReturnValueFromTag(CtrlList: PCONTROL_LIST);

    procedure SetUndoBuffer(Sender: TObject);

    // undo --
    function DoUndo: Boolean;

    function  SetUpdateList(Recid: LongInt; Target: Pointer; Index, Level: Integer; Parent: Pointer): PUPDATE_LIST;
    procedure DeleteUpdateList(RecId: LongInt; Index: Integer);

    //--
    function DateReturn(CtrlList: PCONTROL_LIST; Msg: Boolean): Boolean;

    function GetUpdateListList: TList;

    function InsertSQL(TableName: string; NewRecId: Longint; List: TList): string;
    function UpdateSQL(TableName: string; List: TList): string;

    //--
    function TabTrap(ShiftState: TShiftState): Boolean; virtual; //--
    procedure SetKomoku(Item: Pointer); virtual; abstract;

    procedure SetCtrlListAddress(CtrlList: PCONTROL_LIST); virtual;

    //--
    function  MakeUpdateValue(lcP: PUPDATE_LIST; Msg: Boolean; var ErrorCode: Integer): string; virtual; abstract;

    function  GetFieldName(TableName: string; Index: Integer): string; virtual; abstract;

    procedure CopyValueToTag(Sender: TObject; CtrlList: PCONTROL_LIST);

    //--
    procedure FreeUpdateList(Item: Pointer);

    //--
    procedure AddTab(Item: Pointer);
    procedure InsertTab(Item: Pointer; Index: Integer);
    procedure DeleteTab(Item: Pointer; DisposeFlag: Boolean);
    procedure SetTabCaption(Item: Pointer);
    function  GetTabCaption(Item: Pointer): string; virtual; abstract;
    procedure SelectTabIndex(Index: Integer);

    //--
    function  GetSelected: Pointer;
    procedure SetSelected(Item: Pointer);

    //--
    property Selected: Pointer read GetSelected write SetSelected;

    //--
    property OnTabChange: Boolean read FOnTabChange;

    property ReturnNextTab: Boolean read FReturnNextTab write FReturnNextTab default False;

  public
    { Public }

  end;


function StrToDate00to2000(TargetDate: string): TDateTime;

var
  TabForm: TTabForm;

implementation

{$R *.DFM}

{ TTabForm }

function StrToDate00to2000(TargetDate: string): TDateTime;
var
  p, p2: PChar;
begin

     Result:= 0;

     p := StrAlloc(32);
     StrPCopy(p, TargetDate);
     p2 := StrPos(p, '/');
     if p2 = nil then
     begin
          StrDispose(p);
          Exit;
     end;

     p2^ := #0;
     if (LongInt(p2)-LongInt(p)<3) and (StrToInt(StrPas(p))<50) then
     begin
          try
          Result := StrToDate('20'+TargetDate);
          except
          StrDispose(p);
          Exit;
          end;

     end
     else
     begin
          try
          Result := StrToDate(TargetDate);
          except
          StrDispose(p);
          Exit;
          end;
     end;

     StrDispose(p);

end;

procedure TListDisposeClear(List: TList);
var
  i: Integer;
begin
  for i := 0 to List.Count - 1 do
    Dispose(List[i]);
  List.Clear;
end;

procedure TTabForm.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  FUpdateListList := TList.Create;

  FUpdateList := TList.Create;

  for i:=0 to cMAX_UNDO-1 do
    FUndoBuffer[i] := nil;

  for i:=0 to 99 do
    FCtrlList[i] := nil;

  FCtrlListCount := 0;
  ResetCtrlList;

  //--
  SetTagMemory;

  FNewRecid := 0;

  FOnTabChange := False;
  FReturnNextTab := False;

  FShiftState := [];

  TabStopClear;
end;

procedure TTabForm.FormDestroy(Sender: TObject);
var
  i: Integer;
begin
  UpdateListListDisposeClear;
  FUpdateListList.Free;

  for i := 0 to FCtrlListCount - 1 do
    Dispose(FCtrlList[i]);

  DisposeTagMemory;

  for i := 0 to FUpdateList.Count - 1 do
    Dispose(FUpdateList[i]);

  FUpdateList.Free;
end;

procedure TTabForm.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  //--
  if (Key = VK_TAB) and (TabTrap(FShiftState) = False) then //--
    PriorNextMoveProc(VK_TAB, Shift);
end;

procedure TTabForm.ControlEnter(Sender: TObject);
var
  CtrlList: PCONTROL_LIST;
begin
  if Selected = nil then
    Exit;

  CtrlList := GetCtrlListTarget(Sender as TWinControl);

  if CtrlList = nil then begin
    ReturnFocus;
    Exit;
  end;

  CopyValueToTag(Sender, CtrlList);

  SetCtrlListAddress(CtrlList);
end;

procedure TTabForm.ControlKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  WControl: TWinControl;
begin
  if Key = VK_RETURN then begin
    PriorNextMoveProc(Key, Shift);
    Key := 0;
  end
  else
  if (Key = VK_DOWN) and (Shift = []) then begin
    TabControl.SetFocus;  // ControlExit

    if not FNewMode then begin

      WControl := Sender as TWinControl;

      if TabControl.Tabs.Count - 1 >= TabControl.TabIndex + 1 then begin
        TabControl.TabIndex  := TabControl.TabIndex + 1;
        TabControlChange(Sender);
      end;

      try
        WControl.SetFocus;
      except
        ;
      end;

  //if FCloseQuery then
      ControlEnter(Self.ActiveControl);
    end;
    Key := 0;
  end
  else
  if (Key = VK_UP) and (Shift = []) then begin
    TabControl.SetFocus;  // ControlExit

    if not FNewMode then begin

      WControl := Sender as TWinControl;


      if TabControl.TabIndex > 0 then begin
        TabControl.TabIndex  := TabControl.TabIndex - 1;
        TabControlChange(Sender);
      end;

      try
        WControl.SetFocus;
      except
        ;
      end;
      ControlEnter(Self.ActiveControl);
    end;
    Key := 0;
  end;
end;

function TTabForm.SearchUpdateList(Target: Pointer): Boolean;
var
  i:Integer;
  lcP:PUPDATE_LIST;
begin

     Result := False;
     for i:=0 to FUpdateList.Count-1 do
     begin

          lcP:=FUpdateList.Items[i];

          if (lcP<>nil) and (lcP^.Target=Target) then
          begin
               Result:=True;
               Exit;
          end;
     end;

end;

procedure TTabForm.UpdateListListDisposeClear;
var
  List:TList;
  i:Integer;
begin

     for i:=0 to FUpdateListList.Count-1 do
     begin
          List := FUpdateListList[i];
          List.Free;
     end;
     FUpdateListList.Clear;

end;


function TTabForm.SearchUpdateListList(Target: PUPDATE_LIST): TList;
var
  i,k:Integer;
  lcP:PUPDATE_LIST;
  List:TList;
begin
  for i:=0 to FUpdateListList.Count-1 do
  begin
    List := FUpdateListList[i];
    for k:=0 to List.Count-1 do
    begin
      lcP := List[k];
      if lcP^.REC_ID=Target^.REC_ID then
      begin
        Result:=List;
        Exit;
      end;
    end;
  end;

  List := TList.Create;
  FUpdateListList.Add(List);
  Result:=List;
end;

procedure TTabForm.TabStopClear;
var
  i:Integer;
begin
     for i:=0 To Self.ComponentCount-1 do
         try
           if ((Self.Components[i] is TLabel) or (Self.Components[i] is TImageList))then BREAK
           else (Self.Components[i] as TWinControl).TabStop:=False;
         except
         ;
         end;

end;

procedure TTabForm.SetCtrlListFocus(CtrlList: PCONTROL_LIST);
var
  n:Integer;
begin

     n:=0;
     while FCtrlList[n]<>nil do
     begin
           if FCtrlList[n]<>CtrlList then
              FCtrlList[n]^.Focused:=False
           else
               FCtrlList[n]^.Focused:=True;
           Inc(n);
     end;

end;

procedure TTabForm.SetCtrlFocusFromIndex(Index: Integer);
var
  n: Integer;
begin
  n := 0;

  while FCtrlList[n] <> nil do begin
    if (FCtrlList[n]^.Index = Index) then begin
      try
        FCtrlList[n]^.Target.SetFocus;
      except
        ;
      end;
      Exit;
    end;
    Inc(n);
  end;

  if (FCtrlList[0] <> nil) and ((Index = 0) or (Index = 99)) then
    try
      FCtrlList[0]^.Target.SetFocus;
    except
      ;
    end;
end;

procedure TTabForm.PriorNextMoveProc(Key: Word; ShiftState: TShiftState);
var
  CtrlList:PCONTROL_LIST;
begin
  if Selected = nil then
    Exit;

  //-- PCONTROL_LIST
  GetCtrlListTarget( Self.ActiveControl );

  CtrlList := FEntryCtrl; //--

  if CtrlList = nil then
     Exit;

  FEditError := False;

  if (Key = VK_RETURN) and (CtrlList^.Index < 0) and (not(ShiftState = [ssShift])) then begin
    TabControl.SetFocus;  // ControlExit
    SetCtrlFocusFromIndex(0)
  end
  else
  if (CtrlList^.Index = 99) and (not(ShiftState = [ssShift])) then begin
    TabControl.SetFocus;  // ControlExit

    if (TabControl.Tabs.Count - 1 >= TabControl.TabIndex + 1) and FReturnNextTab then begin
      TabControl.TabIndex := TabControl.TabIndex + 1;
      TabControlChange(Self);
    end;
    if not FEditError then
      SetCtrlFocusFromIndex(0);

  end
  else
  if (CtrlList^.Index = 0) and (ShiftState = [ssShift]) then begin
    TabControl.SetFocus;  // ControlExit

    if (TabControl.TabIndex-1 > -1) and FReturnNextTab then begin
      TabControl.TabIndex := TabControl.TabIndex - 1;
      TabControlChange(Self);
    end;
    SetCtrlFocusFromIndex(99);

  end
  else
    SetCtrlFocusPriorNext(CtrlList^.Target, ShiftState);
end;

procedure TTabForm.SetCtrlFocusPriorNext(Target: TWinControl;
  ShiftState: TShiftState);
var
  n: Integer;
begin
  if Target = nil then
    Exit;

  n := 0;

  while FCtrlList[n] <> nil do begin

    if FCtrlList[n]^.Target = Target then begin

      if (not (ShiftState=[ssShift])) and (FCtrlList[n]^.Next <> nil) then begin
        try
          FCtrlList[n]^.Next.SetFocus;
        except
          SetCtrlFocusPriorNext(FCtrlList[n]^.Next, ShiftState);
        end;
      end
      else
      if (ShiftState=[ssShift]) and (FCtrlList[n]^.Prior <> nil) then begin
        try
          FCtrlList[n]^.Prior.SetFocus;
        except
          SetCtrlFocusPriorNext(FCtrlList[n]^.Prior, ShiftState);
        end;
      end;
      break;

    end;
    Inc(n);
  end;
end;

procedure TTabForm.SetTagMemory;
var
  i:Integer;
begin

     for i:=0 To Self.ComponentCount-1 do

          if Self.Components[i] is TEx2NumEdit then
          begin
               Self.Components[i].Tag := LongInt( StrAlloc( Sizeof(Extended) ) );
               Extended( Pointer(Self.Components[i].Tag)^) := 0;
          end
          else
          if Self.Components[i] is TCustomEdit then
          begin
               Self.Components[i].Tag := LongInt( StrAlloc(128) );
               ZeroMemory(Pointer(Self.Components[i].Tag),128);
          end;

end;

procedure TTabForm.DisposeTagMemory;
var
  i:Integer;
begin

     for i:=0 To Self.ComponentCount-1 do

          if (Self.Components[i] is TEx2NumEdit) or (Self.Components[i] is TCustomEdit) then
          begin
               StrDispose( PChar(Self.Components[i].Tag) );
          end;

end;

procedure TTabForm.ResetCtrlList;
var
  i:Integer;
begin

     for i:=0 to FCtrlListCount-1 do
         Dispose(FCtrlList[i]);

     for i:=0 to 99 do
     begin
          New( FCtrlList[i] );
          ZeroMemory(FCtrlList[i],Sizeof(TCONTROL_LIST));
     end;

     FCtrlListCount:=0;

end;