vrmatrix.pas

作工控的好控件

  if S <> '' then
  begin
    FData := FData + S[1];
    FColors := FColors + FCurrColor;
    Delete(S, 1, 1);
  end;
end;

procedure TVrMatrixData.Decode(S: string);
begin
  FOrigin := S;
  FData := '';
  FColors := '';
  FCurrColor := '-';
  while Length(S) > 0 do
  begin
    if S[1] = ColorCmd then
    begin
      Delete(S, 1, 1);
      if (S <> '') and (S[1] = ColorCmd) then
        InsertChar(S)
      else DecodeColorCode(S);
    end else InsertChar(S);
  end;
end;

procedure TVrMatrixData.MoveLeft;
begin
  FData := Copy(FData, 2, Length(FData) - 1) + Copy(FData, 1, 1);
  FColors := Copy(FColors, 2, Length(FColors) - 1) + Copy(FColors, 1, 1);
end;

procedure TVrMatrixData.MoveRight;
begin
  FData := Copy(FData, Length(FData), 1) + Copy(FData, 0, Length(FData) - 1);
  FColors := Copy(FColors, Length(FColors), 1) + Copy(FColors, 0, Length(FColors) - 1);
end;

procedure TVrMatrixData.Reset;
begin
  Decode(FOrigin);
  SetStyle(FStyle);
end;

procedure TVrMatrixData.SetStyle(Value: TVrMatrixTextStyle);
begin
  FStyle := Value;
  case FStyle of
    tsUpperCase: FData := AnsiUpperCase(FData);
    tsLowerCase: FData := AnsiLowerCase(FData);
    tsProperCase:
      begin
        FData := AnsiLowerCase(FData);
        if FData <> '' then
          FData[1] := Upcase(FData[1]);
      end;
    tsAsIs:; //do nothing
  end;
end;

{TVrMatrix}

constructor TVrMatrix.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque] - [csSetCaption];
  Width := 245;
  Height := 30;
  ParentColor := false;
  Color := clBlack;
  FLeds := 15;
  FSpacing := 2;
  FAlignment := taLeftjustify;
  FTextStyle := tsUpperCase;
  FAutoScroll := false;
  FCharIndex := 1;
  FScrollDirection := msdRightToLeft;
  FLedStyle := ls14x20;
  FLedsVisible := True;
  FOrientation := voHorizontal;
  FPalette := TVrPalette.Create;
  FPalette.OnChange := PaletteModified;
  FBevel := TVrBevel.Create;
  with FBevel do
  begin
    InnerStyle := bsLowered;
    InnerWidth := 2;
    InnerColor := clBlack;
    OnChange := BevelChanged;
  end;
  Bitmap := TBitMap.Create;
  LoadBitmaps;
  FThreaded := True;
  FTimer := TVrTimer.Create(Self);
  FTimer.Enabled := false;
  FTimer.Interval := 500;
  FTimer.OnTimer := TimerEvent;
  FString := TVrMatrixData.Create;
end;

destructor TVrMatrix.Destroy;
begin
  DestroyBitmaps;
  FString.Free;
  FBevel.Free;
  FPalette.Free;
  FTimer.Free;
  inherited Destroy;
end;

procedure TVrMatrix.Loaded;
begin
  inherited Loaded;
  CalcPaintParams;
end;

procedure TVrMatrix.LoadBitmaps;
const
  ResNames: array[TVrMatrixLedStyle] of PChar =
    ('9x13', '14x20', '19x27');
begin
  Bitmap.Handle := LoadBitmap(hInstance, PChar('VRMATRIXLED' + ResNames[FLedStyle]));
  FPalette.ToBMP(Bitmap, ResColorLow, ResColorHigh);
  FImageRect := Bounds(0, 0, Bitmap.Width, Bitmap.Height);
end;

procedure TVrMatrix.DestroyBitmaps;
begin
  Bitmap.Free;
end;

procedure TVrMatrix.PaletteModified(Sender: TObject);
begin
  LoadBitmaps;
  UpdateControlCanvas;
end;

procedure TVrMatrix.BevelChanged(Sender: TObject);
begin
  UpdateControlCanvas;
end;

procedure TVrMatrix.SetLeds(Value: Integer);
begin
  if FLeds <> Value then
  begin
    FLeds := Value;
    FormatText(Text);
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrix.SetSpacing(Value: Integer);
begin
  if FSpacing <> Value then
  begin
    FSpacing := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrix.FormatText(Value: string);
begin
  FString.Decode(Value);
  FString.SetStyle(FTextStyle);
end;

procedure TVrMatrix.SetTextStyle(Value: TVrMatrixTextStyle);
begin
  if FTextStyle <> Value then
  begin
    FTextStyle := Value;
    FormatText(Text);
    UpdateLeds(True);
  end;
end;

procedure TVrMatrix.SetAlignment(Value: TAlignment);
begin
  if FAlignment <> Value then
  begin
    FAlignment := Value;
    if (Designing) or (not FAutoScroll) then
      UpdateControlCanvas;
  end;
end;

procedure TVrMatrix.SetAutoScroll(Value: Boolean);
begin
  if FAutoScroll <> Value then
  begin
    FAutoScroll := Value;
    FCharIndex := 1;
    UpdateControlCanvas;
    if not (Designing or Loading) then
    begin
      ScrollInit := True;
      FTimer.Enabled := Value;
    end;
  end;
end;

procedure TVrMatrix.SetLedStyle(Value: TVrMatrixLedStyle);
begin
  if FLedStyle <> Value then
  begin
    FLedStyle := Value;
    LoadBitmaps;
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrix.SetLedsVisible(Value: Boolean);
begin
  if FLedsVisible <> Value then
  begin
    FLedsVisible := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrix.SetThreaded(Value: Boolean);
begin
  if FThreaded <> Value then
  begin
    FThreaded := Value;
    if Value then FTimer.TimerType := ttThread
    else FTimer.TimerType := ttSystem;
  end;
end;

procedure TVrMatrix.SetOrientation(Value: TVrOrientation);
begin
  if FOrientation <> Value then
  begin
    FOrientation := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrix.SetTimeInterval(Value: Integer);
begin
  FTimer.Interval := Value;
end;

function TVrMatrix.GetTimeInterval: Integer;
begin
  Result := FTimer.Interval;
end;

procedure TVrMatrix.SetPalette(Value: TVrPalette);
begin
  FPalette.Assign(Value);
end;

procedure TVrMatrix.SetBevel(Value: TVrBevel);
begin
  FBevel.Assign(Value);
end;

procedure TVrMatrix.CMTextChanged(var Message: TMessage);
begin
  inherited;
  FormatText(Text);
  UpdateControlCanvas;
end;

procedure TVrMatrix.UpdateLed(Index: Integer; Ch: Char; Color: TColor);
var
  R, ItemRect: TRect;
  I, J, Idx, W: Integer;
begin
  with BitmapCanvas do
  begin
    GetItemRect(Index, ItemRect);
    Brush.Style := bsSolid;
    Brush.Color := Self.Color;
    FillRect(ItemRect);
    if FLedsVisible then
    begin
      Brush.Style := bsClear;
      BrushCopy(ItemRect, Bitmap, FImageRect, clBlack);
    end;

    if Ch = #32 then Exit;

    Brush.Color := Color;
    Idx := ord(Ch) * 7;
    for I := 0 to 6 do
      for J := 0 to 4 do
      begin
        if CharState[Idx + I] and (1 shl J) > 0 then
        begin
          W := SegSize[FLedStyle];
          R := Bounds(ItemRect.Left + Bitmap.Width - W - (J * Succ(W)),
                      ItemRect.Top + (I * Succ(W)), W, W);
          FillRect(R);
        end;
      end;
  end;
end;

procedure TVrMatrix.UpdateLeds(Redraw: Boolean);
var
  I: Integer;
  Data, Colors: string;
  Idx: Integer;
  Color: TColor;

  function GetColorValue(Ch: Char): TColor;
  var
    ColorIndex: Integer;
  begin
    ColorIndex := 0;
    case Upcase(Ch) of
      '0'..'9' : ColorIndex := ord(Ch) - 48;    // 48 = ord('0')
      'A'..'G' : ColorIndex := ord(Ch) - 55;   // 'A' = 41h = 65d  ; minus 10 = 55d
    end;
    if (ColorIndex < 1) or (ColorIndex > 16) then
         Result := FPalette.High
      else Result := ColorArray[ColorIndex];
  end;

begin
  for I := 0 to FLeds - 1 do
    UpdateLed(I, #32, FPalette.High);

  Data := FString.Data;
  Colors := FString.Colors;
  Idx := FStartLed;
  for I := FCharIndex to Length(Data) do
  begin
    Color := GetColorValue(Colors[I]);
    UpdateLed(Idx, Data[I], Color);
    Inc(Idx);
    if Idx >= FLeds then Break;
  end;
  if not Loading then
    if Redraw then inherited Paint;
end;

procedure TVrMatrix.Paint;
var
  R: TRect;
begin
  CalcPaintParams;
  ClearBitmapCanvas;
  R := ClientRect;
  FBevel.Paint(BitmapCanvas, R);
  FCharIndex := 1;
  case FAlignment of
    taCenter: FStartLed := MaxIntVal(0, ((FLeds - Length(FString.Data)) div 2));
    taRightJustify: FStartLed := MaxIntVal(0, (FLeds - Length(FString.Data)));
    else FStartLed := 0;
  end;

  UpdateLeds(True);

  //Make sure we first display the control
  if (not Initialized) and (AutoScroll) then
  begin
    Initialized := True;
    ScrollInit := True;
    FTimer.Enabled := True;
  end;
end;

procedure TVrMatrix.CalcPaintParams;
var
  R: TRect;
  Gap, NewWidth, NewHeight: Integer;
begin
  R := ClientRect;
  FBevel.GetVisibleArea(R);
  Gap := (FLeds - 1) * FSpacing;

  if Orientation = voHorizontal then
  begin
    NewWidth := (R.Left * 2) + Gap + (FLeds * Bitmap.Width);
    NewHeight := (R.Top * 2) + Bitmap.Height;
  end
  else
  begin
    NewWidth := (R.Left * 2) + Bitmap.Width;
    NewHeight := (R.Top * 2) + Gap + (FLeds * Bitmap.Height);
  end;
  BoundsRect := Bounds(Left, Top, NewWidth, NewHeight);
end;

procedure TVrMatrix.GetItemRect(Index: Integer; var R: TRect);
var
  X, Y: Integer;
begin
  R := ClientRect;
  FBevel.GetVisibleArea(R);
  X := R.Left;
  Y := R.Top;
  if Orientation = voHorizontal then
    X := X + (Index * Bitmap.Width) + (Index * FSpacing)
  else Y := Y + (Index * Bitmap.Height) + (Index * FSpacing);
  R := Bounds(X, Y, Bitmap.Width, Bitmap.Height);
end;

procedure TVrMatrix.TimerEvent(Sender: TObject);
begin
  if (ScrollInit) then
  begin
    FCharIndex := 1;
    ScrollInit := false;
  end;

  if FScrollDirection = msdRightToLeft then
  begin
    if FStartLed > 0 then Dec(FStartLed)
    else if FCharIndex <= Length(FString.Data) then Inc(FCharIndex)
    else
    begin
      if Assigned(FOnScrollDone) then
        FOnScrollDone(Self);
      FCharIndex := 1;
      FStartLed := FLeds - 1;
    end;
  end
  else
  begin
    if (FCharIndex = 1) and (FStartLed < FLeds-1) then Inc(FStartLed)
    else
    if FCharIndex > 1 then
    begin
      Dec(FCharIndex);
      FStartLed := 0;
    end
    else
    begin
      if Assigned(FOnScrollDone) then
        FOnScrollDone(Self);
      FCharIndex := Length(FString.Data);
      FStartLed := 0;
    end;
  end;

  UpdateLeds(True);
end;

{ TVrMatrixGroup }

constructor TVrMatrixGroup.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  Width := 200;
  Height := 100;
  Color := clBlack;
  ParentColor := false;
  FCols := 15;
  FRows := 7;
  FCharSpacing := 1;
  FLineSpacing := 1;
  FPixelSize := 1;
  FPixelSpacing := 1;
  FScrollDirection := sdRightToLeft;
  FAutoScroll := false;
  FAlignment := taLeftjustify;
  FTextStyle := tsUpperCase;
  FPalette := TVrPalette.Create;
  FPalette.OnChange := PaletteModified;
  FBevel := TVrBevel.Create;
  with FBevel do
  begin
    InnerStyle := bsLowered;
    InnerWidth := 2;
    InnerColor := clBlack;
    OnChange := BevelChanged;