vrlcd.pas

作工控的好控件

  end;
end;

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

procedure TVrCustomNum.Change;
begin
  if Assigned(FOnChange) then FOnChange(self);
end;

procedure TVrCustomNum.RequestAlign;
begin
  inherited;
  if Align = alNone then UpdateControlCanvas;
end;

procedure TVrCustomNum.ChangeSize(NewWidth, NewHeight: Integer);
begin
  if (Align = alNone) then
    if (NewWidth <> Width) or (NewHeight <> Height) then
    begin
      Self.Width := NewWidth;
      Self.Height := NewHeight;
    end;
end;

procedure TVrCustomNum.DrawNum(Num: integer; X, Y: integer);
var
  R, D: TRect;
begin
  with BitmapCanvas do
  begin
    D := Bounds(X, Y, ImageWidth, ImageHeight);
    R := Bounds(Num * ImageWidth, 0, ImageWidth, ImageHeight);
    Brush.Style := bsClear;
    BrushCopy(D, Bitmap, R, clBlack);
  end;
end;

procedure TVrCustomNum.Paint;
var
  I, X, Y, W: Integer;
  S: string;
  Num, Chars: Integer;

  function PadLeft(str: string; Ch: Char; MaxWidth: Integer): string;
  begin
    while Length(str) < MaxWidth do
      str := Ch + str;
    Result := str;
  end;

begin
  ClearBitmapCanvas;

  Num := FValue;
  if Num < 0 then Num := -Num;

  Chars := FDigits;
  S := Format('%d', [Num]);
  if (FValue = 0) and (FZeroBlank) then S := '';
  if FLeadingZero then S := PadLeft(S, '0', Chars)
  else S := PadLeft(S, #32, Chars);

  if (BelowZero) then Inc(Chars);
  W := (Chars * ImageWidth) + (Pred(Chars) * FSpacing);

  if FAutoSize then
    ChangeSize(W, ImageHeight);

  case FAlignment of
    naLeftJustify: X := 0;
    naRightJustify: X := ClientWidth - W;
    else X := (ClientWidth - W) div 2;
  end;
  Y := (Self.Height - ImageHeight) div 2;

  if BelowZero then
  begin
    if (FValue >= 0) then
      DrawNum(11, X, Y) else DrawNum(12, X, Y);
    Inc(X, ImageWidth + FSpacing);
  end;

  for I := 1 to Length(S) do
  begin
    if (S[I] = #32) then DrawNum(10, X, Y)
    else DrawNum(StrToInt(S[I]), X, Y);
    Inc(X, ImageWidth + FSpacing);
  end;

  inherited Paint;
end;


{TVrClock}

constructor TVrClock.Create(AOwner: TCOmponent);
begin
  inherited Create(AOwner);
  Width := 140;
  FHours := 0;
  FMinutes := 0;
  FSeconds := 0;
  FShowSeconds := false;
  FBlink := false;
  FHours24 := True;
  FShowTimeZone := false;
  FThreaded := True;
  FTimer := TVrTimer.Create(Self);
  FTimer.Enabled := false;
  FTimer.OnTimer := OnTimerEvent;
end;

destructor TVrClock.Destroy;
begin
  FTimer.Free;
  FSeperator.Free;
  FTimeZoneImage.Free;
  inherited Destroy;
end;

procedure TVrClock.Loaded;
begin
  inherited Loaded;
  if (FClockType = ctRealTime) and (not Designing) then
    OnTimerEvent(Self);
end;

procedure TVrClock.LoadBitmaps;
begin
  inherited LoadBitmaps;
  if not Assigned(FSeperator) then
  begin
    FSeperator := TBitmap.Create;
    FSeperator.Transparent := True;
  end;
  if not Assigned(FTimeZoneImage) then
    FTimeZoneImage := TBitmap.Create;

  FSeperator.Handle := LoadBitmap(hInstance, ResClockId[Style]);
  FPalette.ToBMP(FSeperator, ResColorLow, ResColorHigh);
  FTimeZoneImage.Handle := LoadBitmap(hInstance, ResTimeZoneId[Style]);
  FPalette.ToBMP(FTimeZoneImage, ResColorLow, ResColorHigh);
end;

procedure TVrClock.HoursChanged;
begin
  if Assigned(FOnHoursChanged) then
    FOnHoursChanged(Self, FHours);
end;

procedure TVrClock.MinutesChanged;
begin
  if Assigned(FOnMinutesChanged) then
    FOnMinutesChanged(Self, FMinutes);
end;

procedure TVrClock.SecondsChanged;
begin
  if Assigned(FOnSecondsChanged) then
    FOnSecondsChanged(Self, FSeconds);
end;

procedure TVrClock.SetHours(Value: TVrHoursInt);
begin
  if FHours <> Value then
  begin
    FHours := Value;
    UpdateControlCanvas;
    HoursChanged;
  end;
end;

procedure TVrClock.SetMinutes(Value: TVrMinutesInt);
begin
  if FMinutes <> Value then
  begin
    FMinutes := Value;
    UpdateControlCanvas;
    MinutesChanged;
  end;
end;

procedure TVrClock.SetSeconds(Value: TVrSecondsInt);
begin
  if FSeconds <> Value then
  begin
    FSeconds := Value;
    UpdateControlCanvas;
    SecondsChanged;
  end;
end;

procedure TVrClock.SetActive(Value: Boolean);
begin
  if (Value) and (FClockType = ctCustom) then
    Value := false;
  if (FActive <> Value) then
  begin
    FActive := Value;
    FBlinkVisible := True;
    UpdateControlCanvas;
    if Designing then Exit;
    if FActive then ElapsedTime := Now;
    FTimer.Enabled := FActive;
  end;
end;

procedure TVrClock.SetClockType(Value: TVrClockType);
begin
  if (FClockType <> Value) then
  begin
    FClockType := Value;
    if FClockType <> ctCustom then
    begin
      FHours := 0;
      FMinutes := 0;
      FSeconds := 0;
    end
   else
    if Active then Active := false;
    UpdateControlCanvas;
  end;
end;

procedure TVrClock.SetShowSeconds(Value: Boolean);
begin
  if FShowSeconds <> Value then
  begin
    FShowSeconds := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrClock.SetBlink(Value: Boolean);
begin
  if FBlink <> Value then
  begin
    FBlink := Value;
    FBlinkVisible := True;
    UpdateControlCanvas;
  end;
end;

procedure TVrClock.SetShowTimeZone(Value: Boolean);
begin
  if FShowTimeZone <> Value then
  begin
    FShowTimeZone := Value;
    UpdateControlCanvas;
  end;
end;

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

procedure TVrClock.DrawTimeZone(Hrs: Integer; X, Y: integer);
var
  R, D: TRect;
  W, H, Index: Integer;
begin
  with BitmapCanvas do
  begin
    Index := 0;
    if Hrs < 12 then Index := 1;
    W := FTimeZoneImage.Width div 2;
    H := FTimeZoneImage.Height;
    D := Bounds(X, Y, W, H);
    R := Bounds(Index * W, 0, W, H);
    Brush.Style := bsClear;
    BrushCopy(D, FTimeZoneImage, R, clBlack);
  end;
end;

procedure TVrClock.OnTimerEvent(Sender: TObject);
var
  H, M, S, S100: Word;
  Ho, Mo, So: Word;
  T: TDateTime;
  SecsChanged: Boolean;
begin
  //store old values
  Ho := FHours;
  Mo := FMinutes;
  So := FSeconds;

  case FClockType of
    ctRealTime: T := Now;
    ctElapsed: T := Now - ElapsedTime;
    else
      T := 0; //This should never occure
  end;

  DecodeTime(T, H, M, S, S100);
  FHoursInternal := H;
  FHours := H;
  if not FHours24 then
  begin
    FHours := FHours mod 12;
    if FHours = 0 then FHours := 12;
  end;

  FMinutes := M;
  FSeconds := S;
  FBlinkVisible := not FBlinkVisible;

  SecsChanged := (FShowSeconds) and (So <> FSeconds);
  if (SecsChanged) or (FBlink) or (FMinutes <> Mo) then
    UpdateControlCanvas;

  if (FHours <> Ho) then HoursChanged;
  if (FMinutes <> Mo) then MinutesChanged;
  if (FSeconds <> So) then SecondsChanged;
end;

procedure TVrClock.Paint;
var
  I, X, Y, W: Integer;
  NumDigits: Integer;
  NumSpacing: Integer;
  S: string;
begin
  ClearBitmapCanvas;

  NumDigits := 4;
  NumSpacing := 4;
  if FShowSeconds then
  begin
    Inc(NumDigits, 2);
    Inc(NumSpacing, 3);
  end;

  W := (NumDigits * ImageWidth);
  W := W + (FSeperator.Width * (ord(FShowSeconds) + 1));
  W := W + (NumSpacing * FSpacing);
  if (ShowTimeZone) and (ClockType = ctRealTime) then
    Inc(W, FSpacing + FTimeZoneImage.Width div 2);

  if FAutoSize then
    ChangeSize(W, ImageHeight);

  X := (Width - W) div 2;
  Y := (Self.Height - ImageHeight) div 2;

  S := Format('%.2d:%.2d', [FHours, FMinutes]);
  if FShowSeconds then
    S := S + Format(':%.2d', [FSeconds]);

  for I := 1 to Length(S) do
  begin
    if (S[I] = ':') then
    begin
      if (FClockType = ctCustom) or
         (not FBlink) or (FBlink and FBlinkVisible) then
        BitmapCanvas.Draw(X, Y, FSeperator);
      Inc(X, FSeperator.Width + FSpacing);
    end
   else
    begin
      DrawNum(StrToInt(S[I]), X, Y);
      Inc(X, ImageWidth + FSpacing);
    end;
  end;

  if (ShowTimeZone) and (ClockType = ctRealTime) then
    DrawTimeZone(FHoursInternal, X, Y);

  with inherited Canvas do
    Draw(0, 0, BitmapImage);
end;


end.