指定した時刻に指定したマクロ (VBA) を実行するプログラム (VBA) 益永八尋 様々な業務を行っている場合には 指定した時刻に指定したマクロ (Macro VBA) を実行したくなる場合がある たとえば 9:00 17: 00 や 1 時間 6 時間間隔に指定したマクロ (Macro VBA) を実行する この様な場合に対応できるように汎用性の高いプログラムを作成した この場合に注意する必要があるのは 実行されたマクロ (Macro) は 終了時刻がくるまで実行され 途中で実行を中止することが困難なことです このためこのプログラムの実行の際には注意が必要です 止むを得ず途中で実行を中止するには 強制的にシャットダウン ( すでに実行中の場合 ) を行うしか方法がありません ( 適切な方法ではない ) 実行前であれば 通常のシャットダウンで中止できます( 記憶されている実行命令を解除する ) が 他の方法はないと思われる ( 未調査 ) 実行させるプログラムは どのようなプログラムでも選択できるように設定してある
1. 入力画面
2. プログラム説明 2.1 モジュール構成
2.2 プログラムコード (1)Microsoft Excel Objects Sheet3(Main) のコード Private Sub CheckBox1_Click() If Cells(23, 30) = True Then Cells(23, 31) = False Else Cells(23, 31) = True End Sub Private Sub CheckBox2_Click() If Cells(23, 31) = True Then Cells(23, 30) = False Else Cells(23, 30) = True End Sub Private Sub CommandButton1_Click()
Call Module3.AutoStart_Time End End Sub (2) 標準モジュール 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 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() ' 指定した時刻に指定したマクロ (Auto_Start_Macro) を実行する ' この処理は下記のコードが実行されていることが条件である また 当該の WorkBook が開かれていることも条件である 下記コードが ' 実行された後に WorkBook を閉じてしまえば指定の時刻になっても指定のマクロは実行されない Dim Start_Time(10) As Date Dim End_Time As Date Dim Act_Time As Date Dim Interval_Time As Date '-------------------------------------------------------------------------------------------------- ' 下記コードは "Auto_Start_Macro" を現在の時刻から 10 秒後に実行する命令である ' このコードでは 1 回だけ実行する 一定時間間隔で Macro を実行するには繰り返し処理が必要である
'------------------------------------------------------------------------------------------ ' 特定の時刻にマクロ 名 "Auto_Start_Macro" を実行する '************************************************************************************************** ' '-------------------------------------- strm = Cells(24, 30) ' 任意の特定時刻 If strm = True Then strtime_type = " 特定時刻 " For I = 1 To 10 Start_Time(I) = Cells(I + 27, 3) ' 開始時刻 If Cells(I + 27, 3) = "" Then Dn = I - 1 Exit For Next I Else strtime_type = " 時間間隔 " Start_Time(1) = Cells(27, 6) ' 開始時刻 Interval_Time = Cells(28, 6) ' 時間間隔 End_Time = Cells(29, 6) ' 終了時刻 '------------------------------------- ' 実行させたいプログラム名 (Path 名 )
MyEXE = Cells(18, 6) If Right(MyEXE, 3) <> "EXE" Or Right(MyEXE, 3) <> "exe" Then MyEXE = MyEXE & ".exe" MsgBox " 実行プログラム名に拡張子 [.exe] がついていないのでこれを付加した " '-------------------------------------- Select Case strtime_type Case " 特定時刻 " ' 任意の特定時刻にマクロ名 "Auto_Start_Macro" を実行する For I = 1 To Dn Act_Time = Start_Time(I) Application.OnTime Earliesttime:=TimeValue(Act_Time), procedure:="auto_start_macro" Next I Case " 時間間隔 " ' 一定の時間間隔でマクロ名 "Auto_Start_Macro" を実行する Act_Time = Start_Time(1) '----------------------------------- ' 時間間隔から 1 日の繰り返し回数を計算する Dn = Repeat_N(Start_Time(1), Interval_Time, End_Time) '---------------------------------- For I = 1 To Dn Act_Time = Act_Time + Interval_Time Application.OnTime Earliesttime:=TimeValue(Act_Time), procedure:="auto_start_macro"
Next I Case Else End Select End Sub Sub Auto_Start_Macro() Dim Macro_EXE As String '------------------------ ' データ入力 'Public で変数 MyEXE を定義しているが Sub プロシージャ AutoStart_Time で実行 ' した Application.OnTime の命令ででは値の引き渡しがきないので 下記 2 行の記述を追加した 2012/10/28: 追加 Sheets("Main").Select '2012/10/28: 追加 MyEXE = Cells(18, 6) '2012/10/28: 追加 '------------------------ ' 実行プログラムに拡張子 ".exe" がついていない場合の処理 If Right(MyEXE, 4) <> "xlsm" And Right(MyEXE, 3) <> "exe" Then MyEXE = MyEXE & ".exe" '------------------------------------ 'Excel の実行マクロ (Sub プロシージャ名 ) 取得 Macro_EXE = Cells(19, 6) '------------------------------------ ' 実行ファイルの起動方法の選択
If Left(MyEXE, 5) <> "EXCEL" And Right(MyEXE, 3) = "exe" Then 'EXCEL 以外の実行ファイル ( アプリケーション ) の場合 Call Module3.EXE_RUN '--------------------- Else 'Excel ファイルを開く 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 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 Application.Run MyBook & "!" & Macro_EXE 'Call 文では他のブックの Sub プロシージャを実行できないので Run を使用する '---------------------------------------- 'MsgBox " 指定時刻に Macro を実行しました " End Sub Private Function Repeat_N(SartT As Date, X As Date, EndT As Date) 'SarT: 開始時刻 EndT: 終了時刻 ' 開始時刻を秒単位に変換する '--------------- Call MTime(SartT) '--------------------------- 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 '--------------------------------- ' 終了時刻を秒単位に変換する '--------------- 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) ' 秒 '--------------------- ET = ET1 * 3600 + ET2 * 60 + ET3 '--------------------------------- DT = ET - ST Dn = DT / AT Repeat_N = Dn End Function Sub MTime(X As Date) If Mid(X, 2, 1) = ":" Then Rn = 7 Else Rn = 8 J = 1 '--------------------- For I = 1 To Rn
BB = Mid(X, I, 1) If Mid(X, I, 1) = ":" Then T(J) = AA AA = 0 J = J + 1 Else AA = AA + Mid(X, I, 1) If I = Rn Then T(J) = AA Next I '--------------- End Sub