So-net無料ブログ作成

アクセス小僧:時計(3) [コンピューター]

アクセス(VBA)で作った

時計のマクロのコードを公開します。

1.まず、フォームの画面イメージです。

Access_watch.jpg

2.フォームのVBAマクロです。

Option Compare Database

Private Sub Form_Load()
  '【イベント】フォーム読込時
  On Error GoTo ERR1
  '【変数】
  Dim ANS As Integer ' 答え
  '【実行コード】
  'タイマ間隔プロパティを0.1秒(100ms)に再設定
  Me.TimerInterval = 100
  [コンボ_単位時間146].Value = 100
  ' 単位時間をロック
  [コンボ_単位時間146].Locked = True
  ' カウンタ初期化
  [テキスト_counter92] = 0
  ' ラジオボタンをON
  [オプション_日時78].Value = True
  Me.AllowAdditions = True ' レコード追加許可
  Me.AllowEdits = True ' 変更許可
  Call SWStart ' 時間計測開始
  GoTo CleanUp
ERR1:
  ANS = MsgBox("エラー(フォーム読込時)" & vbCrLf & Err.Description, vbCritical, "エラー")
  GoTo CleanUp
CleanUp:
  [コマンド_日時再開74].SetFocus
End Sub

Private Sub Form_Timer()
  '【イベント】タイマー時
  '【変数】
  Dim TUnit As Single ' 単位時間
  Dim TU_h, TU_mn, TU_s, TU_ml As Single '時、分、秒、ミリ秒の計算に使用する時間
  Dim myFlag1 As Integer ' フラグ
  '【実行コード】
  Call SWStop ' 時間計測停止
  Call SWStart ' 時間計測開始
  If [オプション_画面更新151] = False Then
    Application.Echo False, "処理中..." ' 画面更新停止
  Else
     Application.Echo True ' 画面更新再開
  End If
  ' 単位時間
  If [オプション_高精度157] = True Then
    TUnit = 1 ' 1msec.
  Else
    TUnit = [コンボ_単位時間146]
  End If
  TU_h = 60# * 60# * 1000# / TUnit ' 時
  TU_mn = 60# * 1000# / TUnit ' 分
  TU_s = 1000# / TUnit ' 秒
  ' カウンタ92をインクリメント
  [テキスト_counter92] = [テキスト_counter92] + 1
  ' 1/10/100msec間隔
  ' アラーム確認
  If ([オプション_日時78].Value = True) And ([オプション_アラーム88] = True) _
  And (TimeSerial([コンボ_時81], [コンボ_分90], 0) = Time()) Then
    [テキスト_日時72].ForeColor = RGB(0, 0, 0) ' Black
    [テキスト_日時72].Value = Format(Now(), "yyyy\[ggge""]年""mm\月dd""日[") _
    & UFWeekday1(Now()) _
    & Format(Now(), "\] hh\:nn\:ss")
    [オプション_アラーム88] = False ' アラームを止める
    Call myHelp_WSH([コンボ_時81] & "時" & [コンボ_分90] & "分になりました。", "時間です")
  End If
  ' タイマー
  If ([オプション_タイマー96].Value = True) And ([テキスト_counter104].Value >= 0) Then
    If [オプション_高精度157] = True Then
      [テキスト_counter104].Value = [テキスト_counter104].Value - [テキスト_処理時間154].Value ' 減算
      If [テキスト_counter104].Value < 0 Then
       [テキスト_counter104].Value = 0
      End If
    Else
      [テキスト_counter104].Value = [テキスト_counter104].Value - 1 ' 減算
    End If
    ' タイマー終了判定
    If [テキスト_counter104].Value = 0 Then
      [オプション_タイマー96].Value = False
      [コンボ_時94] = 0
      [コンボ_分98] = 0
      [コンボ_秒100] = 0
      [テキスト_Tミリ秒141] = 0
      Call myHelp_WSH("タイマーが終了しました。", "時間です")
    End If
  End If
  ' ストップウォッチ
  If [オプション_StpW109] = True Then
    If [オプション_高精度157] = True Then
       [テキスト_SWCounter120].Value = [テキスト_SWCounter120].Value + [テキスト_処理時間154].Value ' 加算
    Else
      [テキスト_SWCounter120].Value = [テキスト_SWCounter120].Value + 1 ' カウンタをインクリメント
    End If
  End If
  myFlag1 = 0 ' フラグをリセット
  ' 2秒カウンタ
  [テキスト_counter158] = [テキスト_counter158] + [テキスト_処理時間154]
  If [テキスト_counter158] >= 2000 Then
    [テキスト_counter158] = 0
    If [オプション_高精度157] = True Then
      myFlag1 = 1 ' フラグをセット
    End If
  End If
  ' 2秒判定(高精度がオフ時)
  If ([オプション_高精度157] = False) And ([テキスト_counter92] Mod Int(2000 / TUnit) = 0) Then
    myFlag1 = 1 ' フラグをセット
  End If
  ' 日時を一時停止(2000msec間隔)
  If ([オプション_日時78].Value = False) And (myFlag1 = 1) Then
    ' 日時のフォント色を反転
    If [テキスト_日時72].ForeColor = RGB(0, 0, 0) Then
      [テキスト_日時72].ForeColor = RGB(255, 255, 255) ' White
    Else
      [テキスト_日時72].ForeColor = RGB(0, 0, 0) ' Black
    End If
  End If
  myFlag1 = 0 ' フラグをリセット
  ' 0.8秒カウンタ
  [テキスト_counter160] = [テキスト_counter160] + [テキスト_処理時間154]
  If [テキスト_counter160] >= 800 Then
    [テキスト_counter160] = 0
    If [オプション_高精度157] = True Then
      myFlag1 = 1 ' フラグをセット
    End If
  End If
  ' 0.8秒判定(高精度がオフ時)
  If ([オプション_高精度157] = False) And ([テキスト_counter92] Mod Int(800 / TUnit) = 0) Then
    myFlag1 = 1 ' フラグをセット
  End If
  ' 日時を更新(0.8秒間隔)
  If ([オプション_日時78].Value = True) And (myFlag1 = 1) Then
    [テキスト_日時72].ForeColor = RGB(0, 0, 0) ' Black
    [テキスト_日時72].Value = Format(Now(), "yyyy\[ggge""]年""mm\月dd""日[") _
    & UFWeekday1(Now()) _
    & Format(Now(), "\] hh\:nn\:ss")
  End If
  ' タイマーを更新(0.8秒間隔)
  If ([オプション_タイマー96].Value = True) And ([テキスト_counter104].Value >= 0) _
  And (myFlag1 = 1) Then
    [コンボ_時94] = Int([テキスト_counter104].Value / TU_h)
    [コンボ_分98] = Int(([テキスト_counter104].Value - [コンボ_時94] * TU_h) / TU_mn)
    [コンボ_秒100] = Int(([テキスト_counter104].Value - [コンボ_時94] * TU_h - [コンボ_分98] * TU_mn) / TU_s)
    [テキスト_Tミリ秒141] = [テキスト_counter104].Value - [コンボ_時94] * TU_h - [コンボ_分98] * TU_mn _
    - [コンボ_秒100] * TU_s
  End If
  ' ストップウォッチを更新(0.8秒間隔)
  If ([オプション_StpW109] = True) And (myFlag1 = 1) Then
    [コンボ_SW時110] = Int([テキスト_SWCounter120].Value / TU_h)
    [コンボ_SW分112] = Int(([テキスト_SWCounter120].Value - [コンボ_SW時110] * TU_h) / TU_mn)
    [コンボ_SW秒114] = Int(([テキスト_SWCounter120].Value - [コンボ_SW時110] * TU_h - [コンボ_SW分112] * TU_mn) / TU_s)
    [テキスト_SWm秒140] = [テキスト_SWCounter120].Value - [コンボ_SW時110] * TU_h - [コンボ_SW分112] * TU_mn _
    - [コンボ_SW秒114] * TU_s
  End If
  ' カウンタが1周(18000msec)したか?
  If [テキスト_counter92] = (18000 / [コンボ_単位時間146]) Then
    [テキスト_counter92] = 0
  End If
End Sub

Private Sub myYear1_LostFocus()
  '【変数】
  Dim myString1 As String ' 文字列
  Dim ANS As Integer ' 答え
  '【実行コード】
  myString1 = [myYear1] & "/" & ([Co_Month1].ListIndex + 1) & "/" & ([Co_myDay1].ListIndex + 1)
  If IsDate(myString1) Then
    '曜日を更新
    [テキスト_日60] = "日 [" & UFWeekday1(myString1) & "]"
    ' 年号を更新
    [テキスト_年33] = Format(myString1, "\[ggge""]年""")
  Else
    ANS = MsgBox("その日付(" & myString1 & ")は存在しません", vbExclamation, "だめよ")
    '曜日を更新
    [テキスト_日60] = "日 [-]"
    ' 年号を更新
    [テキスト_年33] = "[???]年"
  End If
End Sub

Private Sub コマンド_SWLap118_Click()
  '【機能】ストップウォッチのLAP/SPLIT
  '【変数】
  Dim TUnit As Single ' 単位時間
  Dim TU_h, TU_mn, TU_s, TU_ml As Single '時、分、秒、ミリ秒の計算に使用する時間
  Dim SWCounter As Single ' ストップウォッチのカウンター
  '【実行コード】
  ' 単位時間
  If [オプション_高精度157] = True Then
    TUnit = 1 ' 1msec.
  Else
    TUnit = [コンボ_単位時間146]
  End If
  TU_h = 60# * 60# * 1000# / TUnit ' 時
  TU_mn = 60# * 1000# / TUnit ' 分
  TU_s = 1000# / TUnit ' 秒
  ' ストップウォッチのカウンター値を取り込み
  SWCounter = [テキスト_SWCounter120]
  'ラップタイムを計算
  [テキスト_SWLapCounter138] = SWCounter - [テキスト_SWSplitCounter128]
  [コンボ_SWLap時131] = Int([テキスト_SWLapCounter138].Value / TU_h)
  [コンボ_SWLap分133] = Int(([テキスト_SWLapCounter138].Value - [コンボ_SWLap時131] * TU_h) / TU_mn)
  [コンボ_SWLap秒135] = Int(([テキスト_SWLapCounter138].Value - [コンボ_SWLap時131] * TU_h - [コンボ_SWLap分133] * TU_mn) / TU_s)
  [テキスト_SWLapm秒143] = [テキスト_SWLapCounter138].Value - [コンボ_SWLap時131] * TU_h - [コンボ_SWLap分133] * TU_mn _
  - [コンボ_SWLap秒135] * TU_s
  ' スプリットタイムを計算
  [テキスト_SWSplitCounter128] = SWCounter
  [コンボ_SwSplit時122] = Int([テキスト_SWSplitCounter128].Value / TU_h)
  [コンボSwSplit分124] = Int(([テキスト_SWSplitCounter128].Value - [コンボ_SwSplit時122] * TU_h) / TU_mn)
  [コンボ_SwSplit秒126] = Int(([テキスト_SWSplitCounter128].Value - [コンボ_SwSplit時122] * TU_h - [コンボSwSplit分124] * TU_mn) / TU_s)
  [テキスト_SWSplitm秒142] = [テキスト_SWSplitCounter128].Value - [コンボ_SwSplit時122] * TU_h - [コンボSwSplit分124] * TU_mn _
  - [コンボ_SwSplit秒126] * TU_s
End Sub

Private Sub コマンド_SWStrStp116_Click()
  '【機能】ストップウォッチの開始/停止
  '【変数】
  Dim TUnit As Single ' 単位時間
  Dim TU_h, TU_mn, TU_s, TU_ml As Single '時、分、秒、ミリ秒の計算に使用する時間
  '【実行コード】
  If [オプション_StpW109] = False Then
    [オプション_StpW109] = True ' 開始
  Else
    [オプション_StpW109] = False ' 停止
    ' 単位時間
    If [オプション_高精度157] = True Then
      TUnit = 1 ' 1msec.
    Else
      TUnit = [コンボ_単位時間146]
    End If
    TU_h = 60# * 60# * 1000# / TUnit ' 時
    TU_mn = 60# * 1000# / TUnit ' 分
    TU_s = 1000# / TUnit ' 秒
    [コンボ_SW時110] = Int([テキスト_SWCounter120].Value / TU_h)
    [コンボ_SW分112] = Int(([テキスト_SWCounter120].Value - [コンボ_SW時110] * TU_h) / TU_mn)
    [コンボ_SW秒114] = Int(([テキスト_SWCounter120].Value - [コンボ_SW時110] * TU_h - [コンボ_SW分112] * TU_mn) / TU_s)
    [テキスト_SWm秒140] = [テキスト_SWCounter120].Value - [コンボ_SW時110] * TU_h - [コンボ_SW分112] * TU_mn _
    - [コンボ_SW秒114] * TU_s
  End If
End Sub

Private Sub コマンド_SWリセット119_Click()
  '【機能】ストップウォッチのリセット
  [オプション_StpW109] = False ' 停止
  [テキスト_SWCounter120] = 0
  [コンボ_SW時110] = 0
  [コンボ_SW分112] = 0
  [コンボ_SW秒114] = 0
  [テキスト_SWm秒140] = 0
  ' スプリットタイム
  [コンボ_SwSplit時122] = 0
  [コンボSwSplit分124] = 0
  [コンボ_SwSplit秒126] = 0
  [テキスト_SWSplitm秒142] = 0
  [テキスト_SWSplitCounter128] = 0
  ' ラップタイム
  [コンボ_SWLap時131] = 0
  [コンボ_SWLap分133] = 0
  [コンボ_SWLap秒135] = 0
  [テキスト_SWLapm秒143] = 0
  [テキスト_SWLapCounter138] = 0
End Sub

Private Sub コマンド_タイマーリセット107_Click()
  [テキスト_counter104] = 0
  [コンボ_時94] = 0
  [コンボ_分98] = 0
  [コンボ_秒100] = 0
  [テキスト_Tミリ秒141] = 0
End Sub

Private Sub コマンド_タイマー開始102_Click()
  '【変数】
  Dim TUnit As Single ' 単位時間
  Dim TU_h, TU_mn, TU_s, TU_ml As Single '時、分、秒、ミリ秒の計算に使用する時間
  '【実行コード】
  ' 単位時間
  If [オプション_高精度157] = True Then
    TUnit = 1 ' 1msec.
  Else
    TUnit = [コンボ_単位時間146]
  End If
  TU_h = 60# * 60# * 1000# / TUnit ' 時
  TU_mn = 60# * 1000# / TUnit ' 分
  TU_s = 1000# / TUnit ' 秒
  ' ラジオボタンがOFFのとき、以下を実行
  If [オプション_タイマー96] = False Then
    [テキスト_counter104] = [コンボ_時94] * TU_h + [コンボ_分98] * TU_mn + [コンボ_秒100] * TU_s + [テキスト_Tミリ秒141]
    If [テキスト_counter104] >= 1 Then
      [オプション_タイマー96] = True
    End If
  End If
End Sub

Private Sub コマンド_タイマー停止106_Click()
' ラジオボタンがONのとき、以下を実行
If [オプション_タイマー96] = True Then
  [オプション_タイマー96] = False
End If
End Sub

Private Sub コマンド_一時停止80_Click()
  'タイマ間隔プロパティを2秒(2000ms)に再設定
  ' Me.TimerInterval = 2000
  ' ラジオボタンをOFF
  [オプション_日時78].Value = False
End Sub

Private Sub コマンド_画面更新150_Click()
  If [オプション_画面更新151] = True Then
    Application.Echo False, "処理中..." ' 画面更新停止"
    [オプション_画面更新151] = False
    [テキスト_counter92].Visible = False
    [テキスト_counter104].Visible = False
    [テキスト_SWCounter120].Visible = False
    [テキスト_SWSplitCounter128].Visible = False
    [テキスト_SWLapCounter138].Visible = False
    [テキスト_処理時間154].Visible = False
    [テキスト_counter158].Visible = False
    [テキスト_counter160].Visible = False
  Else
    Application.Echo True ' 画面更新再開
    [オプション_画面更新151] = True
    [テキスト_counter92].Visible = True
    [テキスト_counter104].Visible = True
    [テキスト_SWCounter120].Visible = True
    [テキスト_SWSplitCounter128].Visible = True
    [テキスト_SWLapCounter138].Visible = True
    [テキスト_処理時間154].Visible = True
    [テキスト_counter158].Visible = True
    [テキスト_counter160].Visible = True
  End If
End Sub

Private Sub コマンド_開き直し153_Click()
  '【機能】フォームを閉じて、再度開く
  On Error GoTo ERR1
  '【変数】
  Dim myID As Long ' ID
  Dim myAns As Integer ' 答え
  '【実行コード】
  DoCmd.Close acForm, "F_時計", acSavePrompt ' フォームを閉じる
  myAns = MsgBox("フォームを再度開きますか?", vbOKCancel + vbDefaultButton2)
  If myAns = vbOK Then
    DoCmd.OpenForm "F_時計", acNormal, , , acFormPropertySettings, acWindowNormal ' フォームを開く
  End If
  Exit Sub
ERR1:
  MsgBox ("エラー(開き直し_Click)" & vbCrLf & Err.Description)
End Sub

Private Sub コマンド_現時刻145_Click()
  '【機能】アラームに現時刻を設定
  [コンボ_時81] = Hour(Now())
  [コンボ_分90] = Minute(Now())
End Sub

Private Sub コマンド_高精度156_Click()
  '【機能】高精度モードのON/OFF
  If [オプション_高精度157].Value = True Then
    [オプション_高精度157].Value = False
  Else
    [オプション_高精度157].Value = True
  End If
End Sub

Private Sub コマンド_日時停止75_Click()
  'タイマ間隔プロパティをゼロにする
  Me.TimerInterval = 0
  ' ラジオボタンをOFF
  [オプション_日時78].Value = False
  ' 日時を黒色に
  [テキスト_日時72].ForeColor = RGB(0, 0, 0) ' Black
  ' 単位時間をアンロック
  [コンボ_単位時間146].Locked = False
End Sub

Private Sub コマンド_日時再開74_Click()
  '【変数】
  Dim TUnit As Single ' 単位時間
  Dim TU_h, TU_mn, TU_s, TU_ml As Single '時、分、秒、ミリ秒の計算に使用する時間
  '【実行コード】
  ' 単位時間
  TUnit = [コンボ_単位時間146]
  TU_h = 60# * 60# * 1000# / TUnit ' 時
  TU_mn = 60# * 1000# / TUnit ' 分
  TU_s = 1000# / TUnit ' 秒
  ' MsgBox TUnit & "," & TU_h & "," & TU_mn & "," & TU_s
  'タイマ間隔プロパティを0.1秒(100ms) or 1msに再設定
  Forms![F_時計].TimerInterval = TUnit
  ' カウンタ初期化
  [テキスト_counter92] = 0
  ' ラジオボタンをON
  [オプション_日時78].Value = True
  ' 単位時間をロック
  [コンボ_単位時間146].Locked = True
End Sub

3.Module1標準モジュールのVBAマクロです。

Option Compare Database

Function UFWeekday1(myDate1 As String)
'【機能】日付を曜日に変換
'【引数】
' myDate1 : 日付(yyyy/mm/dd)
'【変数】
'【実行コード】
  Select Case Weekday(myDate1)
  Case vbSunday
    UFWeekday1 = "日"
  Case vbMonday
    UFWeekday1 = "月"
  Case vbTuesday
    UFWeekday1 = "火"
  Case vbWednesday
    UFWeekday1 = "水"
  Case vbThursday
    UFWeekday1 = "木"
  Case vbFriday
    UFWeekday1 = "金"
  Case vbSaturday
    UFWeekday1 = "土"
  End Select
End Function

Sub myHelp_WSH(strText As String, strTitle As String)
  '【機能】WSHによるヘルプ
  '【変数】
  Dim objWshShell
  Dim intButton
  '【実行コード】
  Set objWshShell = CreateObject("WScript.Shell")
  ' nSecondsToWait=0
  ' nType : 0[OK]+48[!]
  intButton = objWshShell.PopUp(strText, 0, strTitle, 48)
  Set objWshShell = Nothing
End Sub

4.mdlStopwatch標準モジュールのVBAマクロです。

Option Compare Database

Option Explicit

Private Declare Function QueryPerformanceCounter Lib "Kernel32" _
                           (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" _
                           (X As Currency) As Boolean
Dim Freq As Currency
Dim Overhead As Currency
Dim Ctr1 As Currency, Ctr2 As Currency, Result As Currency

'ミリ秒以下の高精度で処理時間計測
Public Sub SWStart()
    If QueryPerformanceCounter(Ctr1) Then
        QueryPerformanceCounter Ctr2
        QueryPerformanceFrequency Freq
' Debug.Print "QueryPerformanceCounter minimum resolution: 1/" & _
' Freq * 10000; " sec"
' Debug.Print "API Overhead: "; (Ctr2 - Ctr1) / Freq * 1000; "ミリ秒"
        Overhead = Ctr2 - Ctr1
    Else
        Err.Raise 513, "StopwatchError", "High-resolution counter not supported."
    End If
    QueryPerformanceCounter Ctr1
End Sub

Public Sub SWStop()
    QueryPerformanceCounter Ctr2
    Result = (Ctr2 - Ctr1 - Overhead) / Freq * 1000
    Forms.F_時計.テキスト_処理時間154.Value = Result
End Sub

Public Sub SWShow(Optional Caption As String)
    Debug.Print Caption & " " & Result
End Sub

解説は。。。ごめんなさい。[猫]



ヤバイぜ!(8)  コメント(2) 
共通テーマ:パソコン・インターネット

ヤバイぜ! 8

コメント 2

cheese999

ヤバイぜ! ありがとうございます[__猫]
by cheese999 (2018-02-20 04:58) 

cheese999

解説については、おいおい。。[__猫]
by cheese999 (2018-02-20 04:59) 

コメントを書く

お名前:[必須]
URL:
コメント:
画像認証:
下の画像に表示されている文字(英大文字の「オー」、英小文字の「ユー」、アラビア数字の「ハチ」、アラビア数字の「イチ」、アラビア数字の「ニ」)を入力してください。

Facebook コメント