2016年3月27日日曜日

VBScriptでタスクスケジューラの複数のタスクをXMLに出力、削除、作成

EGで登録したスケジュールのタスクを、他のユーザへ定期的に引き渡すためにVBScriptを組みました。特定のタスクをXMLファイルに出力、削除、登録します。

SCHTASKSを使っていますが、これ１つの操作で１タスクしか定義できません。じゃあPowerShellで書こうかと思ったのですが、お客様先の環境だと使えないことが多いためVBScriptで書きました。
  • tasks_list.vbs でXMLファイルを作成
  • tasks_delete.vbs でタスクを削除
  • tasks_create.vbs でタスクを作成
キーワードを含む名前のタスクをXML形式で出力します。

'----
' Windowsのタスク スケジューラから指定された名前のタスクをXML形式で表示します。
' 標準出力にはログ、標準エラー出力にはXMLを出力します。
' 使用例: C:\Windows\System32\cscript //b c:\temp\tasks_list.vbs 1> tasks.log 2> tasks.xml
'----

Option Explicit
Dim objShell
Dim objExec 
Dim objDictionary
Dim objFso
Dim strLine
Dim strCmd
Dim Count
Dim Name
Dim QuitCode
Const MINIMIZE_WINDOW = 2
Const SCHTASKS = "C:\Windows\System32\SCHTASKS.EXE"
Const KEYWORD = "スケジュール - "

'----
' チェック関数
'----

Function CheckError(fnName)
    CheckError = False
    
    Dim strmsg
    Dim errNum
    
    If Err.Number <> 0 Then
        strmsg = "ERROE: #" & Hex(Err.Number) & " in module " & fnName & " " & Err.Description
        WScript.Stdout.WriteLine strmsg
        CheckError = True
    End If
         
End Function

'----
' オブジェクト生成
'----

Set objShell = WScript.CreateObject("WScript.Shell")
Set objDictionary = WScript.CreateObject("Scripting.Dictionary")
Set objFso = WScript.CreateObject("Scripting.FileSystemObject")

'----
' タスク一覧表示
'----

Sub Main()
    Dim ExitCode
    Dim ErrCount

    '----
    ' タスク一覧から削除対象のタスク名を取得
    '----

    Set objExec = objShell.Exec(SCHTASKS & " /query /fo:csv")
    Count = 0
    Do Until objExec.StdOut.AtEndOfStream
        strLine = objExec.StdOut.ReadLine
        If InStr(strLine, KEYWORD) <> 0 Then
            Count = Count + 1
            objDictionary.Add Count, Mid(strLine, 1, InStr(strLine, ""","))
        End If
    Loop
    If objExec.ExitCode <> 0 Then
        Do Until objExec.StdErr.AtEndOfStream
            WScript.StdOut.WriteLine objExec.StdErr.ReadLine
        Loop
        Err.Raise(51)
    End If
    Set objExec = Nothing

    '----
    ' 件数を出力
    '----

    WScript.StdOut.WriteLine "NOTE: found " & Count & " tasks to export."

    '----
    ' タスクをXML形式で表示
    '----

    For Each Name In objDictionary.Keys
        strCmd = SCHTASKS & " /query /xml /tn:" & objDictionary(Name)
        WScript.StdOut.WriteLine strCmd
        Set objExec = objShell.Exec(strCmd)
        WScript.StdErr.WriteLine("")
        Do Until objExec.StdOut.AtEndOfStream
            WScript.StdErr.WriteLine(objExec.StdOut.ReadLine)
        Loop
        WScript.StdErr.WriteLine("")

        If objExec.ExitCode <> 0 Then
            Do Until objExec.StdErr.AtEndOfStream
                WScript.StdOut.WriteLine objExec.StdErr.ReadLine
            Loop
            Err.Raise(51)
        End If
        Set objExec = Nothing
    Next

End Sub

'----
' 処理実行
'----

Sub Try()
    Call Main()
End Sub

'----
' エラー捕捉
'----

Sub Catch()
    On Error Resume Next
    Call Try()
End Sub

'----
' 処理実行
'----

QuitCode=0
WScript.StdOut.WriteLine "NOTE: script=" & WScript.ScriptFullName & " date=" & Now()
Call Catch()
If CheckError("Catch") Then
    QuitCode = 1
End If

'----
' 終了
'----

Set objShell = Nothing
Set objDictionary = Nothing
Set objFso = Nothing
WScript.StdOut.WriteLine "NOTE: script finished with exit code " & QuitCode
WScript.Quit QuitCode
特定の名前のタスクを削除します。
'----
' Windowsのタスク スケジューラから指定された名前のタスクを削除します。
' 標準出力に削除のログを出力します。
' 使用例: C:\Windows\System32\cscript //b c:\temp\tasks_delete.vbs > tasks_delete_%date:~-2,2%.log
'----

Option Explicit
Dim objShell
Dim objExec 
Dim objDictionary
Dim objFso
Dim strLine
Dim strCmd
Dim Count
Dim Name
Dim objFile
Dim QuitCode
Const SCSHTASKS = "C:\Windows\System32\SCHTASKS.EXE"

'----
' 削除するタスク名の名前
'----

Const KEYWORD = "スケジュール - "

'----
' チェック関数
'----

Function CheckError(fnName)
    CheckError = False
    
    Dim strmsg
    Dim errNum
    
    If Err.Number <> 0 Then
        strmsg = "ERROE: #" & Hex(Err.Number) & " in module " & fnName & " " & Err.Description
        WScript.Stdout.WriteLine strmsg
        CheckError = True
    End If
         
End Function

'----
' オブジェクト生成
'----

Set objShell = WScript.CreateObject("WScript.Shell")
Set objDictionary = WScript.CreateObject("Scripting.Dictionary")
Set objFso = WScript.CreateObject("Scripting.FileSystemObject")

'----
' タスク削除
'----

Sub Main()
    Dim ExitCode
    Dim ErrCount

    '----
    ' タスク一覧から削除対象のタスク名を取得
    '----

    Set objExec = objShell.Exec(SCSHTASKS & " /query /fo:csv")
    Count = 0
    Do Until objExec.StdOut.AtEndOfStream
        strLine = objExec.StdOut.ReadLine
        If InStr(strLine, KEYWORD) <> 0 Then
            Count = Count + 1
            objDictionary.Add Count, Mid(strLine, 1, InStr(strLine, ""","))
        End If
    Loop
    If objExec.ExitCode <> 0 Then
        Do Until objExec.StdErr.AtEndOfStream
            WScript.StdOut.WriteLine objExec.StdErr.ReadLine
        Loop
        Err.Raise(51)
    End If
    Set objExec = Nothing

    '----
    ' 件数を出力
    '----

    WScript.StdOut.WriteLine "NOTE: found " & Count & " tasks to delete."

    '----
    ' タスクを削除
    '----

    For Each Name In objDictionary.Keys
        strCmd = SCSHTASKS & " /delete /f /tn " & objDictionary(Name)
        WScript.StdOut.WriteLine strCmd
        Set objExec = objShell.Exec(strCmd)

        Do Until objExec.StdOut.AtEndOfStream
            WScript.StdOut.WriteLine objExec.StdOut.ReadLine
        Loop

        If objExec.ExitCode <> 0 Then
            Do Until objExec.StdErr.AtEndOfStream
                WScript.StdOut.WriteLine objExec.StdErr.ReadLine
            Loop
            Err.Raise(51)
        End If
        Set objExec = Nothing
    Next

End Sub

'----
' 処理実行
'----

Sub Try()
    Call Main()
End Sub

'----
' エラー捕捉
'----

Sub Catch()
    On Error Resume Next
    Call Try()
End Sub

'----
' 処理実行
'----

QuitCode = 0
WScript.StdOut.WriteLine "NOTE: script=" & WScript.ScriptFullName & " date=" & Now()
Call Catch()
If CheckError("Catch") Then
    QuitCode = 1
End If

'----
' 終了
'----

Set objShell = Nothing
Set objDictionary = Nothing
Set objFso = Nothing
WScript.StdOut.WriteLine "NOTE: script finished with exit code " & QuitCode
WScript.Quit QuitCode
XMLファイルからタスクを作成します。
'----
' WindowsのタスクをXMLファイルから定義します。
' 引数に tasks_list.vbs で作成したXMLファイルを指定します。
' タスクの実行ユーザは、スクリプトの実行者に置き換えられます。
' 使用例: C:\Windows\System32\cscript //b c:\temp\tasks_create.vbs tasks.xml
'----

Option Explicit
Dim objShell
Dim objExec 
Dim objDictionary
Dim objFso
Dim strLine
Dim strCmd
Dim Count
Dim Name
Dim objFile
Dim xmlFile
Dim QuitCode
Const SCSHTASKS = "C:\Windows\System32\SCHTASKS.EXE"

'----
' 実行ユーザのキーワード
'----

Const KEYWORD = "      "

'----
' チェック関数
'----

Function CheckError(fnName)
    CheckError = False
    
    Dim strmsg
    Dim errNum
    
    If Err.Number <> 0 Then
        strmsg = "ERROE: #" & Hex(Err.Number) & " in module " & fnName & " " & Err.Description
        WScript.Stdout.WriteLine strmsg
        CheckError = True
    End If
         
End Function

'----
' XMLのコメントからユーザ名を取得
'----

Function XmlUserName(Buf)
    Dim Pos1, Pos2
    Const Keyword1 = "username="
    Const Keyword2 = " -->"

    XmlUserName = "N/A"

    Pos1 = InStr(Buf, Keyword1)
    Pos2 = InStr(Buf, Keyword2)
    If Pos1 <> 0 And Pos2 <> 0 Then
        XmlUserName = Mid(Buf, Pos1 + Len(Keyword1), Pos2 - (Pos1 + Len(Keyword1)))
    End If
End Function

'----
' XMLのコメントからタスク名を取得
'----

Function XmlTaskName(Buf)
    Dim Pos1, Pos2
    Dim AryStrings
    Const Keyword1 = "<!-- end "
    Const Keyword2 = "username="

    XmlTaskName = "N/A"

    Pos1 = InStr(Buf, Keyword1)
    Pos2 = InStr(Buf, Keyword2)
    If Pos1 <> 0 And Pos2 <> 0 Then
        XmlTaskName = Trim(Mid(Buf, Pos1 + Len(Keyword1), Pos2 - (Pos1 + Len(Keyword1))))
        XmlTaskName = Mid(XmlTaskName, 2, Len(XmlTaskName) - 2)

        AryStrings = Split(XmlTaskName, "\")
        XmlTaskName = AryStrings(UBound(AryStrings))
    End If
End Function

'----
' オブジェクト生成
'----

Set objShell = WScript.CreateObject("WScript.Shell")
Set objDictionary = WScript.CreateObject("Scripting.Dictionary")
Set objFso = WScript.CreateObject("Scripting.FileSystemObject")

'----
' タスク定義
'----

Sub Main()
    Dim UserName
    Dim TaskName
    Dim FilePath

    '----
    ' テンポラリファイルのパスを設定
    '----
    FilePath = objShell.ExpandEnvironmentStrings("%TEMP%") & "\task.xml"

    '----
    ' 引数のXMLファイルを開く
    '----
    If WScript.Arguments.Count <> 1 Then
        Err.Rase(51)
    End If
    Set objFile = objFso.OpenTextFile(WScript.Arguments.Item(0))

    Count = 0
    strLine = objFile.ReadLine
    Do Until objFile.AtEndOfStream
        If InStr(strLine, "<!-- begin") <> 0 Then
            Set xmlFile = objFSO.OpenTextFile(FilePath, 2, True)
            strLine = objFile.ReadLine
            Do Until objFile.AtEndOfStream or (InStr(strLine, "<!-- end") <> 0)
                ' ユーザIDを書き換える
                If InStr(strLine, KEYWORD) = 1 Then
                    strLine = "      " & objShell.ExpandEnvironmentStrings("%USERDOMAIN%") & "\" & objShell.ExpandEnvironmentStrings("%USERNAME%") & ""
                End If
                xmlFile.WriteLine strLine
                strLine = objFile.ReadLine
            Loop
            UserName = xmlUserName(strLine)
            TaskName = xmlTaskName(strLine)
            xmlFile.Close

            '----
            ' タスク登録
            '----
            Count = Count + 1
            strCmd = SCSHTASKS & " /create /xml """ & FilePath & """ /tn:""EG\" & UserName & "." & Right("000" & Count, 3) & " " & TaskName & """"
            WScript.StdOut.WriteLine strCmd
            Set objExec = objShell.Exec(strCmd)

            Do Until objExec.StdOut.AtEndOfStream
                WScript.StdOut.WriteLine objExec.StdOut.ReadLine
            Loop
            If objExec.ExitCode <> 0 Then
                Do Until objExec.StdErr.AtEndOfStream
                    WScript.StdOut.WriteLine objExec.StdErr.ReadLine
                Loop
                Err.Raise(51)
            End If
            Set objExec = Nothing

        End If
        If objFile.AtEndOfStream = False Then
            strLine = objFile.ReadLine
        End If
    Loop

    '----
    ' 件数を出力
    '----

    WScript.StdOut.WriteLine "NOTE: create " & Count & " tasks."

    '----
    ' テンポラリのXMLファイルを削除
    '----
    objFso.DeleteFile FilePath, True

End Sub

'----
' 処理実行
'----

Sub Try()
    Call Main()
End Sub

'----
' エラー捕捉
'----

Sub Catch()
    On Error Resume Next
    Call Try()
End Sub

'----
' 処理実行
'----

QuitCode = 0
WScript.StdOut.WriteLine "NOTE: script=" & WScript.ScriptFullName & " date=" & Now()
Call Catch()
If CheckError("Catch") Then
    QuitCode = 1
End If

'----
' 終了
'----

Set objShell = Nothing
Set objDictionary = Nothing
Set objFso = Nothing
WScript.StdOut.WriteLine "NOTE: script finished with exit code " & QuitCode
WScript.Quit QuitCode

投稿者 時刻:
ラベル: ,

2 件のコメント :

  1. mining2016年3月27日 21:44

    VBScriptを貼り付けたら、最後にゴミが混じる。
    なんどか削除を試みたけど、＜／userid＞が残っています。

    返信削除
  2. mining2016年3月30日 23:34

    さらに注意点を書いときます。
    Windows7だとPCスリープしているときには、タスクが動きません。
    XMLファイルのをtrueに書き換えてください。

    返信削除

登録: コメントの投稿 ( Atom )