返回列表 上一主題 發帖

[發問] 請問如何抓取氣象局opendata xml 問題

回復 5# c_c_lai

謝謝你的測試,2003可空一格。
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

本帖最後由 c_c_lai 於 2016-1-9 18:34 編輯

回復 4# GBKEE
經測試發現:
「Private Sub CommandButton1_Click()     '  按紐(觀測資料查詢)」

    surl = "URL; http://e-service.cwb.gov.tw/HistoryDataQuery/"
要修正為:
    surl = "URL;http://e-service.cwb.gov.tw/HistoryDataQuery/"

"URL;" 與 "http://" 間不能存在空格 (Space),否則執行時,會產生如下的錯誤訊息:

「無法開啟 "URL; http://e-service.cwb.gov.tw/Hist ... tepicker=2016-01-08"
。無法連接網際網路伺服器。」

您模組的組合,其彈性與選擇性充分地表達出來,謝謝您!

TOP

本帖最後由 GBKEE 於 2016-1-9 15:36 編輯

回復 2# stillfish00
回復 3# joey0415
綜合2位,使用表單呈現,可選擇地區,資料格式,時間. 匯入所要的氣象資料.

新增 UserForm(表單) 中加入ComboBox1, ComboBox2, ComboBox3 ,CommandButton1
  1. Option Explicit
  2. Dim xObject()
  3. Private Sub UserForm_Initialize()
  4.     xObject = Array(ComboBox1, ComboBox2, ComboBox3)
  5.     觀測查詢_設定
  6.      Com
  7.      ComboBox1.Value = ComboBox1.List(0)
  8.      ComboBox2.Value = ComboBox2.List(0)
  9. End Sub
  10. Private Sub ComboBox1_Change() '測  站
  11.      Com
  12. End Sub
  13. Private Sub ComboBox2_Change() '資料格式
  14.     Dim i  As Double
  15.     With ComboBox3
  16.         .Clear
  17.         Select Case ComboBox2.ListIndex
  18.             Case 0 '
  19.                 For i = Date - 1 To DateAdd("Q", -1, Date) Step -1
  20.                     .AddItem
  21.                     .List(.ListCount - 1) = Format(i, "YYYY-MM-DD")
  22.                 Next
  23.             Case 1
  24.                 i = Date
  25.                 Do
  26.                     .AddItem
  27.                     .List(.ListCount - 1) = Format(i, "YYYY-MM")
  28.                     i = DateAdd("M", -1, i)
  29.                 Loop Until Year(i) < Year(Date) - 1
  30.             Case 2
  31.                 For i = Year(Date) To Year(Date) - 1 Step -1
  32.                     .AddItem
  33.                     .List(.ListCount - 1) = i
  34.                 Next
  35.         End Select
  36.         If ComboBox2.ListIndex > -1 Then .Value = .List(0)
  37.     End With
  38.     Com
  39. End Sub
  40. Private Sub ComboBox3_Change()  '時  間
  41.     Com
  42. End Sub
  43. Private Sub Com() '
  44.     Dim E As Variant
  45.     With CommandButton1
  46.         .Enabled = True
  47.         For Each E In xObject
  48.             If E.ListIndex = -1 Then .Enabled = False '按紐(觀測資料查詢):不可用
  49.         Next
  50.     End With
  51. End Sub
  52. Private Sub CommandButton1_Click() '按紐(觀測資料查詢)
  53.      Dim surl As String, QT As QueryTable
  54.     'http://e-service.cwb.gov.tw/HistoryDataQuery/YearDataController.do?command=viewMain&station=467410&datepicker=2016
  55.     'http://e-service.cwb.gov.tw/HistoryDataQuery/MonthDataController.do?"
  56.     'http://e-service.cwb.gov.tw/HistoryDataQuery/DayDataController.do?
  57.     surl = "URL; http://e-service.cwb.gov.tw/HistoryDataQuery/"
  58.     Select Case ComboBox2.ListIndex
  59.         Case 0
  60.             surl = surl & "DayDataController.do?"
  61.         Case 1
  62.             surl = surl & "MonthDataController.do?"
  63.         Case 2
  64.             surl = surl & "YearDataController.do?"
  65.     End Select
  66.     surl = surl & "command=viewMain&station=" & ComboBox1.List(ComboBox1.ListIndex, 1)
  67.     surl = surl & "&datepicker=" & ComboBox3
  68.     With ActiveSheet
  69.         .Cells.Delete
  70.         Set QT = .QueryTables.Add(Connection:=surl, Destination:=.Range("$A$1"))
  71.         With QT
  72.             .WebFormatting = xlWebFormattingNone
  73.             .Refresh BackgroundQuery:=False
  74.             .Delete
  75.         End With
  76.     End With
  77.     Set QT = Nothing
  78. End Sub
  79. Private Sub 觀測查詢_設定()
  80.     Dim i As Double, E As Object, op As Object
  81.     Dim oXmlhttp As Object, oHtmldoc As Object, Url As String
  82.     Set oXmlhttp = CreateObject("msxml2.xmlhttp")
  83.     Set oHtmldoc = CreateObject("htmlfile")
  84.     Url = "http://e-service.cwb.gov.tw/HistoryDataQuery/QueryDataController.do?command=viewMain"   '
  85.     With oXmlhttp
  86.         .Open "Get", Url, False
  87.         .Send
  88.         oHtmldoc.write .responseText
  89.     End With
  90.     With oHtmldoc
  91.         Set E = .all.tags("SELECT")(0)
  92.         Set op = .all.tags("option")
  93.     End With
  94.     For i = 0 To op.Length - 1
  95.         If i <= E.Length - 1 Then
  96.             With ComboBox1
  97.                 .AddItem
  98.                 .List(.ListCount - 1, 0) = op(i).innertext  '測站:名稱
  99.                 .List(.ListCount - 1, 1) = op(i).Value      '測站:數值
  100.             End With
  101.         Else
  102.             With ComboBox2
  103.                 .AddItem
  104.                 .List(.ListCount - 1, 0) = op(i).innertext  '資料格式:名稱
  105.             End With
  106.         End If
  107.     Next
  108. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 1# yehmengfeng
變數自己改改看!
  1. Sub 巨集1()
  2. '
  3.     Cells.Delete

  4.     surl = "URL;" & "http://e-service.cwb.gov.tw/HistoryDataQuery/MonthDataController.do?command=viewMain&station=467410&datepicker=2015-01"
  5.    
  6.     Set QT = ActiveSheet.QueryTables.Add(Connection:=surl, Destination:=Range("$A$1"))
  7.    
  8.     With QT
  9.         .WebFormatting = xlWebFormattingNone
  10.         .Refresh BackgroundQuery:=False
  11.         .Delete
  12.     End With
  13.    
  14.     Set QT = Nothing
  15. End Sub
複製代碼

TOP

回復 1# yehmengfeng
參考看看
  1. Sub GetWeatherInfo()
  2.     Dim oXmlhttp As Object: Set oXmlhttp = CreateObject("msxml2.xmlhttp")
  3.     Dim oHtmldoc As Object: Set oHtmldoc = CreateObject("htmlfile")
  4.     Dim oClip As Object: Set oClip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") 'DataObject
  5.     Dim sURL As String
  6.    
  7.     sURL = "http://e-service.cwb.gov.tw/HistoryDataQuery/MonthDataController.do?command=viewMain&station=467410&datepicker=2016-01"
  8.     With oXmlhttp
  9.         .Open "Get", sURL, False
  10.         .Send
  11.         oHtmldoc.write .responseText
  12.     End With
  13.    
  14.     Dim oTable As Object
  15.     Set oTable = oHtmldoc.GetElementById("MyTable")
  16.     If oTable Is Nothing Then MsgBox "擷取Table失敗...": Exit Sub
  17.    
  18.     'remove top header row (press/temperature...)
  19.     oTable.FirstChild.RemoveChild oTable.FirstChild.ChildNodes(0)
  20.    
  21.     'copy to clip board
  22.     With oClip
  23.         .SetText Replace(oTable.outerhtml, "&nbsp;", "")
  24.         .PutInClipboard
  25.     End With
  26.    
  27.     Sheets.Add().PasteSpecial NoHTMLFormatting:=True    '不要含格式
  28. End Sub
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

        靜思自在 : 待人退一步,愛人寬一寸,就會活得很快樂。
返回列表 上一主題