復旧・復興支援制度の全概要をCSVファイルに出力するVBScript（暫定版）#hack4jp

震災復興を継続的に支援するためのIT開発を支えるコミュニティ「Hack for Japan」が次のイベントを本日、開催しました。
Hack For Japan: 復旧 復興支援データベースAPI ハッカソン開催のお知らせ
私も何か手伝えないかな？と思って、復旧・復興支援制度データベースAPI（ http://www.r-assistance.go.jp/about_api.aspx ）を使用したサンプルを作ってみました。*1

• このサンプルは、復旧・復興支援制度の全概要を取得し、CSVファイルに出力するVBScriptです。
• 以下のコードを『GetSummaries2Csv.vbs』というファイル名をつけて保存し、コマンドプロンプトから『cscript //nologo GetSummaries2Csv.vbs』と入力して実行してください。
• 『GetSummaries2Csv.vbs』が存在するフォルダに、全制度のIDが記述されたXMLファイルと、全概要が記述されたXMLファイルと、CSVファイル『SupportSummaries.csv』が出力されます。
  • 出力されたCSVファイルは、Excelで開くときに警告は出ますが正常に表示されるはずです。
  • 地方公共団体コードを地方公共団体名称に変換する処理は入っていません。すみません。

(2012/06/15追記)
完成版は 復旧・復興支援制度の全概要をCSVファイルに出力するVBScript（完成版） - 鎌玉 大のよしなしごと を参照。

Option Explicit
' ===========================================================
' GetSummaries2Csv.vbs
' 復旧・復興支援制度データベースの全制度の概要をCSVファイルに出力する
' ===========================================================
'************************************************************
'定数
'************************************************************
'' 保存先のCSVファイル名
Const CSV_FILE_NAME = "SupportSummaries.csv"

'' 制度情報の複数IDを取得するURL
Const INFORMATIONS_URL = "http://api.r-assistance.go.jp/v1/api.svc/searchSupportInformations?appkey=0&maxcount=100&pageno="
'' 制度情報の複数IDが記述されたXMLファイルにつける接頭辞
Const INFORMATIONS_FILE_PREFIX = "SupportInformations_"

'' 制度情報の概要を取得するURL
Const SUMMARIES_URL = "http://api.r-assistance.go.jp/v1/api.svc/getSupportInformationSummaries?appkey=0&ids="
'' 制度情報の概要が記述されたXMLファイルにつける接頭辞
Const SUMMARIES_FILE_PREFIX = "SupportSummaries_"

'' 制度詳細情報のURL
Const DETAIL_URL = "http://www.r-assistance.go.jp/contentdetail_k.aspx?ContentID="

'************************************************************

Dim oXMLHTTP   ' XMLHTTPオブジェクト
Dim objXML     ' XMLオブジェクト
Dim objFSO     ' ファイルシステムオブジェクト

Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.3.0")
Set objXML   = CreateObject("MSXML2.DOMDocument")
Set objFSO   = WScript.CreateObject("Scripting.FileSystemObject")

Call Main()
WScript.Echo "終了しました"

Set oXMLHTTP = Nothing
Set objXML   = Nothing
Set objFSO   = Nothing

'************************************************************
' メイン処理
'************************************************************
Sub Main()
	Dim oCsvFile       ' CSVファイル
	Dim csvTextStream  ' CSVファイルの出力ストリーム

	Dim infosCount     ' 制度情報のIDが記述されたXMLの数
	Dim infosFileName  ' 制度情報のIDが記述されたXMLのファイル名
	Dim summariesFileName  ' 制度情報の概要が記述されたXMLのファイル名

	Dim i
	Dim ids

	' 既存のCSVファイルが存在すれば、削除
	if objFSO.FileExists(CSV_FILE_NAME) Then
		objFSO.DeleteFile CSV_FILE_NAME
	End if

	' CSVファイルを作成
	objFSO.CreateTextFile CSV_FILE_NAME
	Set oCsvFile = objFSO.GetFile(CSV_FILE_NAME)
	' 8:追記モード, -2:システムデフォルト文字コード SJISで
	Set csvTextStream = oCsvFile.OpenAsTextStream(8, -2)
	csvTextStream.WriteLine("ID,制度のタイトル,お問い合わせ先,対象地域,概要,詳細情報URL")

	' 制度情報のIDが記述されたXMLをローカルに保存
	infosCount = GetSupportInformations()

	If infosCount = 0 Then
		WScript.Echo "制度情報のIDの取得に失敗しました"
	Else
		For i = 1 To infosCount
			infosFileName = INFORMATIONS_FILE_PREFIX & i & ".xml"
			summariesFileName = SUMMARIES_FILE_PREFIX & i & ".xml"

			' 制度情報のIDが記述されたXMLから、ID部分を取得
			ids = ReadXmlTag(infosFileName, "IDs")
			' カンマ区切りをパイプ区切りに変換
			ids = Replace(ids, ",", "|")

			' 制度情報の概要が記述されたXMLをローカルに保存
			If GetSupportSummaries(ids, summariesFileName) = 0 Then
				' CSVファイルに出力
				Call ConvertSummaries2Csv(summariesFileName, csvTextStream)
			Else
				WScript.Echo "制度情報の概要の取得に失敗しました"
				Exit For
			End If
		Next
	End If

	csvTextStream.Close()
	Set csvTextStream = Nothing
	Set oCsvFile = Nothing
End Sub

'************************************************************
'関数ID          ：GetSupportSummaries
'説明            ：制度情報の概要が記述されたXMLをローカルに保存する
'引数            ：ids … 対象となる制度のID、パイプ区切り、最大100個
'引数            ：saveFileName … 保存ファイル名
'戻り値          ：実行結果 0:成功 -1:失敗
'************************************************************
Function GetSupportSummaries(ids, saveFileName)
	Dim targetUrl

	GetSupportSummaries = -1

	targetUrl = SUMMARIES_URL & ids

	If SaveResponse(targetUrl, saveFileName) = 0 Then
		GetSupportSummaries = 0
	End If
End Function

'************************************************************
'関数ID          ：getSupportInformations
'説明            ：制度情報の複数IDが記述されたXMLをローカルに保存する
'引数            ：なし
'戻り値          ：XMLファイルのファイル数
'                ：記述されていないものはカウントしない
'************************************************************
Function GetSupportInformations()
	Dim pageNo
	Dim targetUrl
	Dim saveFileName
	Dim resData

	pageNo = 1
	Do
		targetUrl = INFORMATIONS_URL & pageNo
		saveFileName = INFORMATIONS_FILE_PREFIX & pageNo & ".xml"

		If -1 = SaveResponse(targetUrl, saveFileName) Then
			Exit Do
		End If

		resData = ReadTextAll(saveFileName)

		' IDが記述されていないことを判定 (簡易判定)
		If InStr(resData, "<IDs/>") > 0 Then
			Exit Do
		End If

		pageNo = pageNo + 1
	LOOP

	GetSupportInformations = pageNo - 1
End Function

'************************************************************
'関数ID          ：ReadXmlTag
'説明            ：指定されたXMLファイルの指定タグの情報を返す
'引数            ：xmlFile … XMLファイル名
'引数            ：tagName … タグ名
'戻り値          ：指定タグの情報
'************************************************************
Function ReadXmlTag(xmlFile, tagName)
	Dim nodeRoot
	Dim nodeItems
	Dim nodeItem
	Dim result

	'非同期
	objXml.async=False
	' XMLファイルの読み込み
	result = objXml.Load(xmlFile)
	If Not result Then
		WScript.Echo objXml.parseError.errorCode
		WScript.Echo objXml.parseError.reason
		Exit Function
	End If

	Set nodeRoot = objXml.documentElement
	Set nodeItems = nodeRoot.getElementsByTagName(tagName)

	ReadXmlTag = nodeItems.Item(0).Text
End Function

'************************************************************
'関数ID          ：ConvertSummaries2Csv
'説明            ：制度情報の概要のXMLファイルをCSVファイルに保存
'引数            ：xmlFile … XMLファイル名
'引数            ：csvTextStream … CSVファイルの出力ストリーム
'戻り値          ：なし
'************************************************************
Sub ConvertSummaries2Csv(xmlFile, csvTextStream)
	Dim result
	Dim nodeRoot
	Dim nodeItems
	Dim nodeItem
	Dim id
	Dim title
	Dim contact
	Dim intentArea
	Dim summary
	Dim lineData ' 書き込む行データ

	'非同期
	objXml.async=False
	' XMLファイルの読み込み
	result = objXml.Load(xmlFile)
	If Not result Then
		WScript.Echo objXml.parseError.errorCode
		WScript.Echo objXml.parseError.reason
		Exit Sub
	End If

	Set nodeRoot = objXml.documentElement
	' SupportInformationSummaryタグのリストを取得
	Set nodeItems = nodeRoot.getElementsByTagName("SupportInformationSummary")

	' SupportInformationSummaryタグを1つずつ取り出す。
	For Each nodeItem In nodeItems
		id = nodeItem.getAttribute("ID")
		title = nodeItem.getElementsByTagName("Title").Item(0).Text
		contact = nodeItem.getElementsByTagName("Contact").Item(0).Text
		intentArea = nodeItem.getElementsByTagName("IntendedArea").Item(0).Text
		summary = nodeItem.getElementsByTagName("Summary").Item(0).Text

		' TODO: 対象地域 地方公共団体コードを名称に直す
		' 【暫定措置】
		' Excelで "10000,11000" という文字列は数字と認識されるので、カンマ区切りをパイプ区切りに変換
		' 前0が削除されないように先頭にパイプをつける
		intentArea = "|" & Replace(intentArea, ",", "|")

		lineData = id & ",""" & title & """,""" & contact & """,""" & intentArea & """,""" & summary & """," & DETAIL_URL & id
		csvTextStream.WriteLine(lineData)
	Next
End Sub

' ===========================================================
' 共通処理
' ===========================================================
'************************************************************
'関数ID          ：SaveResponse
'説明            ：指定されたURLの取得内容をファイルに保存する
'引数            ：url      … 取得先URL
'引数            ：filePath … ファイルパス
'戻り値          ：実行結果 0:成功 -1:失敗
'************************************************************
Function SaveResponse(url, filePath)
	Dim objAdodbStream    ' ADODB.Streamオブジェクト

	SaveResponse = -1

	' 既存のファイルを削除
	if g_objFSO.FileExists(filePath) Then
		g_objFSO.DeleteFile filePath
	End if

	' 同期処理
	g_objXMLHTTP.Open "GET", url, False
	g_objXMLHTTP.Send

	If g_objXMLHTTP.Status = 200 Then
		Set objAdodbStream = CreateObject("ADODB.Stream")
		objAdodbStream.Open
		objAdodbStream.Type = 1
		objAdodbStream.Write g_objXMLHTTP.responseBody
		objAdodbStream.SaveToFile filePath
		objAdodbStream.Close
		Set objAdodbStream = Nothing
		SaveResponse = 0
	Else
		WScript.Echo "Error returnCode:" & g_objXMLHTTP.Status
	End If
End Function

'************************************************************
'関数ID          ：ReadTextAll
'説明            ：テキストファイルの内容をすべて読み込みます
'引数            ：filePath ･･･ テキストファイルパス
'戻り値          ：ファイルの内容のテキスト
'************************************************************
Function ReadTextAll(filePath)
	Dim objTextStream  ' テキストストリームオブジェクト
	Dim resData        ' テキスト内容
	
	Set objTextStream = g_objFSO.OpenTextFile(filePath, 1)
	resData = objTextStream.ReadAll

	objTextStream.Close
	Set objTextStream = Nothing
	ReadTextAll = resData
End Function

• 参考にしたWebサイト)
  • MSDN : VBScript ランゲージ リファレンス VBScript ランゲージ リファレンス
  • 猫にWeb VBSでHTTPリクエストを投げて、レスポンスを受け取る - 猫にWeb

*1:サンプルだから、昨日公開したかったのですが…