あくまで「サンプル」です。
ここで紹介するのは「追記」書き出しの例であって、このまま実運用ができるものではありません。
まず、出力先が共有フォルダのテキストファイルなのでデータの改ざんは可能です。プロジェクトをロックしてマクロコードを不可視にして、出力先フォルダを非表示にするなどである程度の防御はできますが、「完全」な対策ではありません。
また、クライアントPCのシステム時刻を利用しているため、故意に時刻を変更して出力させることもできてしまいます。
ということで、あくまで「サンプル」としてご覧下さい。

(画像をクリックすると、このサンプルがダウンロードできます)
仕組みは簡単です。
「出社」ボタンか「退社」ボタンをクリックして、確認メッセージで「はい」を選択すると打刻データが出力されます。
出力先のフォルダをネットワーク上の共有フォルダにすれば、正しい運用の範囲内で打刻データを収集することができるものです。

これは「出社」ボタンをクリックしたところです。出退の間違いをできるだけ回避させるために確認メッセージを表示させています。
「はい」を選択すれば打刻データが出力されます。

念のため、出力後にも確認メッセージを表示させています。

ネットワーク上のトラブルや設定の問題も考えられるので、出力不成功の場合はエラーメッセージを表示させています。
出力データはこのようなイメージです。
inoue,2020/02/26 19:26:55,1
inoue,2020/02/26 19:29:20,2
サンプルでは3項目のCSV(カンマ区切り)テキスト形式ファイルになっていて、最初がWindowsログインユーザー、次がタイムスタンプ、最後が処理モードで「出社」が「1」、「退社」が「2」となっています。
では、コードを見てみましょう。
'***************************************************************************************************
' タイムレコーダプログラムサンプル
'
' 作成者:井上治 URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' [参照設定]
' ・Microsoft Scripting Runtime
' ・Windows Script Host Object Model
'***************************************************************************************************
'変更日付 Rev 変更履歴内容------------------------------------------------------------------------>
'07/05/20(1.00)新規作成
'19/10/24(1.10)*.xlsm化
'20/02/26(1.11)コード整理、「Option Private Module」追加
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
Private Const g_cnsTitle = "タイムレコーダ"
' 出力ファイル名(適時変更して下さい)
Private Const g_cnsSubFolder As String = "TIMERECORD"
Private Const g_cnsFilename As String = "TIMERECORD.dat"
Private Const g_cnsCOM As String = ","
Private Const g_cnsTimeFormat As String = "YYYY/MM/DD HH:NN:SS"
'---------------------------------------------------------------------------------------------------
' APIは条件付きコンパイルで64ビット版Windowsにも対応
#If VBA7 Then
' ■スリープ
Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" _
(ByVal dwMilliseconds As Long)
#Else
' ■スリープ
Private Declare Sub Sleep Lib "KERNEL32.dll" _
(ByVal dwMilliseconds As Long)
#End If
'---------------------------------------------------------------------------------------------------
' 出力パスはマイドキュメント内に「TIMERECORD」になります
Private g_strPathname As String ' 出力パス
'***************************************************************************************************
' ■■■ 起動時処理(既定) ■■■
'***************************************************************************************************
'* 処理名 :Auto_Open
'* 機能 :起動時処理(Windowsログイン名取得)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年05月20日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub Auto_Open()
'-----------------------------------------------------------------------------------------------
ActiveSheet.Protect UserInterfaceOnly:=True
' Windowsログイン名取得
Cells(1, 6).Value = FP_GetWinUser
ThisWorkbook.Saved = True
End Sub
'***************************************************************************************************
' ■■■ ワークシート側からのボタン呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名 :WRITE_SYUSSYA
'* 機能 :「出社」打刻登録(Mode=1)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年05月20日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub WRITE_SYUSSYA()
'-----------------------------------------------------------------------------------------------
Const cnsMODE = 1
Const cnsMODE_NAME = "「出社」"
' 打刻出力処理
Call GP_WRITE_TIMESTAMP(cnsMODE, cnsMODE_NAME)
End Sub
'***************************************************************************************************
'* 処理名 :WRITE_TAISYA
'* 機能 :「退社」打刻登録(Mode=2)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年05月20日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Public Sub WRITE_TAISYA()
'-----------------------------------------------------------------------------------------------
Const cnsMODE = 2
Const cnsMODE_NAME = "「退社」"
' 打刻出力処理
Call GP_WRITE_TIMESTAMP(cnsMODE, cnsMODE_NAME)
End Sub
'***************************************************************************************************
' ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名 :GP_WRITE_TIMESTAMP
'* 機能 :打刻出力処理(WinUser,TimeStamp,Mode)
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = 出退モード(Integer) ※1=出社、2=退社
'* Arg2 = 出退モード名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年05月20日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Sub GP_WRITE_TIMESTAMP(ByVal intMode As Integer, ByVal strModeName As String)
'-----------------------------------------------------------------------------------------------
Dim objFso As FileSystemObject ' FileSystemObject
Dim objTs As TextStream ' TextStream
Dim cntReTry As Long ' リトライカウンタ
Dim dteNow As Date ' 現在日時
Dim strRec As String ' 出力レコード
Dim strUser As String ' ユーザーID
Dim strNow As String ' 現在日時(編集)
Dim strFullname As String ' フルパスファイル名
Dim strMSG As String ' メッセージWORK
' 打刻モードの確認
If MsgBox(strModeName & "を登録します。" & vbCr & "よろしいですね?", _
vbInformation + vbYesNo, g_cnsTitle) <> vbYes Then Exit Sub
'-----------------------------------------------------------------------------------------------
' Windowsログイン名取得(念のため再取得)
strUser = FP_GetWinUser
' 現在時刻取得
dteNow = Now()
strNow = Format(dteNow, g_cnsTimeFormat)
' 出力レコード(カンマ区切り)を編集
strRec = strUser & g_cnsCOM & strNow & g_cnsCOM & intMode
' FileSystemObjectの取得
Set objFso = New FileSystemObject
' タイムレコーダ出力フォルダ名取得(ネットワーク上に出力するような場合は変更して下さい)
Call GP_GetTimerecorderPath(objFso)
' フルパスファイル名を編集
strFullname = objFso.BuildPath(g_strPathname, g_cnsFilename)
' 追記モードでファイルをOPEN(TextStream)
On Error GoTo TIMESTAMP_OPEN_ERROR
Set objTs = objFso.OpenTextFile(strFullname, ForAppending, True)
On Error GoTo 0
' レコードを出力
objTs.WriteLine strRec
' ファイルをCLOSE
objTs.Close
' 処理完了メッセージ
MsgBox strModeName & "を出力しました。" & vbCr & vbCr & _
"ユーザー:" & strUser & vbCr & _
"現在時刻:" & strNow, vbInformation, g_cnsTitle
GoTo TIMESTAMP_EXIT
'===================================================================================================
' OPEN不成功時のリトライWAIT(最大10回)
TIMESTAMP_OPEN_ERROR:
strMSG = Err.Description
cntReTry = cntReTry + 1
If cntReTry <= 10 Then
strMSG = ""
' RANDOM値を使ってWAIT
Sleep Int(301 * Rnd + 200)
' エラー箇所に戻る
Resume
End If
' 失敗メッセージ
MsgBox "打刻の出力に失敗しました。" & vbCr & " (" & strMSG & ")", _
vbExclamation, g_cnsTitle
'===================================================================================================
' 終了
TIMESTAMP_EXIT:
On Error GoTo 0
Set objTs = Nothing
Set objFso = Nothing
' 終了(ボタン押下後毎回閉じる)
If Workbooks.Count <= 1 Then Application.Quit
ThisWorkbook.Saved = True
ThisWorkbook.Close False
End Sub
'***************************************************************************************************
'* 処理名 :FP_GetWinUser
'* 機能 :Windowsログイン名取得
'---------------------------------------------------------------------------------------------------
'* 返り値 :Windowsログイン名(String)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年05月20日
'* 作成者 :井上 治
'* 更新日 :2020年02月26日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetWinUser() As String
'-----------------------------------------------------------------------------------------------
Dim objWshNet As IWshRuntimeLibrary.WshNetwork ' WshNetwork
Set objWshNet = New IWshRuntimeLibrary.WshNetwork
FP_GetWinUser = objWshNet.UserName
Set objWshNet = Nothing
End Function
'***************************************************************************************************
'* 処理名 :FP_GetMyDocumentsFolderByWsh
'* 機能 :マイドキュメントフォルダ名取得(WSH)
'---------------------------------------------------------------------------------------------------
'* 返り値 :マイドキュメントフォルダ名(String)
'* 引数 :(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年05月20日
'* 作成者 :井上 治
'* 更新日 :2007年05月20日
'* 更新者 :井上 治
'* 機能説明:
'* 注意事項:
'***************************************************************************************************
Private Function FP_GetMyDocumentsFolderByWsh() As String
'-----------------------------------------------------------------------------------------------
With New WshShell
FP_GetMyDocumentsFolderByWsh = .SpecialFolders("MyDocuments")
End With
End Function
'***************************************************************************************************
'* 処理名 :GP_GetTimerecorderPath
'* 機能 :タイムレコーダ出力フォルダ名取得+作成
'---------------------------------------------------------------------------------------------------
'* 返り値 :(なし)
'* 引数 :Arg1 = FileSystemObject(Object)
'---------------------------------------------------------------------------------------------------
'* 作成日 :2007年05月20日
'* 作成者 :井上 治
'* 更新日 :2019年10月24日
'* 更新者 :井上 治
'* 機能説明:マイドキュメント内としています
'* 注意事項:
'***************************************************************************************************
Private Sub GP_GetTimerecorderPath(ByRef objFso As FileSystemObject)
'-----------------------------------------------------------------------------------------------
' 出力パス作成済みなら終了
If g_strPathname <> "" Then Exit Sub
' 出力パスを編集
g_strPathname = objFso.BuildPath(FP_GetMyDocumentsFolderByWsh, g_cnsSubFolder)
' このフォルダがなければ作成
If Not objFso.FolderExists(g_strPathname) Then
objFso.CreateFolder g_strPathname
End If
End Sub
'------------------------------------------<< End of Source >>--------------------------------------
■詳細説明
まず、打刻データの出力先はこのサンプルではマイドキュメント内の「TIMERECORD」フォルダとしています。
'***************************************************************************************************
'* マイドキュメントフォルダ名取得(WSH)
'***************************************************************************************************
Private Function FP_GetMyDocumentsFolderByWsh() As String
'-----------------------------------------------------------------------------------------------
With New WshShell
FP_GetMyDocumentsFolderByWsh = .SpecialFolders("MyDocuments")
End With
End Function
'***************************************************************************************************
'* タイムレコーダ出力フォルダ名取得+作成(マイドキュメント内としています)
'***************************************************************************************************
Private Sub GP_GetTimerecorderPath(ByRef objFso As FileSystemObject)
'-----------------------------------------------------------------------------------------------
' 出力パス作成済みなら終了
If g_strPathname <> "" Then Exit Sub
' 出力パスを編集
g_strPathname = objFso.BuildPath(FP_GetMyDocumentsFolderByWsh, g_cnsSubFolder)
' このフォルダがなければ作成
If Not objFso.FolderExists(g_strPathname) Then
objFso.CreateFolder g_strPathname
End If
End Sub
この部分を利用環境によって変更して下さい。
ネットワーク上に出力するような場合はこのようなプロシージャは使わず定数固定でも良いと思います。
サンプルでは「出社」「退社」の2ボタンですが、ボタンと呼び出しプロシージャを対応して追加すれば、
'***************************************************************************************************
' 「外出」打刻登録(Mode=3)
'***************************************************************************************************
Public Sub WRITE_GAISYUTSU()
'-----------------------------------------------------------------------------------------------
Const cnsMODE = 3
Const cnsMODE_NAME = "「外出」"
' 打刻出力処理
Call GP_WRITE_TIMESTAMP(cnsMODE, cnsMODE_NAME)
End Sub
'***************************************************************************************************
' 「外出戻り」打刻登録(Mode=4)
'***************************************************************************************************
Public Sub WRITE_MODORI()
'-----------------------------------------------------------------------------------------------
Const cnsMODE = 4
Const cnsMODE_NAME = "「外出戻り」"
' 打刻出力処理
Call GP_WRITE_TIMESTAMP(cnsMODE, cnsMODE_NAME)
End Sub
たとえば、このように「外出」「外出戻り」を追加するなども簡単に行なえます。
実際のファイル出力は、
' フルパスファイル名を編集
strFullname = objFso.BuildPath(g_strPathname, g_cnsFilename)
' 追記モードでファイルをOPEN(TextStream)
On Error GoTo TIMESTAMP_OPEN_ERROR
Set objTs = objFso.OpenTextFile(strFullname, ForAppending, True)
On Error GoTo 0
' レコードを出力
objTs.WriteLine strRec
' ファイルをCLOSE
objTs.Close
これだけの記述で一瞬で完了するわけですが、ネットワーク環境での利用では朝の定時直前に処理が大量に発生することが予想されます。
このため、ファイルのOPEN失敗の場合に0.3~0.5秒待機して最大10回まで再試行するように、
'===================================================================================================
' OPEN不成功時のリトライWAIT(最大10回)
TIMESTAMP_OPEN_ERROR:
strMSG = Err.Description
cntRETRY = cntRETRY + 1
If cntRETRY <= 10 Then
strMSG = ""
' RANDOM値を使ってWAIT
Sleep Int(301 * Rnd + 200)
' エラー箇所に戻る
Resume
End If
' 失敗メッセージ
MsgBox "打刻の出力に失敗しました。" & vbCr & " (" & strMSG & ")", _
vbExclamation, g_cnsTitle
このようなコードで対応しています。
(OPEN失敗のみで他のタイミングのエラー処置は行なっていません。)