Dim strBreak,strInsertA,strInsertB,nCnt

' **********************************************************
' Object 作成
' **********************************************************
Set Stream = CreateObject( "ADODB.Stream" )
Set Stream2 = CreateObject( "ADODB.Stream" )
Set Fso = CreateObject( "Scripting.FileSystemObject" )
Set objXMLHttp = CreateObject("Msxml2.ServerXMLHTTP.3.0" )
Set objXML = CreateObject("Msxml2.DOMDocument.3.0")
Set Cn = CreateObject( "ADODB.Connection" )
Set Rs = CreateObject( "ADODB.Recordset" )
Set WshShell = CreateObject( "WScript.Shell" )

strTarget = WshShell.CurrentDirectory & "\" & "budget.mdb"

ConnectionString = _
	"Provider=Microsoft.Jet.OLEDB.4.0;" & _
	"Data Source=" & strTarget & ";"

on error resume next
Cn.Open ConnectionString
if Err.Number <> 0 then
	WScript.Echo Err.Description
	Wscript.Quit
end if
on error goto 0

Cn.Execute "delete from 初期"

strTargetUrl = "対象 URL"
strOut = ""

Set objHandle = Fso.OpenTextFile( "TargetList.txt", 1 )
Do While not objHandle.AtEndOfStream
	strBuffer = objHandle.ReadLine
	strBreak = ""
	Call CreateData( strBuffer )
Loop
objHandle.Close

Cn.Close

WScript.Echo "処理終了"

' **********************************************************
' XML データ作成
' **********************************************************
Function CreateData( strTargetName )

	strRequest = strTargetUrl & strTargetName & ".xml"

	Call objXMLHttp.Open( "GET", strRequest, False )
	objXMLHttp.Send


	' バイナリ保存
	Stream.Open
	Stream.Type = 1	' バイナリ
	Stream.Write objXMLHttp.responseBody
	Stream.SaveToFile "Shift_Jis_Page.txt", 2
	Stream.Close


	' 単純 XML に加工
	Set InObj = Fso.OpenTextFile( "Shift_Jis_Page.txt", 1 )
	Set OutObj = Fso.OpenTextFile( "Shift_Jis_Page2.txt", 2, True )

	nCnt = 0
	Do While not InObj.AtEndOfStream
		Buffer = InObj.ReadLine
		nCnt = nCnt + 1
		select Case nCnt
			Case 1
				OutObj.WriteLine _
				"<?xml version=""1.0"" encoding=""utf-8"" ?>"
			Case 2,3
			Case Else
				OutObj.WriteLine Buffer
		end Select
	Loop

	OutObj.Close
	InObj.Close


	' キャラクタセット変更
	Stream.Open
	Stream.Type = 2		' StreamTypeEnum の adTypeText
	Stream.Charset = "shift_jis"
	Stream.LoadFromFile "Shift_Jis_Page2.txt"
	Stream2.Open
	Stream2.Charset = "utf-8"
	Stream.CopyTo Stream2
	Stream2.SaveToFile strTargetName & ".xml", 2
	Stream2.Close
	Stream.Close


	objXML.load( strTargetName & ".xml" )

	' ルートノードコレクション
	Set objNodeList = objXML.getElementsByTagName("budget")
	strXPath = "body/table/data"
	Set objTarget = objNodeList.Item(0).selectNodes(strXPath)

	on error resume next
	Set objTarget2 = objTarget.Item(1).selectNodes("clm")
	if Err.Number <> 0 then
		MsgBox "対象ノードがありません"
		Exit Function
	end if
	on error goto 0

	For Each obj In objTarget2
		Set objXMLDOMNamedNodeMap = obj.Attributes
		Call InsertData( _
			objXMLDOMNamedNodeMap.getNamedItem("cid").value & "", _
			obj.nodeTypedValue & "" )
	Next
	strInsertA = strInsertA & ")"
	strInsertB = strInsertB & ")"
'	Wscript.Echo  strInsertA & strInsertB
	Cn.Execute strInsertA & strInsertB
	strBreak = ""

End Function

Function InsertData( strKey, strTargetData )

	Dim strData,aData


	if Trim ( strTargetData ) = "" then
		strTargetData = "0"
	end if

	strTargetData = Replace( strTargetData, ",", "" )
	strTargetData = Replace( strTargetData, "△ ", "-" )

	aData = Split( strKey, "-" )
	strData = aData(0) & aData(1)

	if strBreak = "" then
		nCnt = 1
		strInsertA = "insert into 初期 ("
		strInsertB = " values("
		strInsertA = strInsertA & "I" & nCnt
		strInsertB = strInsertB & "'" & strTargetData & "'"
	else
		if strBreak <> strData then

			strInsertA = strInsertA & ")"
			strInsertB = strInsertB & ")"

'			Wscript.Echo  strInsertA & strInsertB
			Cn.Execute strInsertA & strInsertB

			nCnt = 1
			strInsertA = "insert into 初期 ("
			strInsertB = " values("
			strInsertA = strInsertA & "I" & nCnt
			strInsertB = strInsertB & "'" & strTargetData & "'"
		else
			nCnt = nCnt + 1
			strInsertA = strInsertA & ",I" & nCnt
			strInsertB = strInsertB & ",'" & strTargetData & "'"
		end if
	end if

	strBreak = aData(0) & aData(1)

End Function