月別アーカイブ: 2013年10月

正確なタイマーを無理やり作る

コメントをどうぞ 
Firemonkey TTimer はざっくりしすぎているので、TStopWatch を使って正確な時間を測る。
これでずいぶん正確になった。



unit untTaskIndicater;

interface

uses
  untViewer,
  untWordDic,
  untWaveFilePlayer,
  untClientManager,

  System.Diagnostics,
  MMsystem,
  FMX.Filter.Effects,
  FMX.Objects,
  FMX.Types,
  FMX.Dialogs,
  System.Types,
  System.UITypes,
  SysUtils;

const
  CLOCK_INTERVAL = 5;

type
  TTaskIndicator = class
  private

    FWordRecord: TWordRecord;
    FRoughTimer: TTimer;
    FIndicatingIndex: Integer;

    FIsVoiceOnly: Boolean;
    FStopwatch :TStopwatch;

    procedure OnRoughTimer(Sender: TObject);
  public
    constructor Create();
    destructor Destroy(); override;

    procedure Reset();
    procedure Indicate(aWordRecord: TWordRecord; aIsVoiceOnly: Boolean);

  end;

implementation

uses
  untModel,
  untMainForm;

constructor TTaskIndicator.Create;
begin
  FStopwatch.Create;

  FRoughTimer := TTimer.Create(nil);
  FRoughTimer.OnTimer  := OnRoughTimer;
  FRoughTimer.Enabled  := False;
  FRoughTimer.Interval := CLOCK_INTERVAL;
end;

destructor TTaskIndicator.Destroy;
begin

  FRoughTimer.Free;
  inherited;
end;

procedure TTaskIndicator.Indicate(aWordRecord: TWordRecord; aIsVoiceOnly: Boolean);
var
  i: Integer;
begin
  FIsVoiceOnly := aIsVoiceOnly;
  FWordRecord := aWordRecord;

  Viewer.DispAllPlanes();

  // タイマーが動く前に再生開始が望ましい
  WaveFilePlayer.Play(FWordRecord.VoiceStream);

  FRoughTimer.Enabled  := True;
  FStopwatch.Reset;
  FStopwatch.Start;

  FIndicatingIndex := -1;

end;

procedure TTaskIndicator.OnRoughTimer(Sender: TObject);
var
  tmpTime: Integer;
begin
  // For Pause
  if Model.IsPausing then Exit;

   tmpTime := FStopwatch.ElapsedMilliseconds;

  // 終了条件
  if FWordRecord.IndicateScheduleArray[Length(FWordRecord.IndicateScheduleArray)-1].EndTime <= tmpTime then
  begin
    Viewer.DeAccentPlane(Length(FWordRecord.IndicateScheduleArray)-1);
    if not FIsVoiceOnly then Viewer.DispAllPlanes();
    FRoughTimer.Enabled := False;
    FStopwatch.Stop;
    Model.onIndicaterFinished(); // 終わりを知らせる
  end;

  if not FIsVoiceOnly then
  begin
   if FWordRecord.IndicateScheduleArray[FIndicatingIndex+1].StartTime <= tmpTime then
   begin
     FIndicatingIndex := FIndicatingIndex + 1;

     if FIndicatingIndex <> 0 then Viewer.DeAccentPlane(FIndicatingIndex-1);
     Viewer.AccentPlane(FIndicatingIndex);
   end;
  end;

end;

procedure TTaskIndicator.Reset;
begin
  FRoughTimer.Enabled := False;
end;

end.

Firemonkey の TCheckbox のイベントについて

コメントをどうぞ

onChange イベントは変更後の IsChecked を正しく持っている。
ただし、コードによって変更された場合もこのイベントは起こってしまう。

onClick イベントは、変更される前に呼び出されてしまう。

で、インターバル50msくらいのタイマーを置いて、こんな感じ。

procedure TfrmMain.tmrForCheckBoxTimer(Sender: TObject);
begin
  DispSearchResult();
  tmrForCheckBox.Enabled := False;
end;

procedure TfrmMain.chkIsOnlySeionClick(Sender: TObject);
begin
  tmrForCheckBox.Enabled := True;
end;

もっといい方法が絶対あるはずだけど、とりあえずこれでOK。

フォントの一覧を所得 Windows

コメントをどうぞ

uses に Windows


procedure TfrmMain.initFontCombo;
var
  tmpFileList: TstringList;
  tmpFolderName: string;
  i: Integer;
  DC:HDC;

  function EnumFamToLines(lplf: PLOGFONT; lpntm: PNEWTEXTMETRIC;
                            FontType: DWORD; Lines: LPARAM): Integer; stdcall;
  begin
    with lplf^ do
//      if    (lfCharSet = SHIFTJIS_CHARSET) and (lfPitchAndFamily and $0F = FIXED_PITCH) then
      // シフトJIS文字セット
      if    (lfCharSet = SHIFTJIS_CHARSET) then
        TStrings(Lines).Add(lplf.lfFaceName);
    Result := 1;
  end;

begin
  tmpFileList := TstringList.Create();
  DC := GetDC(0);
  tmpFileList.Clear;
  EnumFontFamilies(DC, nil, @EnumFamToLines, LongInt(tmpFileList));
  for i := 0 to tmpFileList.Count - 1 do
    if pos('@', tmpFileList[i]) = 0 then
      frmConfig.cmbDesignFontName.Items.Add(tmpFileList[i]);
  tmpFileList.Free;
end;