XSLT変換

Option Explicit

const XSLDirName = "stylesheet\"
const OutFileName = "out.html"

Dim CurrentDir, xslDir, objFSO, objFolder, objFile, xslList, SelectItem, Ret, strContent, objIE

If ( Wscript.Arguments.Count < 1 ) then
    'MsgBox "XMLファイルを指定してください"
    'WScript.Quit
End If

' ファイルシステムオブジェクトを作成
Set objFSO = CreateObject("Scripting.FileSystemObject")

' スタイルシートディレクトリを取得
CurrentDir = Replace(WScript.ScriptFullName, WScript.ScriptName, vbNullString)
xslDir = CurrentDir & XSLDirName

' スタイルシート一覧を取得
Set objFolder = objFSO.GetFolder(xslDir)
For Each objFile in objFolder.Files
    If (Right(objFile.Name, 4) = ".xsl") Then
        xslList = xslList & objFile.Name & ","
    End If
Next

' スタイルシートがある場合は不要なカンマを削除、無い場合は終了
If (Right(xslList,1) = ",") Then
    xslList = Left(xslList, Len(xslList)-1)
Else
    MsgBox "以下の場所にスタイルシートが見つかりませんでした。" & vbCrLf & "スタイルシートを配置後、スクリプトを実行してください。" & vbCrLf & xslDir, 64 , "処理の中止"
    WScript.Quit
End If

' 適用するスタイルシートを取得
SelectItem = SelectList(Split(xslList, ","), TYPE_STRING, "適用スタイルシートの選択")

' キャンセルされた場合は処理を中止
If (SelectItem = STRING_CANCEL) Then
    MsgBox "ファイルの選択がキャンセルされました。" & vbCrLf & "処理を中止します。" & vbCrLf & xslDir, 64 , "処理の中止"
    WScript.Quit
End If

' 変換処理を実施
Ret = transformFiles(WScript.Arguments.Item(0), xslDir & SelectItem, strContent)

' エラーの場合はエラー内容を表示し、処理を中止
If (Ret = RETURN_ERR) Then
    MsgBox "変換処理に失敗しました。" & vbCrLf & strContent & vbCrLf, 64 , "処理の中止"
    WScript.Quit
End If

' 変換結果をファイルに出力
FileOut CurrentDir & OutFileName, strContent, ForWriting
MsgBox "変換処理が正常終了しました。" & vbCrLf & "結果を以下のファイルに出力しました。" & vbCrLf & CurrentDir & OutFileName, 64, "正常終了"

' 出力ファイルがhtmlの場合は結果を表示させる
If ((Right(OutFileName, 5) = ".html") Or (Right(OutFileName, 5) = ".HTML")) Then
    Set objIE = WScript.CreateObject("InternetExplorer.Application")
    objIE.navigate CurrentDir & OutFileName
    objIE.Visible = True
End If

Wscript.Quit

'###########################################################
'            XSLTを使ってファイルを変換する
'
' 参考URL http://www.microsoft.com/japan/msdn/officedev/officexp/odc_acc2xslt.asp#odc_acc2xslt_multiple
' XMLファイルxmlFileをスタイルシートStyleSheetを使って変換し、その結果を文字列形式で返す
Const RETURN_OK  = 0
Const RETURN_ERR = -1
Function transformFiles(xmlFile, StyleSheet, strResult)

Dim objXML      'XML データを保持するオブジェクト
  Dim objXSL      'スタイル シートを保持するオブジェクト

On Error Resume Next

'   データ ファイルとスタイル シート用の新しいドキュメント インスタンスを作成します。
      set objXML = CreateObject("MSXML2.DOMDocument.3.0")
      set objXSL = CreateObject("MSXML2.DOMDocument.3.0")

'  解析されたときにそのファイルが有効になるようにプロパティを設定します。
      objXML.validateOnParse = true
      objXSL.validateOnParse = true

'   ファイルを読み込みます。
      objXML.load(xmlFile)
      objXSL.load(StyleSheet)

'   すべてが OK であれば、変換を実行します。
      strResult = objXML.transformNode(objXSL)
      
  '   エラー処理を実装します。
      If Err.Number <> 0 Then
        strResult = Err.description
        transformFiles = RETURN_ERR
      Else
        transformFiles = RETURN_OK
      End if

End Function
'###########################################################

'###########################################################
'            ドロップダウンリストで項目を選択
' 関数名
'    SelectList
'
' 引数
'    ItemList：配列形式のVariant型
'              ドロップダウンリストに設定する項目を指定
'    Type    ：戻り値の型
'              TYPE_INDEX → 数値型のインデックス(0-origine)で返す
'                            キャンセル時は-1を返す
'              TYPE_STRING → 選択された項目の文字列を返す
'                             キャンセル時は"Cancel"を返す
'    Caption ：ダイアログに表示させる文字
'
' 戻り値
'    第2引数Typeに応じて変化
'    詳細は引数の説明を参照
'
' 制限事項
'    IE右上の×ボタンから画面を閉じた場合、エラーが発生
'

Dim RetVal
Dim ObjListIE
Const TYPE_INDEX    = 0
Const TYPE_STRING   = 1
Const STRING_CANCEL = "Cancel"
Const SELECT_WIDTH  = "350px"     ' (IE_WIDTH-50)程度
Const SELECT_MARGINBOTTOM = "10px"
Const IE_HEIGHT     = 150
Const IE_WIDTH      = 400
Const IE_LEFT       = 300
Const IE_TOP        = 300

Function SelectList(ItemList, RetType, Caption)

Dim ObjSelect, ObjLF, ObjButton1, ObjButton2, ObjOption, item, index
    
    ' キャンセル時の戻り値を設定
    RetVal = STRING_CANCEL
    
    ' IEオブジェクトを取得
    Set ObjListIE = WScript.CreateObject("InternetExplorer.Application")
    ObjListIE.Navigate "about:blank"
    
    ' 起動終了まで待機
    Do While(ObjListIE.Busy)
        WScript.Sleep 50
    Loop

' IEオブジェクトにテキストを追加
    ObjListIE.Document.Body.insertAdjacentText "afterBegin", Caption
    
    ' SELECTタグを作成
    Set ObjSelect = ObjListIE.Document.createElement ("select")
    ObjSelect.style.width = SELECT_WIDTH
    ObjSelect.style.marginBottom = SELECT_MARGINBOTTOM
    ObjListIE.Document.Body.insertBefore(ObjSelect)
    
    ' SELECTタグにOPTIONを追加
    index = 0
    For Each item In ItemList
        Set ObjOption = ObjListIE.Document.createElement("OPTION")
        ObjSelect.Options.Add ObjOption
        ObjOption.text = item
        ObjOption.Value = item
    Next
    
    ' SELECTタグに改行を追加
    Set ObjLF = ObjListIE.Document.createElement("BR")
    ObjListIE.Document.Body.insertBefore(ObjLF)
    
    ' Cancelボタンを追加
    Set ObjButton1 = ObjListIE.Document.createElement("button")
    ObjButton1.Value = "CANCEL"
    ObjButton1.style.styleFloat = "right"
    ObjListIE.Document.Body.insertBefore(ObjButton1)
    Set ObjButton1.onclick = GetRef("Click_Cancel")
    
    ' OKボタンを追加
    Set ObjButton2 = ObjListIE.Document.createElement("button")
    ObjButton2.Value = "OK"
    ObjButton2.style.styleFloat = "right"
    ObjListIE.Document.Body.insertBefore(ObjButton2)
    Set ObjButton2.onclick = GetRef("Click_OK")

' IEオブジェクトのステータスを設定
    With ObjListIE
        .height     = IE_HEIGHT
        .width      = IE_WIDTH
        .Left       = IE_LEFT
        .Top        = IE_TOP
        .AddressBar = false
        .MenuBar    = false
        .Resizable  = false
        .StatusBar  = false
        .ToolBar    = false
        .Visible    = true
    End With
    
    ObjListIE.Document.title = "ドロップダウン選択"

Do While(ObjListIE.Busy)
        WScript.Sleep 100
    Loop
    
    CreateObject("WScript.Shell").AppActivate "about:blank"

' ボタン押下まで待機
    Do While (ObjListIE.Visible)
        WScript.Sleep 100
    Loop

' OKボタンが押された場合は選択項目を返す
    If (RetVal = "OK") Then
        If (RetType = TYPE_INDEX) Then
            RetVal = ObjSelect.selectedIndex
        Else
            RetVal = ObjSelect.Value
        End If
    Else
        If (RetType = TYPE_INDEX) Then
            RetVal = -1
        Else
            RetVal = STRING_CANCEL
        End If
    End If

' IEオブジェクトを解放
    ObjListIE.Quit
    
    SelectList = RetVal

End Function

' OKボタン押下時
Function Click_OK
    RetVal = "OK"
    ObjListIE.Visible = false
End Function

' CANCELボタン押下時
Function Click_Cancel
    RetVal = "Cancel"
    ObjListIE.Visible = false
End Function

'###########################################################

'###########################################################
'           指定文字列を指定ファイルに書き込む
'
' FileName : 書き込むファイル名
'  Content : 書き込む内容
'   IOMode : 書き込みの種類
'            ForWriting   → 新規書き込み
'            ForAppending → 追加書き込み
'
' 戻り値：0 → 正常終了
'        -1 → ファイル名が不正
'        -2 → 書き込み内容が空
'        -3 → モードの指定が不正

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

Function FileOut(FileName, Content, IOMode)

'引数のチェック
    If (FileName = vbNullString) Then
        FileOut = -1
        Exit Function
    End If
    If (Content = vbNullString) Then
        FileOut = -2
        Exit Function
    End If
    If (IOMode <> ForWriting And IOMode <> ForAppending) Then
        FileOut = -3
        Exit Function
    End If
    
    Dim fso, f, ts
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    '入出力モードの確認
    If (IOMode = ForWriting) Then
        '新規モードの場合は新規にファイルを作成
        fso.CreateTextFile FileName
        Set f = fso.GetFile(FileName)
        Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)
        ts.Write Content
        ts.Close
    Else
        'アペンドモードの場合は追記書き込みでファイルを開く
        Set f = fso.OpenTextFile(FileName, ForAppending, True)
        f.Write Content
        f.Close
    End If
    
    FileOut = 0
End Function
'###########################################################