fork download
copy 
  1. Private Const DATE_CELL_ADDRESS As String = "B1"
  2. Private Const TIME_CELL_ADDRESS As String = "B2"
  3. Private Const P_CELL_ADDRESS As String = "D1"
  4. Private Const B0_CELL_ADDRESS As String = "D2"
  5. Private Const L0_CELL_ADDRESS As String = "D3"
  6.  
  7. Sub Parse()
  8.     Dim data As Object
  9.  
  10.     Set data = downloadPB0L0(Range(DATE_CELL_ADDRESS), Range(TIME_CELL_ADDRESS))
  11.     getChild data.ChildNodes, getHMS(Range(TIME_CELL_ADDRESS)), False, 0
  12.  
  13. End Sub
  14.  
  15. '子ノード取得
  16. Function getChild(Node As Object, cmpTime As String, isOut As Boolean, outCount As Integer)
  17.     Dim obj As Object
  18.  
  19.     For Each obj In Node
  20.  
  21.         If obj.ParentNode.nodeName = "td" And isOut Then
  22.             Select Case outCount
  23.             Case 0:
  24.                 Range(P_CELL_ADDRESS).Value = obj.NodeValue
  25.             Case 1:
  26.                 Range(B0_CELL_ADDRESS).Value = obj.NodeValue
  27.             Case 2:
  28.                 Range(L0_CELL_ADDRESS).Value = obj.NodeValue
  29.             End Select
  30.             outCount = outCount + 1
  31.         End If
  32.         If obj.ParentNode.nodeName = "td" And Trim(obj.NodeValue) = cmpTime Then isOut = True
  33.  
  34.         If obj.HasChildNodes Then
  35.             getChild obj.ChildNodes, cmpTime, isOut, outCount
  36.         End If
  37.     Next
  38. End Function
  39.  
  40. '年取得
  41. Function getYear(r As Range) As Integer
  42.     getYear = Year(r.Value)
  43. End Function
  44.  
  45. '月取得
  46. Function getMonth(r As Range) As Integer
  47.     getMonth = Month(r.Value)
  48. End Function
  49.  
  50. '日取得
  51. Function getDay(r As Range) As Integer
  52.     getDay = Day(r.Value)
  53. End Function
  54.  
  55. '時取得
  56. Function getHour(r As Range) As Integer
  57.     getHour = Hour(r.Value)
  58. End Function
  59.  
  60. '分取得
  61. Function getMin(r As Range) As Integer
  62.     getMin = Minute(r.Value)
  63. End Function
  64.  
  65. '秒取得
  66. Function getSec(r As Range) As Integer
  67.     getSec = Second(r.Value)
  68. End Function
  69.  
  70. '時分秒取得
  71. Function getHMS(r As Range) As String
  72.     getHMS = getHour(r) & ":" & Format(getMin(r), "00") & ":" & Format(getSec(r), "00")
  73. End Function
  74.  
  75. 'パラメータ作成
  76. Function getParams(dayRange As Range, timeRange As Range) As String
  77.     Dim ret As String
  78.  
  79.     ret = "year=" & getYear(dayRange)
  80.     ret = ret & "&month=" & getMonth(dayRange)
  81.     ret = ret & "&day=" & getDay(dayRange)
  82.     ret = ret & "&hour=" & getHour(timeRange)
  83.     ret = ret & "&min=" & getMin(timeRange)
  84.     ret = ret & "&sec=" & getSec(timeRange)
  85.     ret = ret & "&tsys=0"
  86.     getParams = ret
  87. End Function
  88.  
  89. 'P B0 L0 ダウンロード
  90. Function downloadPB0L0(dayRange As Range, timeRange As Range) As Object
  91.     Dim obj As Object
  92.     Dim retobj As Object
  93.     Dim bParams() As Byte
  94.  
  95.     Set obj = CreateObject("MSXML2.XMLHTTP")
  96.     Set retobj = CreateObject("MSXML2.DOMDocument")
  97.  
  98.     obj.Open "POST", "http://e...content-available-to-author-only...c.jp/cgi-bin/koyomi/cande/sun_spin.cgi", False
  99.     obj.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  100.     bParams = StrConv(getParams(dayRange, timeRange), vbFromUnicode)
  101.     obj.Send (bParams)
  102.  
  103.     If obj.Status <> 200 Then
  104.         MsgBox "Connection Error"
  105.         Exit Function
  106.     End If
  107.  
  108.     retobj.LoadXML (obj.responseText)
  109.     Set downloadPB0L0 = retobj
  110.  
  111. End Function
  112.  
  113.  
  114.  
Not running #stdin #stdout 0s 0KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/Ughvu7
language:
Text (text 6.10)
created:
11 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!