−−−−−−−−−−−−−−−−−−−−
ファイル名：lapchk.vbp
−−−−−−−−−−−−−−−−−−−−
Type=Exe
Form=startup.frm
Module=ModUty; ModUty.bas
IconForm="FrmStartup"
Startup="FrmStartup"
HelpFile=""
Title="lapchk"
ExeName32="lapchk.exe"
Command32=""
Name="Project1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName=""
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
ThreadPerObject=0
MaxNumberOfThreads=1
−−−−−−−−−−−−−−−−−−−−
ファイル名：moduty.bas
−−−−−−−−−−−−−−−−−−−−
Attribute VB_Name = "ModUty"
Option Explicit
Public Void
Public Enum EPAUSECTRL
PauseOn = 1
none = 0
pauseoff = -1
End Enum
Type SYSTEMTIME
Y As Integer
G As Integer
DayOfWeek As Integer
D As Integer
H As Integer
M As Integer
S As Integer
ms As Integer
End Type
Private PVT_TotalPauseTime As Long
Private PVT_PauseOn As Boolean
Private StartClock As Long
Private PrevClock As Long
Declare Sub GetSystemTime Lib "kernel32" (st As SYSTEMTIME)
Public Function TIM_RawSysTime() As Long
Dim st As SYSTEMTIME
GetSystemTime st
TIM_RawSysTime = 1000& * 60& * 60& * CLng(st.H) + _
1000& * 60& * CLng(st.M) + _
1000& * CLng(st.S) + _
CLng(st.ms)
End Function
Public Function TIM_SysTime(PauseCtrl As EPAUSECTRL) As Long
Static PrvClock&, Clock&, PauseSw As EPAUSECTRL
Clock = TIM_RawSysTime()
If PauseSw = PauseOn Then
PVT_TotalPauseTime = PVT_TotalPauseTime + (Clock - PrvClock)
End If
PrvClock = Clock
TIM_SysTime = TIM_RawSysTime() - PVT_TotalPauseTime
If PauseCtrl <> none Then
PauseSw = PauseCtrl
End If
End Function
Public Sub TIM_Reset()
StartClock = TIM_SysTime(PauseOn)
PrevClock = StartClock
End Sub
Public Function TIM_Get() As Long
TIM_Get = TIM_SysTime(none) - StartClock
End Function
Public Function TIM_PeekLap(total As Long) As Long
Dim st As Long
st = TIM_SysTime(none)
total = st - StartClock
TIM_PeekLap = st - PrevClock
End Function
Public Function TIM_GetLap(total As Long) As Long
Dim st As Long
st = TIM_SysTime(none)
total = st - StartClock
TIM_GetLap = st - PrevClock
PrevClock = st
End Function
Public Function TIM_MsToStr(ms As Long) As String
Dim ji&, fun&, byou&, rin&
rin = ms \ 10
byou = rin \ 100
fun = byou \ 60
ji = fun \ 60
rin = rin Mod 100
byou = byou Mod 60
fun = fun Mod 60
TIM_MsToStr = Format$(ji, "00") & ":" & _
Format$(fun, "00") & ":" & _
Format$(byou, "00") & "." & _
Format$(rin, "00")
End Function
−−−−−−−−−−−−−−−−−−−−
ファイル名：startup.frm
−−−−−−−−−−−−−−−−−−−−
VERSION 5.00
Begin VB.Form FrmStartup
Caption = "ラップタイマー"
ClientHeight = 5010
ClientLeft = 60
ClientTop = 630
ClientWidth = 6855
LinkTopic = "Form1"
ScaleHeight = 5010
ScaleWidth = 6855
StartUpPosition = 2 '画面の中央
WindowState = 2 '最大化
Begin VB.PictureBox PicPanel
Align = 2 '下揃え
Height = 1395
Left = 0
ScaleHeight = 1335
ScaleWidth = 6795
TabIndex = 2
Top = 3615
Width = 6855
Begin VB.CommandButton CmdLap
Caption = "Lap"
Default = -1 'True
Height = 435
Left = 5820
TabIndex = 4
Top = 840
Width = 855
End
Begin VB.Timer Timer1
Interval = 111
Left = 5220
Top = 720
End
Begin VB.CheckBox ChkRun
Caption = "Run"
Height = 255
Left = 5940
TabIndex = 3
Top = 240
Width = 855
End
Begin VB.Timer Timer3
Interval = 10
Left = 5220
Top = 240
End
Begin VB.Label LblTime
Alignment = 2 '中央揃え
Caption = "00:00:00.00"
BeginProperty Font
Name = "ＭＳ ゴシック"
Size = 15.75
Charset = 128
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 2580
TabIndex = 12
Top = 60
Width = 2235
End
Begin VB.Label LblLapTimeNow
Alignment = 2 '中央揃え
Caption = "00:00:00.00"
BeginProperty Font
Name = "ＭＳ ゴシック"
Size = 15.75
Charset = 128
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 2580
TabIndex = 11
Top = 480
Width = 2235
End
Begin VB.Label LblLapTime
Alignment = 2 '中央揃え
Caption = "00:00:00.00"
BeginProperty Font
Name = "ＭＳ ゴシック"
Size = 15.75
Charset = 128
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 2580
TabIndex = 10
Top = 900
Width = 2235
End
Begin VB.Label LblLapNow
Alignment = 2 '中央揃え
BeginProperty Font
Name = "ＭＳ ゴシック"
Size = 15.75
Charset = 128
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 1200
TabIndex = 9
Top = 480
Width = 1275
End
Begin VB.Label LblLap
Alignment = 2 '中央揃え
BeginProperty Font
Name = "ＭＳ ゴシック"
Size = 15.75
Charset = 128
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 1200
TabIndex = 8
Top = 900
Width = 1275
End
Begin VB.Label Label1
Alignment = 2 '中央揃え
Caption = "今回"
BeginProperty Font
Name = "ＭＳ ゴシック"
Size = 15.75
Charset = 128
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Index = 0
Left = -180
TabIndex = 7
Top = 480
Width = 1275
End
Begin VB.Label Label1
Alignment = 2 '中央揃え
Caption = "前回"
BeginProperty Font
Name = "ＭＳ ゴシック"
Size = 15.75
Charset = 128
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Index = 1
Left = -180
TabIndex = 6
Top = 900
Width = 1275
End
Begin VB.Label Label1
Alignment = 2 '中央揃え
Caption = "通算"
BeginProperty Font
Name = "ＭＳ ゴシック"
Size = 15.75
Charset = 128
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Index = 2
Left = -180
TabIndex = 5
Top = 60
Width = 1275
End
End
Begin VB.PictureBox PicGrp
AutoRedraw = -1 'True
Height = 3495
Left = 2220
ScaleHeight = 3435
ScaleWidth = 4515
TabIndex = 1
Top = 60
Width = 4575
End
Begin VB.TextBox TxtResult
Height = 3495
Left = 60
MultiLine = -1 'True
TabIndex = 0
Top = 60
Width = 2115
End
Begin VB.Menu MnuFile
Caption = "ファイル"
Begin VB.Menu MnuReset
Caption = "リセット"
End
Begin VB.Menu MnuExit
Caption = "ラップタイマーの修了"
End
End
End
Attribute VB_Name = "FrmStartup"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private PVT_LogName$
Private PVT_LapHist&(10000)
Private PVT_ClockHist(10000)
Private PVT_LapCount&
Private Sub DrawGraph()
Dim i&
Dim MaxClock&
Dim MaxLap&, AvrLap&
Dim xx As Single, X As Single, yy As Single, Y As Single
If PVT_LapCount < 1 Then Exit Sub
MaxClock = PVT_ClockHist(PVT_LapCount - 1)
If MaxClock <= 0 Then Exit Sub
MaxLap = PVT_LapHist(PVT_LapCount - 1) * 2
PicGrp.Cls
PicGrp.ForeColor = &H666666
For i = 0 To 40
Y = PicGrp.ScaleHeight - 10 - _
CSng((PicGrp.ScaleHeight - 10)) * _
CSng(i * 1000) / _
CSng(MaxLap)
PicGrp.Line (0, Y)-(PicGrp.ScaleWidth, Y)
PicGrp.CurrentX = 10
PicGrp.CurrentY = Y - PicGrp.TextHeight("0")
PicGrp.Print i
Next
PicGrp.DrawStyle = vbDot
For i = 0 To 40
Y = PicGrp.ScaleHeight - 10 - _
CSng((PicGrp.ScaleHeight - 10)) * _
CSng(i * 1000 + 500) / _
CSng(MaxLap)
PicGrp.Line (0, Y)-(PicGrp.ScaleWidth, Y)
PicGrp.CurrentX = 10
PicGrp.CurrentY = Y - PicGrp.TextHeight("0")
PicGrp.Print i + 0.5
Next
PicGrp.DrawStyle = vbSolid
PicGrp.ForeColor = &H0
For i = 0 To PVT_LapCount - 1
X = CSng((PicGrp.ScaleWidth - 10)) * _
CSng(PVT_ClockHist(i)) / _
CSng(MaxClock)
Y = PicGrp.ScaleHeight - 10 - _
CSng((PicGrp.ScaleHeight - 10)) * _
CSng(PVT_LapHist(i)) / _
CSng(MaxLap)
If i <> 0 Then PicGrp.Line (X, Y)-(xx, yy)
xx = X
yy = Y
Next
End Sub
Private Sub DispStatus(cnt&, lap&)
LblLap = "LAP:" & cnt
LblLapTime = TIM_MsToStr(lap)
End Sub
Private Sub WriteFile(cnt&, lap&, total&)
Dim fd%
fd = FreeFile
Open PVT_LogName$ For Append As fd
Print #fd, _
Format$(total / 1000, "0000.00") & " , " & _
Format$(lap / 1000, "000.00") & " , " & _
Format$(cnt, "0000")
Close fd
TxtResult = _
Format$(cnt, "0000") & " , " & _
Format$(lap / 1000, "000.00") & _
Chr$(13) & Chr$(10) & _
TxtResult
End Sub
Private Sub ChkRun_Click()
If ChkRun.Value = 0 Then
Void = TIM_SysTime(PauseOn)
Else
Void = TIM_SysTime(pauseoff)
End If
End Sub
Private Sub CountUpLap()
Dim lap As Long, total As Long
If ChkRun.Value = 0 Then ChkRun.Value = 1
If TIM_PeekLap(total) < 1000 Then Exit Sub
lap = TIM_GetLap(total)
WriteFile PVT_LapCount + 1, lap, total
PVT_LapHist(PVT_LapCount) = lap
PVT_ClockHist(PVT_LapCount) = total
PVT_LapCount = PVT_LapCount + 1
DispStatus PVT_LapCount, lap
DrawGraph
End Sub
Private Sub CmdLap_KeyPress(KeyAscii As Integer)
Select Case Chr$(KeyAscii)
Case "r", "R"
MnuReset_Click
Case " "
CountUpLap
End Select
End Sub
Private Sub Form_Resize()
Dim sh, sw
sh = Me.ScaleHeight
sw = Me.ScaleWidth
If sh < 5010 Then sh = 5010
If sw < 6855 Then sw = 6855
TxtResult.Height = Me.ScaleHeight - PicPanel.Height - PicGrp.Top
PicGrp.Height = Me.ScaleHeight - PicPanel.Height - PicGrp.Top
PicGrp.Width = Me.ScaleWidth - TxtResult.Width - TxtResult.Left * 2
DrawGraph
End Sub
Private Sub PicGrp_KeyPress(KeyAscii As Integer)
CmdLap_KeyPress KeyAscii
End Sub
Private Sub PicGrp_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
CountUpLap
End Sub
Private Sub Timer1_Timer()
Dim t&
LblTime = TIM_MsToStr(TIM_Get())
LblLapTimeNow = TIM_MsToStr(TIM_PeekLap(t))
LblLapNow = "LAP:" & PVT_LapCount + 1
End Sub
Private Sub MnuExit_Click()
Unload Me
End Sub
Private Sub MnuReset_Click()
Dim fd%
ChkRun.Value = 0
PicGrp.Cls
TxtResult.Text = ""
PVT_LogName$ = "LP" & Format$(Now(), "yymmddhhmm") & ".csv"
fd = FreeFile
Open PVT_LogName$ For Append As fd
Print #fd, "ラップ時間時間推移"
Print #fd, "時間（秒）,ラップ時間（秒）,ラップ数（回）"
Close fd
TIM_Reset
PVT_LapCount = 0
DispStatus PVT_LapCount, 0
End Sub
Private Sub Form_Load()
Me.Show
MnuReset_Click
End Sub