【ACCESS/EXCEL/VBA】ログ出力を行うモジュールサンプル

---

ACCESSのみで動作確認をしていますがEXCELでもそのまま使えると思います。
かゆいところに手が届かない部分や雑な箇所があるので、必要に応じてカスタマイズして使用してください。

---

①ファイル出力処理用に
　事前に[ツール]→[参照設定]から[Microsoft Scripting Runtime]を追加する


②以下ログ出力モジュール

Option Compare Database
Option Explicit
 
Private Type systemTime
    Year As Integer
    Month As Integer
    DayOfeek  As Integer
    Day  As Integer
    Hour As Integer
    Minute As Integer
    Second As Integer
    Milliseconds As Integer
End Type
 
Private Declare Sub GetSystemTime Lib "kernel32" (systemTime As systemTime)
Private MeasureStartTime As systemTime
Private MeasureEndTime As systemTime
Private IntermStartTime As systemTime
Private IntermEndTime As systemTime
Private MeasureLog As String
 
Public Sub MeasureStart()
    MeasureStartTime = GetDetailSysTime
    MeasureLog = "計測開始：" & GetFormatSysTime(MeasureStartTime) & vbCrLf
End Sub
 
Public Sub MeasureEnd()
    MeasureEndTime = GetDetailSysTime
    MeasureLog = MeasureLog & _
                 "計測終了：" & GetFormatSysTime(MeasureEndTime) & vbCrLf & _
                 "計測時間：" & GetMeasureTime(IntermStartTime, IntermEndTime) & vbCrLf
                 
    Call OutPutText("Log" & GetUnFormatSysTime(MeasureStartTime), MeasureLog)
End Sub
 
Public Sub IntermStart()
    IntermStartTime = GetDetailSysTime
End Sub
 
Public Sub IntermEnd(ByVal text As String)
    IntermEndTime = GetDetailSysTime
    MeasureLog = MeasureLog & _
                 text & _
                 ":" & _
                 GetFormatSysTime(IntermStartTime) & vbTab & _
                 GetFormatSysTime(IntermEndTime) & vbTab & _
                 GetMeasureTime(IntermStartTime, IntermEndTime) & vbCrLf
End Sub
 
Public Sub AddLog(ByVal text As String)
    MeasureLog = MeasureLog & _
                 text & _
                 ":" & vbTab & _
                 GetFormatSysTime(GetDetailSysTime) & vbCrLf
End Sub
 
Private Function GetDetailSysTime() As systemTime
    Dim sysTime As systemTime
    GetSystemTime sysTime
    GetDetailSysTime = sysTime
End Function
 
Private Sub OutPutText(ByVal fileName As String, ByVal text As String)
    Dim wsh As Object
    Set wsh = CreateObject("WScript.Shell")
    
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
 
    Dim ts As TextStream
    Set ts = fso.CreateTextFile(wsh.SpecialFolders("Desktop") & "\" & fileName & ".txt", Overwrite:=True, Unicode:=True)
 
    ts.Write (text)
    
    ts.Close
    Set wsh = Nothing
    Set ts = Nothing
    Set fso = Nothing
End Sub
 
Private Function GetFormatSysTime(ByRef sysTime As systemTime) As String
    GetFormatSysTime = CStr(sysTime.Year) & "/" & _
                       Format(sysTime.Month, "00") & "/" & _
                       Format(sysTime.Day, "00") & " " & _
                       Format(sysTime.Hour, "00") & ":" & _
                       Format(sysTime.Minute, "00") & ":" & _
                       Format(sysTime.Second, "00") & "." & _
                       Format(sysTime.Milliseconds, "000")
End Function
 
Private Function GetUnFormatSysTime(ByRef sysTime As systemTime) As String
    GetUnFormatSysTime = CStr(sysTime.Year) & _
                    Format(sysTime.Month, "00") & _
                    Format(sysTime.Day, "00") & _
                    Format(sysTime.Hour, "00") & _
                    Format(sysTime.Minute, "00") & _
                    Format(sysTime.Second, "00") & _
                    Format(sysTime.Milliseconds, "000")
End Function
 
Private Function GetMeasureTime(ByRef sysStartTime As systemTime, _
                                ByRef sysEndTime As systemTime) As String
    Dim startTime As Double
    Dim endTime As Double
    startTime = CDbl(Format(sysStartTime.Hour, "00") & _
                     Format(sysStartTime.Minute, "00") & _
                     Format(sysStartTime.Second, "00") & "." & _
                     Format(sysStartTime.Milliseconds, "000"))
    endTime = CDbl(Format(sysEndTime.Hour, "00") & _
                   Format(sysEndTime.Minute, "00") & _
                   Format(sysEndTime.Second, "00") & "." & _
                   Format(sysEndTime.Milliseconds, "000"))
                                
    GetMeasureTime = Format(CStr(endTime - startTime), "00:00:00.000")
End Function

---

---

③使用例
1.MeasureStartでログを取得開始、
　MeasureEndでログファイルをデスクトップに出力します。
※MeasureStart/MeasureEnd処理は計測時には必須処理となります。
2.MeasureStart～End間の処理で以下の関数を実行すると中間ログの取得が行えます。 　AddLog：引数テキスト、AddLog実行時の時刻をログファイルに出力します。 　IntermStart/IntermEnd：IntermStartで中間ログ計測開始、
　　　　　　　　　　　　 IntermEndで引数テキスト、Start/End時刻、Start～End間の時間をログファイルに出力します。

Private Sub LogSample()
    ' MeasureStart実行でログ計測を開始します
    Call MeasureStart
    
    ' 単純なログを残した場合はAddLogを使用します
    Call AddLog("AddLogサンプル①")
    
    ' 中間の処理時間を図りたい場合はIntermStart-IntermEndを使用します
    ' IntermEndの引数に指定した文言/IntermStartとEnd時刻/IntermEndまでの時間が出力されます。
    Call IntermStart
    ' --ダミー処理---
    Dim i As Long
    Dim str As String
    For i = 0 To 100000
        str = "dammy"
    Next i
    ' --ダミー処理---
    Call IntermEnd("IntermStart/End")
    
    Call AddLog("AddLogサンプル②")
    
    ' MeasureEnd実行でログファイルが出力されます
    Call MeasureEnd
End Sub

④実行結果 　[③使用例]のコードを実行した結果 　以下のファイルがデスクトップに出力される。

【ACCESS/EXCEL/VBA】現在時刻ミリ秒まで取得を行う

VBAの[ NOW() ]や[ DATE() ]関数ではミリ秒の取得が行えない。
ミリ秒まで取得を行いたい場合は[ Win32API ]を使用して別途自作する必要がある。

■以下取得関数サンプル

Option Compare Database
Option Explicit
 
Private Type systemTime
    Year As Integer
    Month As Integer
    DayOfeek  As Integer
    Day  As Integer
    Hour As Integer
    Minute As Integer
    Second As Integer
    Milliseconds As Integer
End Type
 
Private Declare Sub GetSystemTime Lib "kernel32" (systemTime As systemTime)
 
' 現在日時をミリ秒まで取得する関数
Public Function GetDetailSysTime() As String
    Dim sysTime As systemTime
    GetSystemTime sysTime
    
    GetDetailSysTime = CStr(sysTime.Year) & "/" & _
                       Format(sysTime.Month, "00") & "/" & _
                       Format(sysTime.Day, "00") & " " & _
                       Format(sysTime.Hour, "00") & ":" & _
                       Format(sysTime.Minute, "00") & ":" & _
                       Format(sysTime.Second, "00") & "." & _
                       Format(sysTime.Milliseconds, "000")
End Function

【ACCESS/VBA】SQL文実行サンプル

 Private Sub ExecSQL()
    Dim cmd As New ADODB.Command
    Dim conn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim rtn As Integer
    m_cn = New ADODB.Connection
    conn.ConnectionString = "DSN=TEST_ODBC;Uid=USER1;Pwd=userpass1;Database=TEST_DB"
    conn.Open
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = conn
    
    ' SELECT文（レコードセットに結果取得するパターン）
    With cmd
        .CommandText = "SELECT * " & _
                       "FROM TEST_TBL1 " & _
                       "WHERE column1 = ? AND " & _
                       "      column2 = ?;"
        .CommandType = adCmdText
        .Parameters(0).Value = 1        ' 1つ目?へのバインド
        .Parameters(1).Value = "AAA"    ' 2つ目?へのバインド
    End With
    Set rst = cmd.Execute
    rst.Close
    Set rst = Nothing
    
    ' UPDATE/INSERT文（レコードセットに結果取得しないパターン）
    With cmd
        .CommandText = "UPDATE TEST_TBL1 " & _
                       "SET   column2 = ? " & _
                       "WHERE column1 = ?;"
        .CommandType = adCmdText
        .Parameters(0).Value = "BBB"        ' 1つ目?へのバインド
        .Parameters(1).Value = 1    ' 2つ目?へのバインド
    End With
    Call cmd.Execute
 
    With cmd
        .CommandText = "INSERT INTO TEST_TBL1(" & _
                       "    column1, " & _
                       "    column2 " & _
                       ")VALUES(" & _
                       "    ?," & _
                       "    ?);"
        .CommandType = adCmdText
        .Parameters(0).Value = 2        ' 1つ目?へのバインド
        .Parameters(1).Value = "CCC"    ' 2つ目?へのバインド
    End With
    Call cmd.Execute
    
    Set cmd = Nothing
 End Sub

【ACCESS/VBA】ストアドプロシージャ実行サンプル

①ストアド内のSELECT結果を取得する場合

Private Sub ExecSP()
    Dim cmd As New ADODB.Command
    Dim conn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim rtn As Integer
    m_cn = New ADODB.Connection
    conn.ConnectionString = "DSN=TEST_ODBC;Uid=USER1;Pwd=userpass1;Database=TEST_DB"
    conn.Open
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = conn
    
    With cmd
        .CommandText = "usp_sp1"
        .CommandType = adCmdStoredProc
        .Parameters.Refresh
        .Parameters(1).Value = 100 ' ストアド引数1つ目
        .Parameters(2).Value = 200 ' ストアド引数2つ目
    End With
    
    ' ストアドプロシージャ内で最後に実行されたSQLの結果を取得
    Set rst = cmd.Execute
    ' ストアドプロシージャのReturn値を取得
    rtn = cmd.Parameters(0).Value
    
    rst.Close
    Set rst = Nothing
    Set cmd = Nothing
    
 End Sub

②ストアド内のSELECT結果を取得しない場合

Private Sub ExecSP()
    Dim cmd As New ADODB.Command
    Dim conn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim rtn As Integer
    m_cn = New ADODB.Connection
    conn.ConnectionString = "DSN=TEST_ODBC;Uid=USER1;Pwd=userpass1;Database=TEST_DB"
    conn.Open
    
    Set cmd = New ADODB.Command
    Set cmd.ActiveConnection = conn
    
    With cmd
        .CommandText = "usp_sp1"
        .CommandType = adCmdStoredProc
        .Parameters.Refresh
        .Parameters(1).Value = 100 ' ストアド引数1つ目
        .Parameters(2).Value = 200 ' ストアド引数2つ目
        .Execute
    End With
    
    ' ストアドプロシージャのReturn値を取得
    rtn = cmd.Parameters(0).Value
    
    rst.Close
    Set rst = Nothing
    Set cmd = Nothing
    
 End Sub

【ACCESS/VBA】ADODB接続サンプル

①事前に[ツール]→[参照設定]から[Microsoft ActiveX Data Objects X.X Library]を追加する
※参照設定を使用しない場合は不要
















②以下サンプル（接続文字列はODBC接続）

Option Compare Database
Option Explicit
 
Private Const CON_STRING As String = "DSN=TEST_ODBC;Uid=USER1;Pwd=userpass1;Database=TEST_DB"
Private m_cn As New ADODB.Connection
 
' コネクションオープン用
Public Sub OpenConnection()
    m_cn = New ADODB.Connection
    m_cn.ConnectionString = CON_STRING
    m_cn.Open
End Sub
 
' コネクションクローズ用
Public Sub CloseConnection()
    m_cn.Close
End Sub
 
' コネクション取得用
Public Function GetConnection() As ADODB.Connection
    Set GetConnection = m_cn
End Function

③使用例

Option Compare Database
Private Sub test()
    Dim rst As New ADODB.Recordset
    Call OpenConnection
    
    rst.ActiveConnection = M_Connection.GetConnection
    rst.Open "select * from TEST_TBL1;"
    rst.Close
 
    Set rst = Nothing
    Call CloseConnection
End Sub