vrmatrix.pas

作工控的好控件

{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}

unit VrMatrix;

{$I VRLIB.INC}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VrConst, VrTypes, VrClasses, VrControls, VrSysUtils, VrThreads;

type
  TVrMatrixTextStyle = (tsUpperCase, tsLowerCase, tsAsIs, tsProperCase);

  TVrMatrixData = class
  private
    FOrigin: string;
    FData: string;
    FColors: string;
    FCurrColor: Char;
    FStyle: TVrMatrixTextStyle;
    procedure DecodeColorCode(var S: string);
    procedure InsertChar(var S: string);
  public
    constructor Create;
    procedure Decode(S: string);
    procedure SetStyle(Value: TVrMatrixTextStyle);
    procedure MoveLeft;
    procedure MoveRight;
    procedure Reset;
    property Data: string read FData;
    property Colors: string read FColors;
  end;

  TVrMatrixScrollDirection = (msdRightToLeft, msdLeftToRight);
  TVrMatrixLedStyle = (ls9x13, ls14x20, ls19x27);

  TVrMatrix = class(TVrGraphicImageControl)
  private
    FLeds: Integer;
    FSpacing: Integer;
    FAlignment: TAlignment;
    FPalette: TVrPalette;
    FTextStyle: TVrMatrixTextStyle;
    FAutoScroll: Boolean;
    FBevel: TVrBevel;
    FScrollDirection: TVrMatrixScrollDirection;
    FLedStyle: TVrMatrixLedStyle;
    FLedsVisible: Boolean;
    FThreaded: Boolean;
    FOrientation: TVrOrientation;
    FCharIndex: Integer;
    FOnScrollDone: TNotifyEvent;
    Bitmap: TBitMap;
    FTimer: TVrTimer;
    ScrollInit: Boolean;
    Initialized: Boolean;
    FStartLed: Integer;
    FImageRect: TRect;
    FString: TVrMatrixData;
    function GetTimeInterval: Integer;
    procedure SetLeds(Value: Integer);
    procedure SetSpacing(Value: Integer);
    procedure SetAlignment(Value: TAlignment);
    procedure SetTextStyle(Value: TVrMatrixTextStyle);
    procedure SetAutoScroll(Value: Boolean);
    procedure SetTimeInterval(Value: Integer);
    procedure SetLedStyle(Value: TVrMatrixLedStyle);
    procedure SetLedsVisible(Value: Boolean);
    procedure SetPalette(Value: TVrPalette);
    procedure SetBevel(Value: TVrBevel);
    procedure SetThreaded(Value: Boolean);
    procedure SetOrientation(Value: TVrOrientation);
    procedure PaletteModified(Sender: TObject);
    procedure BevelChanged(Sender: TObject);
    procedure TimerEvent(Sender: TObject);
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  protected
    procedure LoadBitmaps; virtual;
    procedure DestroyBitmaps;
    procedure UpdateLed(Index: Integer; Ch: Char; Color: TColor);
    procedure UpdateLeds(Redraw: Boolean);
    procedure Paint; override;
    procedure Loaded; override;
    procedure GetItemRect(Index: Integer; var R: TRect);
    procedure CalcPaintParams;
    procedure FormatText(Value: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Threaded: Boolean read FThreaded write SetThreaded default True;
    property Leds: Integer read FLeds write SetLeds default 15;
    property Spacing: Integer read FSpacing write SetSpacing default 2;
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property Palette: TVrPalette read FPalette write SetPalette;
    property Bevel: TVrBevel read FBevel write SetBevel;
    property TextStyle: TVrMatrixTextStyle read FTextStyle write SetTextStyle default tsUpperCase;
    property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default false;
    property TimeInterval: Integer read GetTimeInterval write SetTimeInterval default 500;
    property ScrollDirection: TVrMatrixScrollDirection read FScrollDirection write FScrollDirection default msdRightToLeft;
    property LedStyle: TVrMatrixLedStyle read FLedStyle write SetLedStyle default ls14x20;
    property LedsVisible: Boolean read FLedsVisible write SetLedsVisible default True;
    property Orientation: TVrOrientation read FOrientation write SetOrientation default voHorizontal;
    property OnScrollDone: TNotifyEvent read FOnScrollDone write FOnScrollDone;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Color;
    property DragCursor;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragMode;
    property Hint;
    property ParentColor;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Text;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;

  TVrMatrixGroup = class(TVrGraphicImageControl)
  private
    FCols: TVrColInt;
    FRows: TVrRowInt;
    FAutoScroll: Boolean;
    FPalette: TVrPalette;
    FBevel: TVrBevel;
    FCharSpacing: Integer;
    FLineSpacing: Integer;
    FPixelSize: Integer;
    FPixelSpacing: Integer;
    FLines: TStrings;
    FTimer: TVrTimer;
    FThreaded: Boolean;
    FLedImage: TBitmap;
    FMatrixImage: TBitmap;
    FColorChanged: Boolean;
    FScrollDirection: TVrScrollDirection;
    FViewPort: TRect;
    FAlignment: TAlignment;
    FTextStyle: TVrMatrixTextStyle;
    FInitialized: Boolean;
    FList: TList;
    function GetTimeInterval: Integer;
    procedure SetCols(Value: TVrColInt);
    procedure SetRows(Value: TVrRowInt);
    procedure SetCharSpacing(Value: Integer);
    procedure SetLineSpacing(Value: Integer);
    procedure SetPixelSize(Value: Integer);
    procedure SetPixelSpacing(Value: Integer);
    procedure SetLines(Value: TStrings);
    procedure SetPalette(Value: TVrPalette);
    procedure SetBevel(Value: TVrBevel);
    procedure SetThreaded(Value: Boolean);
    procedure SetAutoScroll(Value: Boolean);
    procedure SetAlignment(Value: TAlignment);
    procedure SetTextStyle(Value: TVrMatrixTextStyle);
    procedure SetTimeInterval(Value: Integer);
    procedure PaletteModified(Sender: TObject);
    procedure BevelChanged(Sender: TObject);
    procedure LinesChanged(Sender: TObject);
    procedure TimerEvent(Sender: TObject);
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  protected
    procedure Paint; override;
    procedure CalcPaintParams;
    procedure Loaded; override;
    procedure CreateLedImage;
    procedure UpdateLed(Index: Integer; Ch: Char; Color: TColor);
    procedure UpdateRow(ARow: Integer);
    procedure FormatStrings;
    function GetItemRect(Index: Integer): TRect;
    procedure CreateDataList;
    procedure ClearDataList(FreeList: Boolean);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Reset;
  published
    property Threaded: Boolean read FThreaded write SetThreaded default True;
    property Cols: TVrColInt read FCols write SetCols default 15;
    property Rows: TVrRowInt read FRows write SetRows default 7;
    property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default false;
    property CharSpacing: Integer read FCharSpacing write SetCharSpacing default 1;
    property LineSpacing: Integer read FLineSpacing write SetLineSpacing default 1;
    property PixelSize: Integer read FPixelSize write SetPixelSize default 1;
    property PixelSpacing: Integer read FPixelSpacing write SetPixelSpacing default 1;
    property Lines: TStrings read FLines write SetLines;
    property ScrollDirection: TVrScrollDirection read FScrollDirection write FScrollDirection default sdRightToLeft;
    property Palette: TVrPalette read FPalette write SetPalette;
    property Bevel: TVrBevel read FBevel write SetBevel;
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property TextStyle: TVrMatrixTextStyle read FTextStyle write SetTextStyle default tsUpperCase;
    property TimeInterval: Integer read GetTimeInterval write SetTimeInterval default 500;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Color default clBlack;
    property DragCursor;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragMode;
    property Hint;
    property ParentColor default false;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Text;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;


implementation

{$R VRMATRIX.D32}

const
  CharState: array[0..895] of byte = { all ASCII according to Hewlett Packard HDSP 2470 }
              ($02, $06, $0e, $1e, $0e, $06, $02,     { NUL }
               $04, $00, $04, $08, $11, $11, $0e,     { SOH }
               $1f, $00, $11, $0a, $04, $0a, $11,     { STX }
               $1f, $00, $11, $19, $15, $13, $11,     { ETX }
               $1f, $00, $16, $19, $11, $11, $11,     { EOT }
               $00, $00, $0d, $12, $12, $12, $0d,     { ENQ }
               $1c, $12, $12, $16, $11, $16, $10,     { ACK }
               $06, $08, $04, $0e, $11, $11, $0e,     { BEL }
               $00, $00, $00, $04, $0a, $11, $1f,     { BS }
               $00, $10, $1c, $12, $12, $02, $01,     { HT }
               $0e, $11, $11, $1f, $11, $11, $0e,     { LF }
               $00, $10, $08, $04, $0a, $11, $11,     { VT }
               $00, $00, $09, $09, $09, $0e, $10,     { FF }
               $00, $01, $0e, $1a, $0a, $0a, $0a,     { CR }
               $00, $00, $0f, $12, $12, $12, $0c,     { SO }
               $1f, $08, $04, $02, $04, $08, $1f,     { SI }
               $00, $00, $01, $0e, $14, $04, $04,     { DLE }
               $00, $04, $0e, $15, $15, $0e, $04,     { DC1 }
               $0e, $11, $11, $11, $11, $0a, $1b,     { DC2 }
               $04, $00, $0e, $11, $1f, $11, $11,     { DC3 }
               $04, $00, $0e, $12, $12, $12, $0d,     { DC4 }
               $0a, $00, $0e, $11, $1f, $11, $11,     { NAK }
               $0a, $00, $0e, $12, $12, $12, $0d,     { SYN }
               $0a, $0e, $11, $11, $11, $11, $0e,     { ETB }
               $0a, $00, $0e, $11, $11, $11, $0e,     { CAN }
               $0a, $00, $11, $11, $11, $11, $0e,     { EM }
               $00, $0a, $00, $11, $11, $11, $0e,     { SUB }
               $00, $04, $02, $1f, $02, $04, $00,     { ESC }
               $00, $0f, $08, $08, $08, $18, $08,     { FS }
               $0c, $12, $04, $08, $1e, $00, $00,     { GS }
               $06, $09, $08, $1c, $08, $08, $1f,     { RS }
               $11, $0a, $04, $04, $0e, $04, $04,     { US }
               $00, $00, $00, $00, $00, $00, $00,     { Space }
               $08, $08, $08, $08, $08, $00, $08,     { ! }
               $0a, $0a, $00, $00, $00, $00, $00,     { " }
               $0a, $0a, $1f, $0a, $1f, $0a, $0a,     { # }
               $04, $0f, $14, $0e, $05, $1e, $04,     { $ }
               $18, $19, $02, $04, $08, $13, $03,     { % }
               $08, $14, $14, $08, $15, $12, $0d,     { & }
               $0c, $0c, $04, $08, $00, $00, $00,     { ' }
               $02, $04, $04, $04, $04, $04, $02,     { ( }
               $08, $04, $04, $04, $04, $04, $08,     { ) }
               $00, $0a, $04, $1f, $04, $0a, $00,     { * }
               $00, $04, $04, $1f, $04, $04, $00,     { + }
               $00, $00, $00, $0c, $0c, $04, $08,     { , }
               $00, $00, $00, $1f, $00, $00, $00,     { - }
               $00, $00, $00, $00, $0c, $0c, $00,     { . }
               $00, $01, $02, $04, $08, $10, $00,     { / }
               $0e, $11, $13, $15, $19, $11, $0e,     { 0 }
               $04, $0c, $04, $04, $04, $04, $0e,     { 1 }
               $0e, $11, $01, $06, $08, $10, $1f,     { 2 }
               $0e, $11, $01, $06, $01, $11, $0e,     { 3 }
               $02, $06, $0a, $12, $1f, $02, $02,     { 4 }
               $1f, $10, $1e, $01, $01, $11, $0e,     { 5 }
               $06, $08, $10, $1e, $11, $11, $0e,     { 6 }
               $1f, $01, $02, $04, $08, $08, $08,     { 7 }
               $0e, $11, $11, $0e, $11, $11, $0e,     { 8 }
               $0e, $11, $11, $0f, $01, $02, $0c,     { 9 }
               $00, $0c, $0c, $00, $0c, $0c, $00,     { : }
               $0c, $0c, $00, $0c, $0c, $04, $08,     { ; }
               $01, $02, $04, $08, $04, $02, $01,     { < }
               $00, $00, $1f, $00, $1f, $00, $00,     { = }
               $10, $08, $04, $02, $04, $08, $10,     { > }
               $0e, $11, $01, $02, $04, $00, $04,     { ? }
               $0e, $11, $17, $15, $17, $10, $0e,     { @ }
               $0e, $11, $11, $1f, $11, $11, $11,     { A }
               $1e, $11, $11, $1e, $11, $11, $1e,     { B }
               $0e, $11, $10, $10, $10, $11, $0e,     { C }
               $1e, $11, $11, $11, $11, $11, $1e,     { D }
               $1f, $10, $10, $1e, $10, $10, $1f,     { E }
               $1f, $10, $10, $1e, $10, $10, $10,     { F }
               $0e, $11, $10, $10, $13, $11, $0f,     { G }
               $11, $11, $11, $1f, $11, $11, $11,     { H }
               $0e, $04, $04, $04, $04, $04, $0e,     { I }
               $01, $01, $01, $01, $01, $11, $0e,     { J }
               $11, $12, $14, $18, $14, $12, $11,     { K }
               $10, $10, $10, $10, $10, $10, $1f,     { L }
               $11, $1b, $15, $15, $11, $11, $11,     { M }
               $11, $11, $19, $15, $13, $11, $11,     { N }
               $0e, $11, $11, $11, $11, $11, $0e,     { O }
               $1e, $11, $11, $1e, $10, $10, $10,     { P }
               $0e, $11, $11, $11, $15, $12, $0d,     { Q }
               $1e, $11, $11, $1e, $14, $12, $11,     { R }
               $0e, $11, $10, $0e, $01, $11, $0e,     { S }
               $1f, $04, $04, $04, $04, $04, $04,     { T }
               $11, $11, $11, $11, $11, $11, $0e,     { U }
               $11, $11, $11, $11, $11, $0a, $04,     { V }
               $11, $11, $11, $15, $15, $1b, $11,     { W }
               $11, $11, $0a, $04, $0a, $11, $11,     { X }
               $11, $11, $0a, $04, $04, $04, $04,     { Y }
               $1f, $01, $02, $04, $08, $10, $1f,     { Z }
               $07, $04, $04, $04, $04, $04, $07,     { [ }
               $00, $10, $08, $04, $02, $01, $00,     { \ }
               $1c, $04, $04, $04, $04, $04, $1c,     { ] }
               $04, $0e, $15, $04, $04, $04, $04,     { ^ }
               $00, $00, $00, $00, $00, $00, $1f,     { _ }
               $0c, $0c, $08, $04, $00, $00, $00,     { ` }
               $00, $00, $0e, $12, $12, $12, $0d,     { a }
               $10, $10, $16, $19, $11, $11, $1e,     { b }
               $00, $00, $0e, $10, $10, $11, $0e,     { c }
               $01, $01, $0d, $13, $11, $11, $0f,     { d }
               $00, $00, $0e, $11, $1e, $10, $0e,     { e }
               $04, $0a, $08, $1c, $08, $08, $08,     { f }
               $00, $00, $0f, $11, $0f, $01, $06,     { g }
               $10, $10, $16, $19, $11, $11, $11,     { h }
               $04, $00, $0c, $04, $04, $04, $0e,     { i }
               $02, $00, $06, $02, $02, $12, $0c,     { j }
               $08, $08, $09, $0a, $0c, $0a, $09,     { k }
               $0c, $04, $04, $04, $04, $04, $0e,     { l }
               $00, $00, $0a, $15, $15, $11, $11,     { m }
               $00, $00, $16, $19, $11, $11, $11,     { n }
               $00, $00, $0e, $11, $11, $11, $0e,     { o }
               $00, $00, $1e, $11, $19, $16, $10,     { p }
               $00, $00, $0e, $12, $16, $0a, $03,     { q }
               $00, $00, $0b, $0c, $08, $08, $08,     { r }
               $00, $00, $0e, $10, $0e, $01, $1e,     { s }
               $00, $08, $1c, $08, $08, $0a, $04,     { t }
               $00, $00, $11, $11, $11, $13, $0d,     { u }
               $00, $00, $11, $11, $11, $0a, $04,     { v }
               $00, $00, $11, $11, $15, $15, $0a,     { w }
               $00, $00, $11, $0a, $04, $0a, $11,     { x }
               $00, $00, $11, $0a, $04, $04, $08,     { y }
               $00, $00, $1f, $02, $04, $08, $1f,     { z }
               $02, $04, $04, $08, $04, $04, $02,     (* { *)
               $04, $04, $04, $00, $04, $04, $04,     { | }
               $08, $04, $04, $02, $04, $04, $08,     (* } *)
               $00, $00, $08, $15, $02, $00, $00,     { ~ }
               $0a, $15, $0a, $15, $0a, $15, $0a);    { DEL }

  SegSize: array[TVrMatrixLedStyle] of Integer = (1, 2, 3);

  SegX = 5;
  SegY = 7;
  ColorCmd = '%';

  ColorArray: array[1..16] of TColor = (
    clBlack, clMaroon, clGreen, clOlive, clNavy, clPurple,
    clTeal, clGray, clSilver, clRed, clLime, clYellow,
    clBlue, clFuchsia, clAqua, clWhite);

  //Each color code is made out of a percentage charater and a combination
  //of a digit or a letter: for example "%CHello" will display all characters in clYellow.
  //Combinations are also possible: %CH%0ello. This will only display the
  //"H" in a different color.

  //Codes are as follows:
  //1 = clBlack       A = clRed
  //2 = clMaroon      B = clLime
  //3 = clGreen       C = clYellow
  //4 = clOlive       D = clBlue
  //5 = clNavy        E = clFuchsia
  //6 = clPurple      F = clAqua
  //7 = clTeal        G = clWhite
  //8 = clGray
  //9 = clSilver

  //Note: in order to reset to the default palette color use "%0", or
  //to display a % character use %%.

function CountChars(const S: string): Integer;
var
  I: Integer;
begin
  I := 1;
  Result := 0;
  while I <= Length(S) do
  begin
    if S[I] = ColorCmd then
    begin
      Inc(I);
      if (I <= Length(S)) and (S[I] = ColorCmd) then
      begin
        Inc(Result);
        Inc(I);
      end else Inc(I);
    end
    else
    begin
      Inc(Result);
      Inc(I);
    end;
  end;
end;

{ TVrMatrixData }

constructor TVrMatrixData.Create;
begin
  inherited Create;
  FStyle := tsAsIs;
end;

procedure TVrMatrixData.DecodeColorCode(var S: string);
begin
  FCurrColor := '-';
  if S <> '' then
  begin
    if Upcase(S[1]) in ['0'..'9', 'A'..'G'] then
      FCurrColor := S[1];
    Delete(S, 1, 1);
  end;
end;

procedure TVrMatrixData.InsertChar(var S: string);
begin