Private Const DATE_CELL_ADDRESS As String = "B1"
Private Const TIME_CELL_ADDRESS As String = "B2"
Private Const P_CELL_ADDRESS As String = "D1"
Private Const B0_CELL_ADDRESS As String = "D2"
Private Const L0_CELL_ADDRESS As String = "D3"
Sub Parse()
Dim data As Object
Set data = downloadPB0L0(Range(DATE_CELL_ADDRESS), Range(TIME_CELL_ADDRESS))
getChild data.ChildNodes, getHMS(Range(TIME_CELL_ADDRESS)), False, 0
End Sub
'子ノード取得
Function getChild(Node As Object, cmpTime As String, isOut As Boolean, outCount As Integer)
Dim obj As Object
For Each obj In Node
If obj.ParentNode.nodeName = "td" And isOut Then
Select Case outCount
Case 0:
Range(P_CELL_ADDRESS).Value = obj.NodeValue
Case 1:
Range(B0_CELL_ADDRESS).Value = obj.NodeValue
Case 2:
Range(L0_CELL_ADDRESS).Value = obj.NodeValue
End Select
outCount = outCount + 1
End If
If obj.ParentNode.nodeName = "td" And Trim(obj.NodeValue) = cmpTime Then isOut = True
If obj.HasChildNodes Then
getChild obj.ChildNodes, cmpTime, isOut, outCount
End If
Next
End Function
'年取得
Function getYear(r As Range) As Integer
getYear = Year(r.Value)
End Function
'月取得
Function getMonth(r As Range) As Integer
getMonth = Month(r.Value)
End Function
'日取得
Function getDay(r As Range) As Integer
getDay = Day(r.Value)
End Function
'時取得
Function getHour(r As Range) As Integer
getHour = Hour(r.Value)
End Function
'分取得
Function getMin(r As Range) As Integer
getMin = Minute(r.Value)
End Function
'秒取得
Function getSec(r As Range) As Integer
getSec = Second(r.Value)
End Function
'時分秒取得
Function getHMS(r As Range) As String
getHMS = getHour(r) & ":" & Format(getMin(r), "00") & ":" & Format(getSec(r), "00")
End Function
'パラメータ作成
Function getParams(dayRange As Range, timeRange As Range) As String
Dim ret As String
ret = "year=" & getYear(dayRange)
ret = ret & "&month=" & getMonth(dayRange)
ret = ret & "&day=" & getDay(dayRange)
ret = ret & "&hour=" & getHour(timeRange)
ret = ret & "&min=" & getMin(timeRange)
ret = ret & "&sec=" & getSec(timeRange)
ret = ret & "&tsys=0"
getParams = ret
End Function
'P B0 L0 ダウンロード
Function downloadPB0L0(dayRange As Range, timeRange As Range) As Object
Dim obj As Object
Dim retobj As Object
Dim bParams() As Byte
Set obj = CreateObject("MSXML2.XMLHTTP")
Set retobj = CreateObject("MSXML2.DOMDocument")
obj.Open "POST", "http://e...content-available-to-author-only...c.jp/cgi-bin/koyomi/cande/sun_spin.cgi", False
obj.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
bParams = StrConv(getParams(dayRange, timeRange), vbFromUnicode)
obj.Send (bParams)
If obj.Status <> 200 Then
MsgBox "Connection Error"
Exit Function
End If
retobj.LoadXML (obj.responseText)
Set downloadPB0L0 = retobj
End Function