vrmatrix.pas

作工控的好控件

  end;
  FThreaded := True;
  FTimer := TVrTimer.Create(Self);
  with FTimer do
  begin
    FTimer.Enabled := false;
    FTimer.Interval := 500;
    FTimer.OnTimer := TimerEvent;
  end;
  FLines := TStringList.Create;
  TStringList(FLines).OnChange := LinesChanged;
  FLedImage := TBitmap.Create;
  FLedImage.Transparent := false;
  FMatrixImage := TBitmap.Create;
  FMatrixImage.Transparent := false;
  CreateLedImage;
  CreateDataList;
end;

destructor TVrMatrixGroup.Destroy;
begin
  ClearDataList(True);
  FBevel.Free;
  FPalette.Free;
  FTimer.Free;
  FLines.Free;
  FLedImage.Free;
  FMatrixImage.Free;
  inherited Destroy;
end;

procedure TVrMatrixGroup.Loaded;
begin
  inherited Loaded;
  FColorChanged := True;
  CreateLedImage;
end;

procedure TVrMatrixGroup.CreateDataList;
var
  I: Integer;
begin
  if not Assigned(FList) then
    FList := TList.Create;
  ClearDataList(false);
  for I := 0 to (Rows * 2) - 1 do
    FList.Add(TVrMatrixData.Create);
end;

procedure TVrMatrixGroup.ClearDataList(FreeList: Boolean);
var
  I: Integer;
begin
  for I := 0 to FList.Count - 1 do
    TVrMatrixData(FList[I]).Free;
  FList.Clear;
  if FreeList then
    FList.Free;
end;

procedure TVrMatrixGroup.Reset;
var
  I: Integer;
begin
  AutoScroll := false;
  for I := 0 to FList.Count - 1 do
    TVrMatrixData(FList[I]).Reset;
  UpdateControlCanvas;
end;

procedure TVrMatrixGroup.CreateLedImage;
var
  R: TRect;
  X, Y: Integer;
begin
  with FLedImage do
  begin
    Width := ((PixelSize + PixelSpacing) * SegX) - PixelSpacing;
    Height := ((PixelSize + PixelSpacing) * SegY) - PixelSpacing;
    Canvas.Brush.Color := Self.Color;
    Canvas.FillRect(Bounds(0, 0, Width, Height));

    X := 0;
    while X <= Width do
    begin
      Y := 0;
      while Y <= Height do
      begin
        R := Bounds(X, Y, PixelSize, PixelSize);
        Canvas.Brush.Color := FPalette.Colors[0];
        Canvas.FillRect(R);
        Inc(Y, PixelSize + PixelSpacing);
      end;
      Inc(X, PixelSize + PixelSpacing);
    end;
  end;

  with FMatrixImage do
  begin
    Width := ((FLedImage.Width + FCharSpacing + 1) * FCols) - FCharSpacing;
    Height := ((FLedImage.Height + FLineSpacing + 1) * FRows) - FLineSpacing;
    Canvas.Brush.Color := Self.Color;
    Canvas.FillRect(Bounds(0, 0, Width, Height));

    X := 0;
    while X <= Width do
    begin
      Y := 0;
      while Y <= Height do
      begin
        Canvas.Draw(X, Y, FLedImage);
        Inc(Y, FLedImage.Height + LineSpacing + 1);
      end;
      Inc(X, FLedImage.Width + CharSpacing + 1);
    end;
  end;
end;

function TVrMatrixGroup.GetItemRect(Index: Integer): TRect;
var
  X, Y: Integer;
begin
  X := (Index mod FCols) * (FLedImage.Width + CharSpacing + 1);
  Y := (Index div FCols) * (FLedImage.Height + LineSpacing + 1);
  Result := Bounds(FViewPort.Left + X, FViewPort.Top + Y, FLedImage.Width, FLedImage.Height);
end;

procedure TVrMatrixGroup.UpdateLed(Index: Integer; Ch: Char; Color: TColor);
var
  R, ItemRect: TRect;
  I, J, Idx, W: Integer;
begin
  if Ch = #32 then Exit;
  with BitmapCanvas do
  begin
    ItemRect := GetItemRect(Index);
    Brush.Color := Color;
    Idx := ord(Ch) * 7;
    W := PixelSize;
    for I := 0 to SegY - 1 do
      for J := 0 to SegX - 1 do
      begin
        if CharState[Idx + I] and (1 shl J) > 0 then
        begin
          R := Bounds(ItemRect.Left + FLedImage.Width - W - (J * Succ(PixelSpacing)),
                      ItemRect.Top + (I * Succ(PixelSpacing)), W, W);
          FillRect(R);
        end;
      end;
  end;
end;

procedure TVrMatrixGroup.UpdateRow(ARow: Integer);
var
  Idx, I: Integer;
  Color: TColor;
  Data, Colors: string;

  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
  if ARow > Rows - 1 then
    Exit;
  Data := TVrMatrixData(FList[ARow]).Data;
  Colors := TVrMatrixData(FList[ARow]).Colors;
  Idx := ARow * Cols;
  for I := 1 to Length(Data) do
  begin
    Color := GetColorValue(Colors[I]);
    UpdateLed(Idx, Data[I], Color);
    Inc(Idx);
    if Idx >= (ARow * FCols) + FCols then Break;
  end;
end;

procedure TVrMatrixGroup.Paint;
var
  I: Integer;
begin
  CalcPaintParams;
  FViewPort := ClientRect;
  FBevel.Paint(BitmapCanvas, FViewPort);
  with BitmapCanvas do
    Draw(FViewPort.Left, FViewPort.Top, FMatrixImage);
  for I := 0 to Rows - 1 do UpdateRow(I);
  inherited Paint;
  //Make sure we first display the control
  if (not FInitialized) and (AutoScroll) then
  begin
    FInitialized := True;
    FTimer.Enabled := True;
  end;
end;

procedure TVrMatrixGroup.CalcPaintParams;
var
  R: TRect;
  NewWidth, NewHeight: Integer;
begin
  R := ClientRect;
  Bevel.GetVisibleArea(R);
  NewWidth := FMatrixImage.Width + (R.Left * 2);
  NewHeight := FMatrixImage.Height + (R.Top * 2);
  BoundsRect := Bounds(Left, Top, NewWidth, NewHeight);
end;

procedure TVrMatrixGroup.TimerEvent(Sender: TObject);
var
  I: Integer;
begin
  if (FScrollDirection in [sdRightToLeft, sdLeftToRight]) then
  begin
    for I := 0 to Rows - 1 do
        case FScrollDirection of
          sdRightToLeft: TVrMatrixData(FList[I]).MoveLeft;
          sdLeftToRight: TVrMatrixData(FList[I]).MoveRight;
        end;
  end
  else
  if FScrollDirection = sdTopToBottom then
  begin
    FList.Add(FList[0]);
    FList.Delete(0);
  end
  else
  begin
    FList.Insert(0, FList[FList.Count - 1]);
    FList.Delete(FList.Count - 1);
  end;
  UpdateControlCanvas;
end;

procedure TVrMatrixGroup.FormatStrings;
var
  S: string;
  I, MaxLen, Count: Integer;
  Strings: TStringList;

  function Center(S: string; Width: Integer): string;
  var
    Append: Boolean;
    Cnt: Integer;
  begin
    Result := S;
    Cnt := CountChars(S);
    Append := True;
    while Cnt < Width do
    begin
      if Append then Result := Result + #32 else Result := #32 + Result;
      Append := not Append;
      Inc(Cnt);
    end;
  end;

  function RightJustify(S: string; Width: Integer): string;
  var
    Cnt: Integer;
  begin
    Result := S;
    Cnt := CountChars(S);
    while Cnt < Width do
    begin
      Result := #32 + Result;
      Inc(Cnt);
    end;
  end;

begin
  Strings := TStringList.Create;
  try
    for I := 0 to Lines.Count - 1 do
      case Alignment of
        taCenter: Strings.Add(Center(Lines[I], Cols));
        taRightJustify: Strings.Add(RightJustify(Lines[I], Cols));
        else Strings.Add(Lines[I]);
      end;

    while Strings.Count < Rows * 2 do Strings.Add(#32);

    MaxLen := Cols;
    for I := 0 to Strings.Count - 1 do
      MaxLen := MaxIntVal(MaxLen, CountChars(Strings[I]));

    for I := 0 to Strings.Count - 1 do
    begin
      S := Strings[I];
      Count := CountChars(S);
      while Count < MaxLen + Cols do
      begin
        S := S + #32;
        Inc(Count);
      end;
      TVrMatrixData(FList[I]).Decode(S);
      TVrMatrixData(FList[I]).SetStyle(FTextStyle);
    end;

  finally
    Strings.Free;
  end;
end;

procedure TVrMatrixGroup.PaletteModified(Sender: TObject);
begin
  CreateLedImage;
  UpdateControlCanvas;
end;

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

procedure TVrMatrixGroup.LinesChanged(Sender: TObject);
begin
  FormatStrings;
  UpdateControlCanvas;
end;

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

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

procedure TVrMatrixGroup.SetLines(Value: TStrings);
begin
  FLines.Assign(Value);
end;

procedure TVrMatrixGroup.SetCols(Value: TVrColInt);
begin
  if FCols <> Value then
  begin
    FCols := Value;
    CreateLedImage;
    FormatStrings;
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrixGroup.SetRows(Value: TVrRowInt);
begin
  if FRows <> Value then
  begin
    FRows := Value;
    CreateDataList;
    CreateLedImage;
    FormatStrings;
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrixGroup.SetCharSpacing(Value: Integer);
begin
  if FCharSpacing <> Value then
  begin
    FCharSpacing := Value;
    CreateLedImage;
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrixGroup.SetLineSpacing(Value: Integer);
begin
  if FLineSpacing <> Value then
  begin
    FLineSpacing := Value;
    CreateLedImage;
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrixGroup.SetPixelSize(Value: Integer);
begin
  if FPixelSize <> Value then
  begin
    FPixelSize := Value;
    CreateLedImage;
    UpdateControlCanvas;
  end;
end;

procedure TVrMatrixGroup.SetPixelSpacing(Value: Integer);
begin
  if FPixelSpacing <> Value then
  begin
    FPixelSpacing := Value;
    CreateLedImage;
    UpdateControlCanvas;
  end;
end;

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

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

procedure TVrMatrixGroup.SetTextStyle(Value: TVrMatrixTextStyle);
begin
  if FTextStyle <> Value then
  begin
    FTextStyle := Value;
    FormatStrings;
    UpdateControlCanvas;
  end;
end;

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

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

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

procedure TVrMatrixGroup.CMColorChanged(var Message: TMessage);
begin
  inherited;
  if FColorChanged then
  begin
    CreateLedImage;
    UpdateControlCanvas;
  end;
end;


end.