現在時刻を1/100秒単位で現す関数 - VBレスキュー(花ちゃん)　Visual Basic,VS6.0,VB6.0,サンプル,Tips

Option Explicit　　 'SampleNo=057　WindowsXP VB6.0(SP5) 2002.05.13
'=======================================================
'現在時刻を1/100秒単位で現す関数 fNow_Alpha　　ゆう(U)さん投稿分
'=======================================================
' result = fNow_Alpha(Expression)
' 引数　Expression：日付／時刻表示書式指定文字
' 　　　　秒には".00"が付加されます
' 戻値　result ：書式指定変換後の文字列
'-------------------------------------------------------
'1999年元旦午前０時ちょうどだと・・・
'Debug.Print fNow_Alpha("yyyy/mm/dd hh:nn:ss")
'結果は「1999/01/01 00:00:00.00」
'Debug.Print fNow_Alpha("s")
'結果は「0.00」
'※秒(s)が書式に無いとただのFormat$(Now, Expression)です
'========================================================
'●なお、Timer関数が正しくSingle値を返さないマシンでは
'　正常に動作しません（常に.00になります）。
'　一部の機種でConfig.SySにHRTIMER.SYSが設定されていないと
'　型はSingleですが、整数値しか戻らない場合がありました。
'　異常確認機種
'　NEC(PC9821VALUESTAR V200)、Win95B、VB5.0(SP3)pro
'　HRTIMER.SYSをコメントにして確認しました
'-------------------------------------------------------
Private Function fNow_Alpha(ByRef Expression As String) As String
　　Dim i　　　　 As Long
　　Dim strTemp　 As String
　　Dim sngTemp　 As Single
　　Dim lngTemp　 As Long
　　Dim sngSecond As Single

　　sngTemp = Timer
　　i = fInstrRev1(Expression, "s", -1, vbTextCompare)
　　If i > 0& Then
　　　　lngTemp = CLng(sngTemp)
　　　　sngSecond = CSng(sngTemp - lngTemp)
　　　　strTemp = Left$(Expression, i) _
　　　　　　　& Right$(Format$(sngSecond, ".00"), 3) _
　　　　　　　& Right$(Expression, Len(Expression) - i)
　　Else
　　　　strTemp = Expression
　　End If

　　fNow_Alpha = Format$(Now, strTemp)
End Function
Private Sub Command1_Click()
　　Label1.Caption = fNow_Alpha("yyyy/mm/dd hh:nn:ss")
　　'結果　　2002/01/09 10:32:13.35
End Sub

'一番最後に見つかった位置を返すInstrRev似関数　ゆう(U)さん投稿分
Private Function fInstrRev1(ByRef String1 As String, _
　　　　　　ByRef String2 As String, _
　　　　　　Optional ByVal lngLimit As _
　　　　　　Long = -1&, _
　　　　　　Optional ByVal compare As _
　　　　　　VbCompareMethod = vbBinaryCompare _
　　　　　　) As Long
　　Dim i As Long, j As Long
　　Dim lngEndPos As Long
　　Dim lngLength As Long

　　lngLength = Len(String2)
　　If lngLength = 0& Then GoTo Err_Exit
　　If Len(String1) = 0& Then GoTo Err_Exit

　　If lngLimit < 0& Then
　　　　lngEndPos = Len(String1) - lngLength + 1&
　　Else
　　　　lngEndPos = lngLimit - lngLength + 1&
　　End If

　　i = InStr(j + 1&, String1, String2, compare)
　　Do While i > 0&
　　　　If i > lngEndPos Then Exit Do
　　　　j = i
　　　　i = InStr(j + 1&, String1, String2, compare)
　　Loop
　　fInstrRev1 = j

　　Exit Function

Err_Exit:

　　fInstrRev1 = -1&

End Function