麻辣家族討論版版 - Powered by Discuz! Board

Sub GetWeatherInfo()
Dim oXmlhttp As Object: Set oXmlhttp = CreateObject("msxml2.xmlhttp")
Dim oHtmldoc As Object: Set oHtmldoc = CreateObject("htmlfile")
Dim oClip As Object: Set oClip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") 'DataObject
Dim sURL As String
sURL = "http://e-service.cwb.gov.tw/HistoryDataQuery/MonthDataController.do?command=viewMain&station=467410&datepicker=2016-01"
With oXmlhttp
.Open "Get", sURL, False
.Send
oHtmldoc.write .responseText
End With
Dim oTable As Object
Set oTable = oHtmldoc.GetElementById("MyTable")
If oTable Is Nothing Then MsgBox "擷取Table失敗...": Exit Sub
'remove top header row (press/temperature...)
oTable.FirstChild.RemoveChild oTable.FirstChild.ChildNodes(0)
'copy to clip board
With oClip
.SetText Replace(oTable.outerhtml, " ", "")
.PutInClipboard
End With
Sheets.Add().PasteSpecial NoHTMLFormatting:=True '不要含格式
End Sub

複製代碼

Sub 巨集1()
'
Cells.Delete
surl = "URL;" & "http://e-service.cwb.gov.tw/HistoryDataQuery/MonthDataController.do?command=viewMain&station=467410&datepicker=2015-01"
Set QT = ActiveSheet.QueryTables.Add(Connection:=surl, Destination:=Range("$A$1"))
With QT
.WebFormatting = xlWebFormattingNone
.Refresh BackgroundQuery:=False
.Delete
End With
Set QT = Nothing
End Sub

複製代碼

Option Explicit
Dim xObject()
Private Sub UserForm_Initialize()
xObject = Array(ComboBox1, ComboBox2, ComboBox3)
觀測查詢_設定
Com
ComboBox1.Value = ComboBox1.List(0)
ComboBox2.Value = ComboBox2.List(0)
End Sub
Private Sub ComboBox1_Change() '測　　站
Com
End Sub
Private Sub ComboBox2_Change() '資料格式
Dim i As Double
With ComboBox3
.Clear
Select Case ComboBox2.ListIndex
Case 0 '
For i = Date - 1 To DateAdd("Q", -1, Date) Step -1
.AddItem
.List(.ListCount - 1) = Format(i, "YYYY-MM-DD")
Next
Case 1
i = Date
Do
.AddItem
.List(.ListCount - 1) = Format(i, "YYYY-MM")
i = DateAdd("M", -1, i)
Loop Until Year(i) < Year(Date) - 1
Case 2
For i = Year(Date) To Year(Date) - 1 Step -1
.AddItem
.List(.ListCount - 1) = i
Next
End Select
If ComboBox2.ListIndex > -1 Then .Value = .List(0)
End With
Com
End Sub
Private Sub ComboBox3_Change() '時　　間
Com
End Sub
Private Sub Com() '
Dim E As Variant
With CommandButton1
.Enabled = True
For Each E In xObject
If E.ListIndex = -1 Then .Enabled = False '按紐(觀測資料查詢):不可用
Next
End With
End Sub
Private Sub CommandButton1_Click() '按紐(觀測資料查詢)
Dim surl As String, QT As QueryTable
'http://e-service.cwb.gov.tw/HistoryDataQuery/YearDataController.do?command=viewMain&station=467410&datepicker=2016
'http://e-service.cwb.gov.tw/HistoryDataQuery/MonthDataController.do?"
'http://e-service.cwb.gov.tw/HistoryDataQuery/DayDataController.do?
surl = "URL; http://e-service.cwb.gov.tw/HistoryDataQuery/"
Select Case ComboBox2.ListIndex
Case 0
surl = surl & "DayDataController.do?"
Case 1
surl = surl & "MonthDataController.do?"
Case 2
surl = surl & "YearDataController.do?"
End Select
surl = surl & "command=viewMain&station=" & ComboBox1.List(ComboBox1.ListIndex, 1)
surl = surl & "&datepicker=" & ComboBox3
With ActiveSheet
.Cells.Delete
Set QT = .QueryTables.Add(Connection:=surl, Destination:=.Range("$A$1"))
With QT
.WebFormatting = xlWebFormattingNone
.Refresh BackgroundQuery:=False
.Delete
End With
End With
Set QT = Nothing
End Sub
Private Sub 觀測查詢_設定()
Dim i As Double, E As Object, op As Object
Dim oXmlhttp As Object, oHtmldoc As Object, Url As String
Set oXmlhttp = CreateObject("msxml2.xmlhttp")
Set oHtmldoc = CreateObject("htmlfile")
Url = "http://e-service.cwb.gov.tw/HistoryDataQuery/QueryDataController.do?command=viewMain" '
With oXmlhttp
.Open "Get", Url, False
.Send
oHtmldoc.write .responseText
End With
With oHtmldoc
Set E = .all.tags("SELECT")(0)
Set op = .all.tags("option")
End With
For i = 0 To op.Length - 1
If i <= E.Length - 1 Then
With ComboBox1
.AddItem
.List(.ListCount - 1, 0) = op(i).innertext '測站:名稱
.List(.ListCount - 1, 1) = op(i).Value '測站:數值
End With
Else
With ComboBox2
.AddItem
.List(.ListCount - 1, 0) = op(i).innertext '資料格式:名稱
End With
End If
Next
End Sub

複製代碼

Option Explicit
Dim Sh(1 To 2) As Worksheet
Private Sub UserForm_Initialize()
Set Sh(1) = Sheets.Add '設定新增工作表
Sh(1).Visible = False '隱藏工作表
觀測查詢_設定
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.DisplayAlerts = False
Sh(1).Delete
Application.DisplayAlerts = True
End Sub
Private Sub 觀測查詢_設定()
Dim Url As String, i As Double, op As Object, xDate As Date
Dim oHtmldoc As Object
Set oHtmldoc = CreateObject("htmlfile")
Url = "http://e-service.cwb.gov.tw/HistoryDataQuery/QueryDataController.do?command=viewMain" '
With CreateObject("msxml2.xmlhttp")
.Open "Get", Url, False
.Send
oHtmldoc.write .responseText
End With
With ComboBox1
For Each op In oHtmldoc.all.tags("SELECT")(0)
.AddItem
.List(.ListCount - 1, 0) = op.innertext '測站:名稱
.List(.ListCount - 1, 1) = op.Value '測站:數值
Next
.ListIndex = 0
End With
With ComboBox2
For i = 0 To -59 Step -1 '60個月份
xDate = DateAdd("M", i, Date)
.AddItem
.List(.ListCount - 1, 0) = Format(xDate, "EE年MM月")
.List(.ListCount - 1, 1) = DateSerial(Year(xDate), Month(xDate), 1)
Next
.ListIndex = 0
End With
End Sub
Private Sub CommandButton1_Click() '按紐(資料查詢)
Dim surl As String, QT As Range, Qdate As Date, Station As String, Msg As Boolean
'http://e-service.cwb.gov.tw/HistoryDataQuery/DayDataController.do?
surl = "URL;http://e-service.cwb.gov.tw/HistoryDataQuery/DayDataController.do?"
surl = surl & "command=viewMain&station=" & ComboBox1.List(ComboBox1.ListIndex, 1)
Station = ComboBox1.List(ComboBox1.ListIndex, 0) & "(" & ComboBox1.List(ComboBox1.ListIndex, 1) & ")" '工作表名稱
On Error GoTo Make_station: '處裡錯誤: 測站不存在
Set Sh(2) = Sheets(Station) '指定工作表(測站)
On Error GoTo 0 '有錯誤不處理了
Application.ScreenUpdating = False
For Qdate = ComboBox2.List(ComboBox2.ListIndex, 1) To DateAdd("m", 1, ComboBox2.List(ComboBox2.ListIndex, 1)) - 1
surl = "URL;http://e-service.cwb.gov.tw/HistoryDataQuery/DayDataController.do?command=viewMain&station=" & ComboBox1.List(ComboBox1.ListIndex, 1) & "&datepicker=" & Format(Qdate, "yyyy-m-dd")
If Qdate > Date Then Exit For '日期大於當日
If Not Sh(2).Range("A:A").Find(Qdate, LookIn:=xlFormulas) Is Nothing Then GoTo Ne '日期資料已存在,下一日期迴圈
Application.StatusBar = "匯入 " & Qdate & " 資料..." '狀態列的文字
With Sh(1)
.UsedRange.Delete
With .QueryTables.Add(Connection:=surl, Destination:=.Range("$A$1"))
.WebTables = "MyTable"
.WebFormatting = xlWebFormattingNone
.Refresh BackgroundQuery:=False
If .ResultRange.Rows.Count > 5 Then '有資料
Set QT = .ResultRange '含表頭的資料範圍
With Sh(2)
If .UsedRange.Count = 1 Then '工作表(測站)為空白
.Range("A1") = "觀測時間"
.Range("A1").Resize(5).Merge
Else
Set QT = QT.Rows("6:" & QT.Rows.Count) '不含表頭的資料
End If
With .Cells(Rows.Count, "b").End(xlUp)
If .Row = 1 Then '工作表(測站)為空白
QT.Copy .Cells
Else '.Row = 4 ->沒有資料但有表頭
QT.Copy .Cells(IIf(.Row = 4, 3, 2))
End If
End With
With .Range(.Cells(Rows.Count, "A").End(xlUp).Offset(1).Address & ":A" & Sh(2).Cells(Rows.Count, "B").End(xlUp).Row)
.Cells = Qdate 'A欄寫上日期
.NumberFormatLocal = "yyyy-mm-dd" '給予格式
End With
End With
End If
.Delete
End With
End With
Ne:
Next
Application.StatusBar = False
Application.ScreenUpdating = True
'排序
With Sh(2).UsedRange.Offset(5)
.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("B1"), Order2:=xlAscending, Header:=xlNo
End With
Exit Sub
Make_station:
Sheets.Add(Sheet1).Name = Station '新增工作表(測站)
Resume '回到錯誤的程式碼繼續程式
End Sub

複製代碼

Private Sub CommandButton1_Click() '按紐(資料查詢)
Dim surl As String, QT As Range, Qdate As Date, Station As String, Msg As Boolean
surl = "URL;http://e-service.cwb.gov.tw/HistoryDataQuery/DayDataController.do?"
Stop
MsgBox ComboBox1
MsgBox ComboBox1.List(Me.ComboBox1.ListIndex, 1) '加上ME是否可修正錯誤
MsgBox ComboBox1.List(ComboBox1.ListIndex, 1)

複製代碼