qimport3txtview.pas

EMS Advanced Import Component Suite 允许你把数据从文件导入数据库中

unit QImport3TXTView;

{$I VerCtrl.inc}

interface

uses
  {$IFDEF QI_UNICODE}
    {$IFDEF VCL10} WideStrings, {$ELSE} EmsWideStrings, {$ENDIF}
    EmsWideStringCanvas, EmsCustomControl,
  {$ENDIF}
  QImport3StrIDs, Controls, Classes, StdCtrls, Messages, Windows, QImport3ASCII;

type
  TViewArrow = class(TCollectionItem)
  private
    FPosition: integer;
    procedure SetPosition(Value: integer);
  public
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    property Position: integer read FPosition write SetPosition;
  end;

  TQImport3TXTViewer = class;

  TViewArrows = class(TCollection)
  private
    FViewer: TQImport3TXTViewer;
    function GetItem(Index: integer): TViewArrow;
    procedure SetItem(Index: integer; Value: TViewArrow);
  public
    constructor Create(Viewer: TQImport3TXTViewer);
    function Add: TViewArrow;
{$IFNDEF VCL5}
    procedure Delete(Index: integer);
{$ENDIF}
//    procedure Sort;
//    function FindBetween(Start, Finish: integer; var Index: integer): boolean;
    function FindBetweenExcept(Start, Finish: integer; ExceptIndex: integer;
      var Index: integer): boolean;
    function FindLeftAndRight(Position: integer; var Left,
      Right: integer): boolean;
    function FindByPosition(Position: integer): boolean;

    property Items[Index: integer]: TViewArrow read GetItem
      write SetItem; default;
  end;

  TViewRulerAlign = (raTop, raBottom);
  TViewRuler = class(TGraphicControl)
  private
    FAlign: TViewRulerAlign;
    FOffset: integer;
    FStep: integer;

    procedure SetAlign(const Value: TViewRulerAlign);
    procedure SetOffset(Value: integer);
    procedure SetStep(Value: integer);
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  protected
    procedure Paint; override;

    property Offset: integer read FOffset write SetOffset;
    property Step: integer read FStep write SetStep;
  public
    constructor Create(AOwner: TComponent); override;
    property Align: TViewRulerAlign read FAlign write SetAlign;

    property Color;
  end;

  TViewSelection = class
  private
    FViewer: TQImport3TXTViewer;
    FVisibleRect: TRect;

    FLeftArrow: TViewArrow;
    FRightArrow: TViewArrow;

    FInverted: boolean;

    FOnChange: TNotifyEvent;

    function GetExists: boolean;
    procedure Update;
  public
    constructor Create(Viewer: TQImport3TXTViewer);
    procedure SetSelection(Left, Right: TViewArrow);

    property Viewer: TQImport3TXTViewer read FViewer;
    property LeftArrow: TViewArrow read FLeftArrow write FLeftArrow;
    property RightArrow: TViewArrow read FRightArrow write FRightArrow;
    property Exists: boolean read GetExists;
    property VisibleRect: TRect read FVisibleRect;

    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  TDeleteArrowEvent = procedure(Sender: TObject; Position: integer) of object;
  TMoveArrowEvent = procedure(Sender: TObject; OldPos, NewPos: integer) of object;
  TIntersectArrowsEvent = procedure(Sender: TObject; Position: integer) of object;

  TQImport3TXTViewer = class({$IFDEF QI_UNICODE} TEmsCustomControl {$ELSE} TCustomControl {$ENDIF})
  private
    FImport: TQImport3ASCII;
    FCodePage: Integer;
    FScrollBars: TScrollStyle;

    FCharWidth: integer;
    FCharHeight: integer;
    FRealHeight: integer;
    FRealLeft: integer;
    FRealTop: integer;
    FRealWidth: integer;

    FTopRuler: TViewRuler;
    FBottomRuler: TViewRuler;

{$IFDEF QI_UNICODE}
    FLinesW: TWideStrings;
{$ELSE}
    FLines: TStrings;
{$ENDIF}

    FLineCount: integer;
    FMaxLineLength: integer;

    FArrows: TViewArrows;
    FActiveArrow: TViewArrow;
    FSelection: TViewSelection;

    FOnChangeSelection: TNotifyEvent;
    FOnDeleteArrow: TDeleteArrowEvent;
    FOnMoveArrow: TMoveArrowEvent;
    FOnIntersectArrows: TIntersectArrowsEvent;

    procedure SetScrollBars(const Value: TScrollStyle);
//    procedure SetLines(Value: TStrings);
    function CreateRuler(Align: TViewRulerAlign): TViewRuler;
    function GetFullWidth: integer;
    function GetFullHeight: integer;
    procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
    function GetNewArrowPosition(X: integer): integer;
    procedure ChangeSelection(Sender: TObject);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DrawRulers;
    procedure DrawLines;
    procedure DrawArrow(Index: integer);
    procedure DrawArrows;
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
  protected
    property ScrollBars: TScrollStyle read FScrollBars write SetScrollBars;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure LoadFromFile(const AFileName: string);
    procedure SetSelection(Pos, Size: integer);
    procedure GetSelection(var Pos, Size: integer);
    procedure AddArrow(Pos: integer);
    procedure DeleteArrows;

    property Arrows: TViewArrows read FArrows;
    property RealLeft: Integer read FRealLeft;
    property LineCount: integer read FLineCount write FLineCount;

    property OnChangeSelection: TNotifyEvent read FOnChangeSelection
      write FOnChangeSelection;
    property OnDeleteArrow: TDeleteArrowEvent read FOnDeleteArrow
      write FOnDeleteArrow;
    property OnMoveArrow: TMoveArrowEvent read FOnMoveArrow
      write FOnMoveArrow;
    property OnIntersectArrows: TIntersectArrowsEvent read FOnIntersectArrows
      write FOnIntersectArrows;
    property Import: TQImport3ASCII read FImport write FImport;
    property CodePage: Integer read FCodePage write FCodePage;
{$IFDEF QI_UNICODE}
    property Lines: TWideStrings read FLinesW;
{$ELSE}
    property Lines: TStrings read FLines;
{$ENDIF}
  end;

implementation

uses
  {$IFDEF QI_UNICODE} GpTextFile, {$ENDIF}
  QImport3, Graphics, SysUtils, QImport3Common;

const
  sWidth    = 240;
  sHeight   = 120;
  sFontSize = 10;
  sFontName = 'Courier New';

{ TViewArrow }

constructor TViewArrow.Create(Collection: TCollection);
begin
  inherited;
  FPosition := -1;
end;

procedure TViewArrow.Assign(Source: TPersistent);
begin
  if Source is TViewArrow then
  begin
    Position := (Source as TViewArrow).Position;
    Exit;
  end;
  inherited;
end;

procedure TViewArrow.SetPosition(Value: integer);
begin
  if FPosition <> Value then
    FPosition := Value;
end;

{ TViewArrows }

constructor TViewArrows.Create(Viewer: TQImport3TXTViewer);
begin
  inherited Create(TViewArrow);
  FViewer := Viewer;
end;

function TViewArrows.Add: TViewArrow;
begin
  Result := (inherited Add) as TViewArrow;
end;

{$IFNDEF VCL5}
procedure TViewArrows.Delete(Index: integer);
begin
  TCollectionItem(Items[Index]).Free;
end;
{$ENDIF}

{procedure TViewArrows.Sort;

  procedure QuickSort(L, R: Integer);
  var
    i, j: Integer;
    P, T: TViewArrow;
  begin
    repeat
      i := L;
      j := R;
      P := Items[(L + R) shr 1];
      repeat
        while Items[i].Position < P.Position do
          Inc(i);
        while Items[j].Position > P.Position do
          Dec(j);
        if i <= j then
        begin
          T := Items[i];
          Items[i] := Items[j];
          Items[j] := T;
          Inc(i);
          Dec(j);
        end;
      until i > j;
      if L < j then
        QuickSort(L, j);
      L := i;
    until i >= R;
  end;

begin
  QuickSort(0, Count - 1);
end;}

{function TViewArrows.FindBetween(Start, Finish: integer;
  var Index: integer): boolean;
var
 L, H, I, C: Integer;
 j: integer;
begin
  Result := False;
  for j := Start to Finish do begin
    L := 0;
    H := Count - 1;
    while L <= H do begin
      I := (L + H) shr 1;
      if Items[i].Position < j then
        C := -1
      else if Items[i].Position > j then
        C := 1
      else C := 0;
      if C < 0 then L := I + 1
      else begin
        H := I - 1;
        if C = 0 then begin
          Result := True;
          L := I;
        end;
      end;
    end;
    Index := L;
    if Result then Break;
  end;
end;}

function TViewArrows.FindBetweenExcept(Start, Finish: integer;
  ExceptIndex: integer; var Index: integer): boolean;
var
  i: integer;
begin
  Result := False;
  for i := 0 to Count - 1 do
    if (i <> ExceptIndex) and (Items[i].Position >= Start) and
       (Items[i].Position <= Finish) then
    begin
      Result := True;
      Index := i;
      Break;
    end;
end;

function TViewArrows.FindLeftAndRight(Position: integer; var Left,
  Right: integer): boolean;
var
  i: integer;
begin
  Result := False;
  if Count < 2 then Exit;
  Left  := -1;
  Right := -1;
  for i := 0 to Count - 1 do
  begin
    if (Items[i].Position < Position) and
       ((Left = -1) or (Items[i].Position > Items[Left].Position)) then
      Left := i
    else if (Items[i].Position > Position) and
       ((Right = -1) or (Items[i].Position < Items[Right].Position)) then
      Right := i;
  end;
  Result := (Left > -1) and (Right > -1);
end;

function TViewArrows.FindByPosition(Position: integer): boolean;
var
  i: integer;
begin
  Result := False;
  for i := 0 to Count - 1 do
    if Items[i].Position = Position then
    begin
      Result := True;
      Break;
    end;
end;

function TViewArrows.GetItem(Index: integer): TViewArrow;
begin
  Result := inherited Items[Index] as TViewArrow;
end;

procedure TViewArrows.SetItem(Index: integer; Value: TViewArrow);
begin
  inherited SetItem(Index, Value);
end;

{ TViewRuler }

constructor TViewRuler.Create(AOwner: TComponent);
begin
  inherited;
  Height := 16;
  Width := 16;
  SetAlign(raTop);
  FStep := 10;
  ParentColor := False;
  Color := clBtnFace;
end;

procedure TViewRuler.Paint;

  procedure DrawVertTrack(X, Y1, Y2: integer);
  begin
    if X > 0 then
      with Canvas do
        case Align of
          raTop: begin
            Pen.Color := clBlack  ;
            Pen.Width := 1;
            MoveTo(X, Y1);
            LineTo(X, Y2);
            Pen.Color := clWhite;
            MoveTo(X + 1, Y1);
            LineTo(X + 1, Y2);
          end;
          raBottom: begin
            Pen.Color := clBlack;
            Pen.Width := 1;
            MoveTo(X, Y1);
            LineTo(X, Y2 - 1);
            Pen.Color := clWhite;
            MoveTo(X + 1, Y1);
            LineTo(X + 1, Y2 - 1);
          end
        end;
  end;

  procedure DrawBorder;
  begin
    with Canvas do
    begin
      case Align of
        raTop: begin
          Pen.Color := clBlack;
          Pen.Width := 1;
          MoveTo(0, Height - 1);
          LineTo(Width - 1, Height - 1);