RSS订阅 | 匿名投稿
您的位置:网站首页 > 时间 > 正文

Delphi版毫秒级高精秒表

作者:admin 来源:未知 日期:2010/5/1 20:42:18 人气: 标签:


在玩一个非常无聊的小游戏时为了保存纪录,需要计时,而且要精确到毫秒,随时可暂停并继续,并且能保存当前的时间。这样的小软件无需上网到处找,随便自己写一个算了。

实现原理非常简单,利用一个API函数 GetTickCount 即可,其它都是一些辅助性功能。界面懒得去弄了,要的是功能。看代码。

unit Unit1;

interface

uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
    Dialogs, StdCtrls, ExtCtrls, ShellApi, TlHelp32, mmsystem;

type
    TForm1 = class(TForm)
        B1: TButton;
        B2: TButton;
        B3: TButton;
        Timer1: TTimer;
        Timer2: TTimer;
        BtnRun: TButton;
        B4: TButton;
        B5: TButton;
        L1: TLabel;
        procedure B1Click(Sender: TObject);
        procedure Timer1Timer(Sender: TObject);
        procedure FormCreate(Sender: TObject);
        procedure B2Click(Sender: TObject);
        procedure B3Click(Sender: TObject);
        procedure Timer2Timer(Sender: TObject);
        procedure B4Click(Sender: TObject);
        procedure BtnRunClick(Sender: TObject);
        procedure B5Click(Sender: TObject);
    private
        { Private declarations }
    public
        { Public declarations }
    end;

var
    Form1: TForm1;
    iStart, iPauseStart, iElipse: LongInt;
    iFlash: integer;
    strFlash: string;
implementation

{$R *.dfm}

function CheckTask(ExeFileName: string): Boolean;
const
    PROCESS_TERMINATE = $0001;
var
    ContinueLoop: BOOL;
    FSnapshotHandle: THandle;
    FProcessEntry32: TProcessEntry32;
begin
    result := False;
    FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
    FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
    ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
    while integer(ContinueLoop) <> 0 do
    begin
        if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
            UpperCase(ExeFileName))
            or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName)))
                then
            result := True;
        ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
    end;
end;


procedure TForm1.B1Click(Sender: TObject);
begin
    iStart := GetTickCount;
    Timer1.Enabled := True;
    B1.Enabled := False;
    B2.Enabled := True;
    B3.Enabled := True;
    B3.Caption := '结束';
    B2.Caption := '暂停';
    L1.Font.Color := clBlue;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
    iHour, iMin, iSec, iMSec: string;
    i: integer;
begin
    iElipse := GetTickCount - iStart;
    i := iElipse mod 1000;
    iMSec := inttostr(i);
    if Length(iMSec) = 1 then iMSec := '00' + iMSec;
    if Length(iMSec) = 2 then iMSec := '0' + iMSec;

    iSec := inttostr(Trunc(iElipse div 1000) mod 60);
    if Length(iSec) = 1 then iSec := '0' + iSec;

    iMin := inttostr(Trunc(iElipse div 1000 div 60) mod 60);
    if Length(iMin) = 1 then iMin := '0' + iMin;

    iHour := inttostr(Trunc(iElipse div 1000 div 60 div 60) mod 60);
    if Length(iHour) = 1 then iHour := '0' + iHour;

    L1.Caption := iHour + '时' + iMin + '分' + iSec + '秒' + iMSec + '毫秒';

    //声音提示:
    if (iSec = '00') and (iMin <> '00') and (iMin <> '20')
        and (iMin <> '30') and (i <= 100) then
        PlaySound('ding.wav', 0, SND_ASYNC);

    if (iSec = '00') and (iMin = '20') and (i <= 100) then
        PlaySound('20.wav', 0, SND_ASYNC);

    if (iSec = '00') and (iMin = '30') and (i <= 100) then
        PlaySound('30.wav', 0, SND_ASYNC);


end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    Form1.DoubleBuffered := True;
    Form1.Top := 0;
    SetWindowPos(Handle, Hwnd_Topmost, 0, 0, 0, 0,
        (SWP_NOMOVE or SWP_NOSIZE));
end;

procedure TForm1.B2Click(Sender: TObject);
begin
    if B2.Caption = '暂停' then
    begin
        Timer1.Enabled := False;
        iPauseStart := GetTickCount;
        B2.Caption := '继续';
        strFlash := L1.Caption;
        Timer2.Enabled := True;
        Form1.Caption := '高精度秒表 -- 暂停';
        Exit;
    end else
    begin
        Timer1.Enabled := True;
        iStart := iStart + GetTickCount - iPauseStart; //累加中间停顿时间;
        B2.Caption := '暂停';
        L1.Font.Color := clBlue;
        Timer2.Enabled := False;
        Form1.Caption := '高精度秒表';
        Exit;
    end;

end;

procedure TForm1.B3Click(Sender: TObject);
begin
    if B3.Caption = '结束' then
    begin
        Timer1.Enabled := False;
        Timer2.Enabled := False;
        if L1.Caption = '' then L1.Caption := strFlash;
        L1.Font.Color := clRed;
        Form1.Caption := '高精度秒表';
        B1.Enabled := True;
        B2.Enabled := False;
        B2.Caption := '暂停';
        B3.Caption := '清零';
        Exit;
    end else //清零
    begin
        L1.Caption := '00时00分00秒000毫秒';
        L1.Font.Color := clBlue;
        B3.Caption := '结束';
        B3.Enabled := False;
        Exit;
    end;
end;

procedure TForm1.Timer2Timer(Sender: TObject);
begin
    iFlash := iFlash + 1;
    if iFlash >= 256 then iFlash := 0;
    if not (iFlash mod 2 = 1) then
    begin
        L1.Caption := strFlash;
        Exit;
    end else
    begin
        L1.Caption := '';
        Exit;
    end;
end;

procedure TForm1.B4Click(Sender: TObject);
var
    TXT: TextFile;
    F: string;
    Buf: string;
begin
    if not Timer1.Enabled then Exit;
    F := ExtractFilePath(ParamStr(0)) + '记录.txt';
    AssignFile(TXT, F);
    if not FileExists(F) then ReWrite(TXT) else Append(TXT);
    Buf := '本次纪录耗时共:' + L1.Caption + ' 完成时间:' + DateToStr(Now) + ' '
        + TimetoStr(Now);
    WriteLn(TXT, Buf);
    CloseFile(TXT);
end;

procedure TForm1.BtnRunClick(Sender: TObject);
begin
if not CheckTask('bs5_.exe') then
begin
    ShellExecute(0, nil, '泡泡.lnk', nil, nil, SW_SHOW);
end;
end;

procedure TForm1.B5Click(Sender: TObject);
begin
    ShellExecute(0, 'open', '记录.txt', nil, nil, SW_SHOW);
end;

end.


读完这篇文章后,您心情如何?
0
0
0
0
0
0
0
0
本文网址: