指定した時刻に指定したマクロ（
VBA）を実行するプログラム（VBA)
益永八尋 様々な業務を行っている場合には、指定した時刻に指定したマクロ（Macro、VBA)を実行したくなる場合がある。たとえば、9：00、17： 00、や 1 時間、6 時間間隔に指定したマクロ（Macro、VBA)を実行する。また、月に 1 回、毎週 1 回定期的または不定期的にある時刻にな れば指定したプログラムを実行させる。この様な場合に対応できるように汎用性の高いプログラムに改良した。この場合に注意する必要があ るのは、実行されたマクロ（Macro）は、終了時刻がくるまで実行され、途中で実行を中止することが困難なことです。このためこのプログ ラムでは、入力値の再確認を行うためのform を表示するように改良した。実行された場合に、止むを得ず途中で実行を中止するには、強制 的にシャットダウン（すでに実行中の場合）を行うしか方法がありません（適切な方法ではない）。実行前であれば、通常のシャットダウン で中止できます（記憶されている実行命令を解除する）が、他の方法はないと思われる。実行させるプログラムは、どのようなプログラム（EXE ファイル（アプリケーション）、VBA(マクロのある)EXCE ファイル、Word（VBA）、 Fortran で作成された EXE ファイル等）でも選択できるように設定してある。
また、参考として、パソコン起動時に本プログラムを自動実行させるための設定方法とパソコンの自動電源 ON、OFF についての参考資 料を明示している。
2.プログラム説明
2.2 プログラムコード
（1）Microsoft Excel Objects
Sheet3(Main)のコード
Private Sub CheckBox1_Click() If CheckBox1.Value = True Then Cells(24, 30) = 1
Cells(24, 32) = False 'CheckBox2 Cells(31, 32) = False 'CheckBox3 End If
End Sub
Private Sub CheckBox2_Click() If CheckBox2.Value = True Then Cells(24, 30) = 2
Cells(24, 31) = False 'CheckBox1 Cells(31, 32) = False 'CheckBox3 End If
End Sub
Private Sub CommandButton1_Click() Call Module3.AutoStart_Time End
Private Sub CommandButton1_Click() Dim DOK As String
Dim Run_Count As Integer Dim cnt As Integer
Dim AA As String
'---
DOK = MsgBox("設定した自動実行を取り消します。よろしいですか。", vbYesNo) '---
If DOK = vbYes Then
'---
strTime_Type = TextBox1.Text '任意の特定時刻 With UserForm1
Select Case strTime_Type Case "特定時刻" '--- 'TextBox が多いので Controls コレクションで対応するのがプログラムコードが簡潔になる。 cnt = 0 For I = 1 To UserForm1.Controls.Count strText = UserForm1.Controls(I).Name If "TextBox" = Mid(strText, 1, 7) Then cnt = cnt + 1
If cnt >= 2 Then
If start_Time(cnt - 1) = CDate(0) Then Exit For End If End If End If Next I '--- Case "時間間隔" start_Time(1) = .TextBox12.Text '開始時刻 Interval_Time = .TextBox13.Text '時間間隔 End_Time = .TextBox14.Text '終了時刻 '---
Interval_Nisuu = DateDiff("s", Start_Day(1), End_Day) '終了時刻でも実行させるため+1 にしている。
Run_Count = Repeat_N(start_Time(1), Interval_Time, End_Time, Interval_Nisuu, Interval_Day) + 1 End Select
End With
'---
Call Run_Time(strTime_Type, start_Time(), Run_Count, False) '---
End If
Unload Me
'--- End Sub
Private Sub CommandButton2_Click()
DOK = MsgBox("自動実行を開始します。よろしいですか。", vbYesNo) '---
If DOK = vbYes Then
'---
strTime_Type = TextBox1.Text '任意の特定時刻 With UserForm1
Select Case strTime_Type Case "特定時刻" For I = 1 To 10 start_Time(I) = Cells(I + 27, 3) '開始時刻 If Cells(I + 27, 3) = "" Then Dn = I - 1 Exit For End If Next I Case "時間間隔" Start_Day(1) = .TextBox12.Text start_Time(1) = .TextBox17.Text '開始時刻
Interval_Day = .TextBox13.Text
Interval_Time = .TextBox18.Text '時間間隔 End_Day = .TextBox14.Text
End_Time = .TextBox19.Text '終了時刻 '---
Interval_Nisuu = DateDiff("s", Start_Day(1), End_Day) '終了時刻でも実行させるため+1 にしている。
Run_Count = Repeat_N(start_Time(1), Interval_Time, End_Time, Interval_Nisuu, Interval_Day) + 1 End Select End With End If Unload Me End Sub
Private Sub CommandButton4_Click() End
(3) 標準モジュール
Module1 のコード
Public errCount As Integer 'エラー発生回数のカウント
Public strProgram_Err(1000) As String 'エラーの内容（プロシージャ名、エラー番号等） Public Sub errMail_Soushin(strProgram_Err() As String, errCount As Integer)
'このメール送信プログラムでは添付ファイルの送信ができない。要修正 2013/5/1 '宛先
Dim strBody As String
Address = "[email protected]" '--- 'タイトル Subject = "エラー発生の通知" '--- '本文 For I = 1 To errCount
strBody = strBody & strProgram_Err(I) & ":" 'Chr(13)：改行 Next I
'---
Body = "益永八尋" & "様" & vbCrLf & vbCrLf
Body = Body & "プログラム名=Auto_Run:" & strBody & vbCrLf Body = Replace(Body, vbCrLf, "%0D%0A")
Link = "mailto:" & Address & _ "?Subject=" & Subject & _ "&body=" & Body
Link = Replace(Link, "&", "^&") '--- '下記条件にすべて一致する場合コマンドラインの引用符が有効になる。 'その判定を文字列 Link にあるかないかを cmd.exe を実行して判定する '①"/S"がない、②引用符が 1 組ある、③引用符の中に特殊文字(&、<、>、(、)、@、｜）がない '④引用符の中に 1 つ以上のスペースがある、⑤引用符の中の文字列が、実行可能ファイルの名前である '最初の文字が引用符であるにも関わらず上記①～⑤の条件に一致しない場合は、最初の引用符と 'コマンドラインの最後の引用符が削除され、最後の引用符のあとのテキストが有効になる。
Shell "cmd.exe /c start " & Link 'shell：exe（実行ファイル）を実行する '---
Do
On Error Resume Next AppActivate Subject MyErr = Err.Number On Error GoTo 0 Loop Until MyErr = 0
'---
Application.Wait Now() + TimeValue("00:00:01") SendKeys "%s", True
Exit Sub End Sub
Module3 のコード
Public Declare Function GetExitCodeProcess Lib "kernel32" _ (ByVal hProcess As Long, lpExitCode As Long) As Long Public Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _ ByVal dwProcessID As Long) As Long
Public Const PROCESS_QUERY_INFORMATION = &H400 '---
Public MyEXE As String Public MyEXE_Fie As String Public T(5) As Integer
'--- 'エラー内容のメール送信処理のための変数設定
Public Repeat As Integer
Public errCount As Integer 'エラー発生回数のカウント
Public strProgram_Err(1000) As String 'エラーの内容（プロシージャ名、エラー番号等） '---
Public start_Time(20) As Date Public Start_Day(20) As Date Public Interval_Day As Integer Public Interval_Nisuu As Integer Public End_Day As Date
Public End_Time As Date Public Act_Time As Date Public Interval_Time As Date Public Run_Count As Integer Public strTimeType As String
Public Run_N As Integer Public strTime_Type As String Public strQuit As String Public Macro_EXE As String Sub EXE_RUN()
Dim dwProcessID As Long Dim hProcess As Long Dim lpdwExitCode As Long Dim ret As Long
'--- dwProcessID = Shell(MyEXE, 1)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, True, dwProcessID) '---
Do
ret = GetExitCodeProcess(hProcess, lpdwExitCode) DoEvents
Loop While lpdwExitCode
'--- MsgBox MyEXE_Fie & "終了しました。" End Sub
Sub AutoStart_Time()
'2013.6.3 作成：益永八尋：埼玉県さいたま市北区植竹町
'この処理は下記のコードが実行されていることが条件である。また、当該の WorkBook が開かれていることも条件である。下記コード が '実行された後に WorkBook を閉じてしまえば指定の時刻になっても指定のマクロは実行されない。 '--- '下記コードは"Auto_Start_Macro"を現在の時刻から 10 秒後に実行する命令である。 'このコードでは 1 回だけ実行する。一定時間間隔で Macro を実行するには繰り返し処理が必要である。 '--- '特定の時刻にマクロ」名"Auto_Start_Macro"を実行する。 '************************************************************************************************** '
Dim DOK As String
'--- 'データ入力
'--- Sheets("Main").Select
'strQuit = Cells(19, 6) 'Excel のファイルタイプ strM = Cells(24, 30) '任意の特定時刻 '--- Select Case strM Case 1 strTime_Type = "特定時刻" '--- For I = 1 To 10
Start_Day(I) = Cells(I + 27, 3) '開始年月日 start_Time(I) = Cells(I + 27, 4) '開始時刻 '--- If Cells(I + 27, 3) = "" Then Run_Count = I - 1 Exit For End If '--- Next I '--- Case 2 strTime_Type = "時間間隔" Start_Day(1) = Cells(27, 7) '開始年月日 start_Time(1) = Cells(27, 8) '開始時刻 Interval_Day = Cells(28, 7) '間隔（日） Interval_Time = Cells(28, 8) '間隔（時間） End_Day = Cells(29, 7) '終了年月日 End_Time = Cells(29, 8) '終了時刻 Act_Time = start_Time(1) '--- '開始年月日と終了年月日の時間間隔を取得する
Interval_Nisuu = DateDiff("s", Start_Day(1), End_Day) '---
'時間間隔から 1 日の繰り返し回数を計算する '総実行回数
'終了時刻でも実行させるため+1 にしている。
Run_Count = Repeat_N(start_Time(1), Interval_Time, End_Time, Interval_Nisuu, Interval_Day) + 1 '---
'1 日当り実行回数
If Interval_Day = 0 Then
Delta_Sec = DateDiff("s", start_Time(1), End_Time) Delta = DatePart("s", Interval_Time)
'終了時刻でも実行させるため+1 にしている。 Day_Run_Count = Delta_Sec / Delta + 1 End If Case Else End Select '--- '実行させたいプログラム名（Path 名を含む） MyEXE = Cells(17, 6) strKatyoushi = Right(MyEXE, 4) Rn = Len(MyEXE) '--- For I = 1 To Rn strDot = Mid(MyEXE, I, 1)
If strDot = "." Then DOK = 1 M = I strKakutyoushi = Mid(MyEXE, M, Rn - M + 1) Else DOK = 0 End If Next I '---
Select Case strKakutyoushi Case ".EXE", ".exe"
Case ".xls", ".XLS", ".xlsm", ".XLSM" '--- 'EXCEL ファイルの場合の処理方法 'If strQuit = "" Then
' MsgBox "Excel ファイルのタイプが不明です。タイプを選定してください。" ' End 'End If Case Else MsgBox "EXCEL ファイル名に拡張子がついていません" End End Select
'---
DOK = MsgBox("自動実行を設定しました。再確認をおこないます。", vbYesNoCancel) If DOK = vbYes Then
'自動実行の最終確認
'これは自動実行を設定した場合は、途中での実行停止が困難であるためである。 With UserForm1
.TextBox1.Text = strTime_Type '--- Select Case strTime_Type Case "特定時刻" .TextBox2.Visible = True .TextBox3.Visible = True .TextBox4.Visible = True .TextBox5.Visible = True .TextBox6.Visible = True .TextBox7.Visible = True .TextBox8.Visible = True .TextBox9.Visible = True .TextBox10.Visible = True .TextBox11.Visible = True .TextBox20.Visible = True .TextBox21.Visible = True '---
.TextBox12.Visible = False .TextBox13.Visible = False .TextBox14.Visible = False .TextBox15.Visible = False .TextBox16.Visible = False .TextBox17.Visible = False .TextBox18.Visible = False .TextBox19.Visible = False '--- .TextBox2.Text = start_Time(1) .TextBox3.Text = start_Time(2) .TextBox4.Text = start_Time(3) .TextBox5.Text = start_Time(4) .TextBox6.Text = start_Time(5) .TextBox7.Text = start_Time(6) .TextBox8.Text = start_Time(7) .TextBox9.Text = start_Time(8) .TextBox10.Text = start_Time(9) .TextBox11.Text = start_Time(10) '--- .TextBox20.Text = start_Time(11) .TextBox21.Text = start_Time(12)
Case "時間間隔" .TextBox2.Visible = False .TextBox3.Visible = False .TextBox4.Visible = False .TextBox5.Visible = False .TextBox6.Visible = False .TextBox7.Visible = False .TextBox8.Visible = False .TextBox9.Visible = False .TextBox10.Visible = False .TextBox11.Visible = False .TextBox20.Visible = False .TextBox21.Visible = False '--- .TextBox12.Visible = True .TextBox13.Visible = True .TextBox14.Visible = True .TextBox15.Visible = True .TextBox16.Visible = True .TextBox17.Visible = True .TextBox18.Visible = True .TextBox19.Visible = True '---
.TextBox12.Text = Start_Day(1) .TextBox13.Text = Interval_Day .TextBox14.Text = End_Day .TextBox15.Text = Day_Run_Count '--- .TextBox16.Text = Run_Count .TextBox17.Text = start_Time(1) .TextBox18.Text = Interval_Time .TextBox19.Text = End_Time Case Else End Select '--- .Show End With End If '--- '自動スタートの設定 '自動スタートの形式、スタート時刻、実行回数、Schedule Call Run_Time(strTime_Type, start_Time(), Run_Count, True) '---
End
'****************************************************** errorHandler:
errNo = Err.Number
'DOK = MsgBox(Err.Description & Chr(13) & _
"【Error Sub Name=Sub Main()】", vbYesNo) '---
errCount = errCount + 1
strProgram_Err(errCount) = "エラー番号=" & errNo & ":" & "ErrorSubName=AutoStart_Time():" & _ Err.Description & Chr(13)
'--- 'If DOK = vbYes Then
' Resume Next 'Else
'---
'エラーなしの場合は送信しない If errCount <> 0 Then
Call errMail_Soushin(strProgram_Err(), errCount) End If
'--- Resume Next ' End
End Sub
Sub Auto_Start_Macro() Dim DOK As String
Dim strKakutyoushi As String 'ファイルの拡張子 Dim DOK_Num As Integer
'--- 'データ入力
'Public で変数 MyEXE を定義しているが、Sub プロシージャ AutoStart_Time で実行
'した Application.OnTime の命令ででは値の引き渡しがきないので、下記 2 行の記述を追加した 2012/10/28:追加 'Workbooks("Auto_Run93-2003.xls").Activate Workbooks("Auto_Run.xlsm").Activate Sheets("Main").Select '2012/10/28: 追加 '--- Sheets("Main").Select MyEXE = Cells(17, 6) '2012/10/28:追加 'strQuit = Cells(19, 6) 'Excel のファイルタイプ
'--- '実行プログラムに拡張子".exe"がついていない場合の処理 Rn = Len(MyEXE) '--- For I = Rn To 1 Step -1 '文字列最後の文字から先頭に向かって検索する。ファイル名に”.”が付いている場合があるため、確実に '検索できるようにした。
strDot = Mid(MyEXE, I, 1) If strDot = "." Then DOK = 1 M = I strKakutyoushi = Mid(MyEXE, M, Rn - M + 1) Exit For Else DOK = 0 End If Next I '--- Select Case strKakutyoushi Case ".EXE", ".exe"
'実行ファイル：Application Case ".xls", ".XLS", ".xlsm", ".XLSM" 'Excel ファイル Case Else MsgBox "EXCEL ファイル名に拡張子がついていません" End End Select '--- '--- 'Excel の実行マクロ（Sub プロシージャ名）取得
Sheets("Main").Select Macro_EXE = Cells(18, 6) '--- '実行ファイルの起動方法の選択
If Left(MyEXE, 5) <> "EXCEL" And Right(MyEXE, 3) = "exe" Then 'EXCEL 以外の実行ファイル（アプリケーション）の場合 Call Module3.EXE_RUN
'--- Else
'Excel ファイルを開く
'Excel ファイルをここで開くコードを記述しているので、自動実行対象の Excel ファイルの VBA コードに 'ExcelFile の close 文または Application.Quit 文があっても関係ない。
Workbooks.Open MyEXE '--- 'Book 名を取得する Rn = Len(MyEXE) MyBook = "" '--- For I = 1 To Rn AA = Mid(MyEXE, I, 1) If AA = "¥" Then J = J + 1 Mn = I
End If Next I
'--- For I = Mn + 1 To Rn AA = Mid(MyEXE, I, 1) MyBook = MyBook & AA Next I '--- If Macro_EXE <> "" Then 'Excel ファイルに Macro 名が入力されている場合 Workbooks(MyBook).Activate '指定した Excel ファイルをアクティブにする If Macro_EXE <> "" Then
'Select Case strQuit ' Case "有"
'VBA コードに”Application.Quit”の記述あり
'Application.Run Macro:=MyEXE & "!" & Macro_EXE 'Call 文では他のブックの Sub プロシージャを 実行できないのでRun を使用する。
Application.Run Macro:=MyBook & "!" & Macro_EXE 'Call 文では他のブックの Sub プロシージャを 実行できないのでRun を使用する。
' Case "なし"
'VBA コードに”Application.Quit”の記述なし
' Application.Run Macro:=MyBook & "!" & Macro_EXE 'Call 文では他のブックの Sub プロシージャを 実行できないのでRun を使用する。
' Case Else 'End Select End If End If End If '--- 'MsgBox "指定時刻に Macro を実行しました。" Exit Sub '****************************************************** errorHandler: errNo = Err.Number
'DOK = MsgBox(Err.Description & Chr(13) & _
"【Error Sub Name=Sub Main()】", vbYesNo) '---
errCount = errCount + 1
strProgram_Err(errCount) = "エラー番号=" & errNo & ":" & "ErrorSubName=Auto_Start_Macro():" & _ Err.Description & Chr(13)
'--- 'If DOK = vbYes Then
' Resume Next 'Else
'---
If errCount <> 0 Then
Call errMail_Soushin(strProgram_Err(), errCount) End If '--- Resume Next ' End 'End If End Sub
Public Function Repeat_N(StartT As Date, X As Date, EndT As Date, N1 As Integer, N2 As Integer) 'SarT：開始時刻、X：間隔（時間/日）、EndT：終了時刻
'開始時刻を秒単位に変換する 'N1:終了日-開始日（sec) 'N2:間隔（日数） Dim DOK As String Dim Rn As Integer Dim StartDay As Date Dim EndDay As Date Dim Dummy As String Dim AA As String
Dim Interval_Day As Long Dim DT As Long
Dim AT As Long Dim ET As Long
Dim ET1 As Long Dim ET2 As Long Dim ET3 As Long Dim ST1 As Long Dim ST2 As Long Dim ST3 As Long Dim AT1 As Long Dim AT2 As Long Dim AT3 As Long '--- '時刻データのみ取得 '開始時刻を秒に変換 Call MTime(StartT) '--- ST1 = T(1) '時間 ST2 = T(2) '分 ST3 = T(3) '秒 '--- '開始時刻を秒単位に変換する ST = ST1 * 3600 + ST2 * 60 + ST3 '時間間隔から 1 日の繰り返し回数を計算する '--- Call MTime(X)
'--- AT1 = T(1) '時間 AT2 = T(2) '分 AT3 = T(3) '秒 '--- '時間間隔を秒単位に変換する
AT = AT1 * 3600 + AT2 * 60 + AT3 + N2 * 86400 '--- '終了時刻を秒単位に変換する '--- Call MTime(EndT) '--- ET1 = T(1) '時間 '--- If ET1 = 0 Then ET1 = 24 ET2 = 0 '分 ET3 = 0 '秒 Else ET1 = T(1) ET2 = T(2) '分 ET3 = T(3) '秒
End If
'---
'終了時刻を秒単位に変換する ET = ET1 * 3600 + ET2 * 60 + ET3 '--- DT = ET - ST + N1 * 86400 Dn = Int(DT / AT) Repeat_N = Dn Exit Function '****************************************************** errorHandler: errNo = Err.Number
'DOK = MsgBox(Err.Description & Chr(13) & _
"【Error Sub Name=Sub Main()】", vbYesNo) '---
errCount = errCount + 1
strProgram_Err(errCount) = "エラー番号=" & errNo & ":" & "ErrorFunctionName=Repeat_N():" & _ Err.Description & Chr(13)
'--- 'If DOK = vbYes Then
'Else
'---
'エラーなしの場合は送信しない If errCount <> 0 Then
Call errMail_Soushin(strProgram_Err(), errCount) End If '--- Resume Next ' End 'End If End Function
Sub MTime(X As Variant) Dim DOK As String '--- '時刻の書式は①12：15：33、②5：15：01 の 2 通りである If Mid(X, 2, 1) = ":" Then Rn = 7 Else Rn = 8 End If J = 1 '--- For I = 1 To Rn
BB = Mid(X, I, 1) If Mid(X, I, 1) = ":" Then If J = 1 Then T(J) = Mid(X, 1, I - 1) Else T(J) = Mid(X, I - 2, 2) End If J = J + 1 Else If J = 3 Then T(J) = Mid(X, Rn - 1, 2) Exit For End If End If Next I '--- Exit Sub '****************************************************** errorHandler: errNo = Err.Number
'DOK = MsgBox(Err.Description & Chr(13) & _
"【Error Sub Name=Sub Main()】", vbYesNo) '---
errCount = errCount + 1
strProgram_Err(errCount) = "エラー番号=" & errNo & ":" & "ErrorSubName=MTime():" & _ Err.Description & Chr(13)
'--- 'If DOK = vbYes Then
' Resume Next 'Else
'---
'エラーなしの場合は送信しない If errCount <> 0 Then
Call errMail_Soushin(strProgram_Err(), errCount) End If '--- Resume Next ' End 'End If End Sub
Public Sub Run_Time(strTimeType As String, start_Time() As Date, Run_N As Integer, AA As String) Dim DOK As String
'---
Select Case strTimeType Case "特定時刻"
'任意の特定時刻にマクロ名"Auto_Start_Macro"を実行する。 For I = 1 To Run_N
If Start_Day(I) = Null Then
'毎日の特定時刻になれば、自動実行する Act_Time = start_Time(I)
Application.OnTime Earliesttime:=TimeValue(Act_Time), procedure:="Auto_Start_Macro", Schedule:=AA Else
'特定日付の特定時刻に自動実行する If Start_Day(I) = Date Then
Act_Time = start_Time(I)
Application.OnTime Earliesttime:=TimeValue(Act_Time), procedure:="Auto_Start_Macro", Schedule:=AA End If End If Next I Case "時間間隔" '一定の時間間隔でマクロ名"Auto_Start_Macro"を実行する。 'Act_Time = start_Time(1) '--- For I = 1 To Run_N
If Start_Day(1) = Null Then
Act_Time = start_Time(1) + Interval_Time * (I - 1)
Application.OnTime Earliesttime:=TimeValue(Act_Time), procedure:="Auto_Start_Macro", Schedule:=AA Else
'特定の日付のみ一定の時間間隔で自動実行する If Start_Day(1) = Date Then
Act_Time = start_Time(1) + Interval_Time * (I - 1)
Application.OnTime Earliesttime:=TimeValue(Act_Time), procedure:="Auto_Start_Macro", Schedule:=AA End If End If Next I Case Else End Select '--- End Sub
