1. 入力画面

Size: px

Start display at page:

Download "1. 入力画面"

ゆずさうばら
5 years ago
Views:

1 指定した時刻に指定したマクロ (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 1. 入力画面

4 2. プログラム説明 2.1 モジュール構成

5 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 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 Sub Private Sub CommandButton1_Click() Call Module3.AutoStart_Time End End Sub

6 (3) 標準モジュール

7 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 start_time(cnt - 1) = UserForm1.Controls(I).Text

8 If start_time(cnt - 1) = CDate(0) Then Exit For 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) ' '

9 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 Next I Case " 時間間隔 " Start_Day(1) =.TextBox12.Text start_time(1) =.TextBox17.Text ' 開始時刻

10 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 Unload Me End Sub Private Sub CommandButton4_Click() End End Sub

11 (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 = "yahiro_mas@hb.tp1.jp" ' ' タイトル 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") '

12 Link = "mailto:" & Address & _ "?Subject=" & Subject & _ "&body=" & Body Link = Replace(Link, "&", "^&") ' ' 下記条件にすべて一致する場合コマンドラインの引用符が有効になる ' その判定を文字列 Link にあるかないかを cmd.exe を実行して判定する '1"/S" がない 2 引用符が 1 組ある 3 引用符の中に特殊文字 (& < > ( ) がない '4 引用符の中に 1 つ以上のスペースがある 5 引用符の中の文字列が実行可能ファイルの名前である ' 最初の文字が引用符であるにも関わらず上記 1~5の条件に一致しない場合は最初の引用符と ' コマンドラインの最後の引用符が削除され最後の引用符のあとのテキストが有効になる 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

13 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" _

14 (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

15 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() ' 作成 : 益永八尋 : 埼玉県さいたま市北区植竹町 ' 指定した時刻に指定したマクロ (Auto_Start_Macro) を実行する

16 が ' この処理は下記のコードが実行されていることが条件であるまた当該の 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

17 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 ' 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) '

18 ' 時間間隔から 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 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)

19 If strdot = "." Then DOK = 1 M = I strkakutyoushi = Mid(MyEXE, M, Rn - M + 1) Else DOK = 0 Next I ' Select Case strkakutyoushi Case ".EXE", ".exe" Case ".xls", ".XLS", ".xlsm", ".XLSM" ' 'EXCEL ファイルの場合の処理方法 'If strquit = "" Then ' MsgBox "Excel ファイルのタイプが不明ですタイプを選定してください " ' End ' Case Else MsgBox "EXCEL ファイル名に拡張子がついていません " End End Select

20 ' 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 '

21 .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)

22 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 '

23 .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 ' ' 自動スタートの設定 ' 自動スタートの形式スタート時刻実行回数 Schedule Call Run_Time(strTime_Type, start_time(), Run_Count, True) ' Exit Sub

24 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) ' Resume Next ' End '

25 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_Run 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 ' 文字列最後の文字から先頭に向かって検索するファイル名に. が付いている場合があるため確実に ' 検索できるようにした

26 strdot = Mid(MyEXE, I, 1) If strdot = "." Then DOK = 1 M = I strkakutyoushi = Mid(MyEXE, M, Rn - M + 1) Exit For Else DOK = 0 Next I ' Select Case strkakutyoushi Case ".EXE", ".exe" ' 実行ファイル :Application Case ".xls", ".XLS", ".xlsm", ".XLSM" 'Excel ファイル Case Else MsgBox "EXCEL ファイル名に拡張子がついていません " End End Select ' ' 'Excel の実行マクロ (Sub プロシージャ名 ) 取得

27 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

28 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 を使用する

29 ' Case Else 'End Select ' '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 ' ' エラーなしの場合は送信しない

30 If errcount <> 0 Then Call errmail_soushin(strprogram_err(), errcount) ' Resume Next ' End ' 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

31 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 * ST2 * 60 + ST3 ' 時間間隔から 1 日の繰り返し回数を計算する ' Call MTime(X)

32 ' AT1 = T(1) ' 時間 AT2 = T(2) ' 分 AT3 = T(3) ' 秒 ' ' 時間間隔を秒単位に変換する AT = AT1 * AT2 * 60 + AT3 + N2 * ' ' 終了時刻を秒単位に変換する ' 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) ' 秒

33 ' ' 終了時刻を秒単位に変換する ET = ET1 * ET2 * 60 + ET3 ' DT = ET - ST + N1 * 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 ' Resume Next

34 'Else ' ' エラーなしの場合は送信しない If errcount <> 0 Then Call errmail_soushin(strprogram_err(), errcount) ' Resume Next ' End ' End Function Sub MTime(X As Variant) Dim DOK As String ' ' 時刻の書式は112:15:33 25:15:01 の 2 通りである If Mid(X, 2, 1) = ":" Then Rn = 7 Else Rn = 8 J = 1 ' For I = 1 To Rn

35 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) J = J + 1 Else If J = 3 Then T(J) = Mid(X, Rn - 1, 2) Exit For Next I ' Exit Sub '****************************************************** errorhandler: errno = Err.Number 'DOK = MsgBox(Err.Description & Chr(13) & _ " Error Sub Name=Sub Main() ", vbyesno) '

36 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) ' Resume Next ' End ' End Sub Public Sub Run_Time(strTimeType As String, start_time() As Date, Run_N As Integer, AA As String) Dim DOK As String '

37 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 Next I Case " 時間間隔 " ' 一定の時間間隔でマクロ名 "Auto_Start_Macro" を実行する 'Act_Time = start_time(1) ' For I = 1 To Run_N If Start_Day(1) = Null Then ' 毎日一定の時間間隔で自動実行する

38 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 Next I Case Else End Select ' End Sub

1. 入力画面

1. 入力画面指定した時刻に指定したマクロ (VBA) を実行するプログラム (VBA) 益永八尋様々な業務を行っている場合には指定した時刻に指定したマクロ (Macro VBA) を実行したくなる場合があるたとえば 9:00 17: 00 や 1 時間 6 時間間隔に指定したマクロ (Macro VBA) を実行するこの様な場合に対応できるように汎用性の高いプログラムを作成したこの場合に注意する必要があるのは