unit MsgSCR;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls;

type
  TMuki = (muYoko, muTate);
  TMsgSCR = class(TCustomPanel)
  private
    FMsg: String;
    FBMap: TBitMap;
    FX, FY, FLen,
    FStep: Integer;
    FTicker,
    FWrite: Boolean;
    FTimer: TTimer;
    FMuki: TMuki;

    Procedure DrawTate;
    Procedure DrawYoko;
    Function GetInterval: Integer;
    Procedure MakeBitMap;
    Procedure MakeBitTate;
    Procedure MakeBitYoko;
    procedure SetInterval(PValue: Integer);
    procedure SetTicker(PValue: Boolean);
    procedure SetMsg(PValue: String);
    Procedure SetMuki(Pmuki: TMuki);
    Procedure Start;
    Procedure Stop;
 protected
    procedure FTimerTimer(Sender: TObject);
    procedure Paint; override;
    Procedure WMFONTCHANGE(Var Msg: TWMFONTCHANGE); Message WM_FONTCHANGE;
  public
    constructor Create(AOwner: TComponent); OverRide;
    Destructor Destroy; OverRide;
  published
    Property Align;
    Property Color;
    Property Font;
    Property Interval: Integer Read GetInterval Write SetInterval;
    Property Ticker: Boolean Read FTicker Write SetTicker;
    Property Msg: String Read FMsg Write SetMsg;
    Property Muki: TMuki Read FMuki Write SetMuki;
    Property Step: Integer Read FStep Write FStep;
  end;

procedure Register;

implementation

{ Register }
procedure Register;
begin
  RegisterComponents('Samples', [TMsgSCR]);
end;

{ Create }
constructor TMsgSCR.Create(AOwner: TComponent);
Begin
  Inherited Create(AOwner);
  BevelOuter := bvNone;
  Canvas.Brush.Style := bsClear;
  FBMap := TBitmap.Create;
  SetMsg('らせん企画 謹製');
  { Timer 作成 }
  FTimer := TTimer.Create(Self);
  With FTimer Do
  Begin
    Enabled := False;
    Interval := 100;
    OnTimer := FTimerTimer
  End;
  FTicker := False;
  FWrite := False;
  FStep := 4;
End;

{ Destroy }
Destructor TMsgSCR.Destroy;
Begin
  FBMap.Free;
  FTimer.Free;
  inherited Destroy;
End;

{ DrawTate }
procedure TMsgSCR.DrawTate;
begin
  With Canvas Do
  Begin
    FWrite := True;
    Dec(FY,FStep);
    If FY + FLen <= 0 Then
    Begin
      FY := Height;
    End;
    Draw(0,FY,FBMap);
  End;
end;

{ DrawYoko }
procedure TMsgSCR.DrawYoko;
begin
  With Canvas Do
  Begin
    FWrite := True;
    Dec(FX,FStep);
    If FX + FLen <= 0 Then
    Begin
      FX := Width;
    End;
    Draw(FX,0,FBMap);
  End;
end;

{ GetInterval }
Function TMsgSCR.GetInterval: Integer;
Begin
  Result := FTimer.Interval;
End;

{ MakeBitMap }
procedure TMsgSCR.MakeBitMap;
begin
  Case FMuki Of
   muYoko: MakeBitYoko;
   muTate: MakeBitTate;
  End;
end;

{ MakeBitTate }
procedure TMsgSCR.MakeBitTate;
Var
  Fh, ix, y, x: Integer;
  WList: TStringList;
  WStr: String;
begin
  FBMap.Width := Width;
  With FBMap.Canvas Do
  Begin
    Brush.Color := Self.Color;
    FillRect(ClipRect);
  End;
  FBMap.Canvas.Font.Assign(Font);
  Fh := FBMap.Canvas.TextHeight(FMsg);
  WList := TStringList.Create;
  Try
    ix := 0;
    While ix < length(FMsg) Do
    Begin
      Inc(ix);
      If ByteType(FMsg, ix) = mbLeadByte Then
      Begin
        WStr := Copy(FMsg, ix, 2);
        Inc(ix);
      End
      Else
        If ix < Length(FMsg) Then
        Begin
          If ByteType(FMsg, ix + 1) = mbSingleByte Then
          Begin
            WStr := Copy(FMsg, ix, 2);
            Inc(ix);
          End
          Else
            WStr := Copy(FMsg, ix, 1);
        End
        Else
          WStr := Copy(FMsg, ix, 1);
      WList.Add(WStr);
    End;
    FLen := (Fh * WList.Count) + (Font.Size Div 2);
    FBMap.Height := FLen;
    y := 0;
    For ix := 0 To WList.Count - 1 Do
    Begin
      WStr := WList[ix];
      x := (Width - FBMap.Canvas.TextWidth(WStr)) Div 2;
      FBMap.Canvas.TextOut(x, y, WStr);
      Inc(y, Fh);
    End;
  Finally
    WList.Free;
  End;
end;

{ MakeBitYoko }
procedure TMsgSCR.MakeBitYoko;
Var
  y: Integer;
begin
  FBMap.Height := Height;
  With FBMap.Canvas Do
  Begin
    Brush.Color := Self.Color;
    FillRect(ClipRect);
  End;
  FBMap.Canvas.Font.Assign(Font);
  FLen := FBMap.Canvas.TextWidth(FMsg);
  If Width < FLen Then
    Inc(FLen , (Font.Size Div 2))
  Else
    FLen := Width + (Font.Size Div 2);
  FBMap.Width := FLen;
  y := (Height - FBMap.Canvas.TextHeight(FMsg)) Div 2;
  FBMap.Canvas.TextOut(0, y, FMsg);
end;

{ Paint }
procedure TMsgSCR.Paint;
Begin
  Inherited Paint;
  If (Parent <> Nil) And (FTimer.Enabled) Then
  Begin
    Stop;
    MakeBitMap;
    Start;
  End;
End;

{ SetInterval }
procedure TMsgSCR.SetInterval;
begin
  FTimer.Interval := PValue;
end;

{ SetMsg }
procedure TMsgSCR.SetMsg;
begin
  FMsg := PValue;
  Caption := FMsg;
  MakeBitMap;
end;

{ SetMuki }
procedure TMsgSCR.SetMuki;
begin
  FMuki := PMuki;
  MakeBitMap;
end;

{ SetTicker }
procedure TMsgSCR.SetTicker;
begin
  FTicker := PValue;
  If FTicker Then
  Begin
    MakeBitMap;
    Start;
  End
  Else
    Stop;
end;

{ Start }
procedure TMsgSCR.Start;
begin
  With Canvas Do
  Begin
    Brush.Color := Color;
    FillRect(ClipRect);
  End;
  FWrite := False;
  FY := Height;
  FX := Width;
  FTimer.Enabled := True;
end;

{ Stop }
procedure TMsgSCR.Stop;
begin
  FTimer.Enabled := False;
end;

{ FTimerTimer }
procedure TMsgSCR.FTimerTimer(Sender: TObject);
begin
  Case FMuki Of
   muYoko: DrawYoko;
   muTate: DrawTate;
  End;
end;

{ WMFONTCHANGE }
Procedure TMsgSCR.WMFONTCHANGE(Var Msg: TWMFONTCHANGE);
Begin
  Paint;
End;

end.
             98/11/6(Fri) 09:48am  BYQ05322 らせん企画の佐々木

Original document by らせん企画      氏 ID:(BYQ05322)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。