網頁查詢問題

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2016-2-23 15:35 | 顯示全部帖子

回復 1# sillykin
試試看

Option Explicit
Sub Ex_土地段名代碼查詢系統()
Dim i As Integer, E As Object, xTile, Ar, iR As Integer
With CreateObject("InternetExplorer.Application")
' .Visible = True
.Navigate "http://www.land.moi.gov.tw/ngis/chhtml/query2.asp"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
For i = 0 To .document.all.tags("SELECT").Length - 1
Set E = .document.all.tags("SELECT")(i)
ReDim Ar(1 To E.Length - 1)
For iR = 1 To E.Length - 1
Ar(iR) = iR & Space(1) & E(iR).INNERTEXT
Next
Do
xTile = InputBox(Join(Ar, vbLf), E(0).INNERTEXT & " 1-" & E.Length - 1, 1)
If Val(xTile) = 0 Then MsgBox "離開程式": GoTo OU
Loop Until Val(xTile) >= 1 And Val(xTile) <= E.Length - 1
E.selectedIndex = Val(xTile)
E.fireEvent ("onchange")
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Next
Do
Set E = .document.all.tags("INPUT")
Loop Until Not E Is Nothing
For Each Ar In E
If Ar.Value = "查詢" And Ar.Type = "button" Then
Ar.Click
Exit For
End If
Next
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Do
Set E = .document.all.tags("STRONG")(0)
Loop Until Not E Is Nothing
MsgBox E.INNERTEXT
OU:
.Quit '關閉網頁
End With
End Sub

複製代碼

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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2016-2-23 20:39 | 顯示全部帖子

回復 3# sillykin

http://forum.twbts.com/tag.php?name=網頁元素

'MsgBox E.INNERTEXT
[B11]=E.INNERTEXT

複製代碼

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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2016-2-25 21:35 | 顯示全部帖子

本帖最後由 GBKEE 於 2016-2-26 06:13 編輯

回復 7# sillykin
試試看
UserForm的程式碼
需制定如下的6個控制項
ComboBox0, ComboBox1, ComboBox2, ComboBox3, ComboBox4, Label1

Option Explicit
Dim IE As Object, Combo_Ar(), xMsg As Boolean, xButton As Boolean, xRng As Range
Private Sub UserForm_Initialize()
'ComboBox 控制項 -> 縣市'事務所名稱 '鄉鎮市區'段'小段
Combo_Ar = Array(ComboBox0, ComboBox1, ComboBox2, ComboBox3, ComboBox4)
Set IE = CreateObject("InternetExplorer.Application")
Set xRng = [B11]
Label1 = ""
xRng.Resize(, 6) = ""
With IE
'.Visible = True '可不顯示IE
.Navigate "http://www.land.moi.gov.tw/ngis/chhtml/query2.asp"
Do While .Busy Or .readyState <> 4: DoEvents: Loop
ComboBox_list 0
End With
End Sub
Private Sub ComboBox_list(ByVal Op As Integer)
'縣市'事務所名稱 '鄉鎮市區'段'小段的選項內容導入ComboBox的list
Dim xSelect As Object, i As Integer, x As Integer
xMsg = True
'xButton = True
For i = Op To UBound(Combo_Ar)
With Combo_Ar(i)
If i = Op And .ListCount = 0 Then
Do
Set xSelect = IE.Document.all.tags("SELECT")(i)
Loop Until xSelect.Length > 0
' MsgBox .List(1)
For x = 0 To xSelect.Length - 1
.AddItem
.List(.ListCount - 1, 0) = xSelect(x).innertext
Next
.ListIndex = 0
ElseIf i = Op And .ListIndex > 0 Then
Do
Set xSelect = IE.Document.all.tags("SELECT")(i)
Loop Until xSelect.Length > 0
xSelect.selectedIndex = .ListIndex
If Op <> UBound(Combo_Ar) Then
xSelect.fireEvent ("onchange")
Do While IE.Busy Or IE.readyState <> 4: DoEvents: Loop
Do
Set xSelect = IE.Document.all.tags("SELECT")(i + 1)
Loop Until xSelect.Length > 0
With Combo_Ar(i + 1)
.Clear
For x = 0 To xSelect.Length - 1
.AddItem
.List(.ListCount - 1, 0) = xSelect(x).innertext
Next
.ListIndex = 0
End With
End If
ElseIf i > 0 Then
If Combo_Ar(i - 1).ListIndex = 0 Or Combo_Ar(i - 1).ListCount = 0 Then
.Clear
End If
End If
If .ListCount = 0 Or .ListIndex = 0 Then xButton = False
If UBound(Combo_Ar) = i And .ListCount > 0 Then
If .ListCount = 2 And .List(1) = "" Then xButton = True
If .ListCount = 2 And .List(1) <> "" And .ListIndex > 0 Then xButton = True
If .ListCount > 2 And .ListIndex > 0 Then xButton = True
End If
End With
Next
If xButton Then
button_Click
Else
xRng.Cells(1, 6) = ""
Label1 = ""
End If
xMsg = False
End Sub
Private Sub ComboBox0_Change() '縣市
If xMsg = False Then ComboBox_list 0
xRng.Cells(1, 1) = ComboBox0.Value
End Sub
Private Sub ComboBox1_Change() '事務所名稱
If xMsg = False Then ComboBox_list 1
xRng.Cells(1, 2) = ComboBox1.Value
End Sub
Private Sub ComboBox2_Change() '鄉鎮市區
If xMsg = False Then ComboBox_list 2
xRng.Cells(1, 3) = ComboBox2.Value
End Sub
Private Sub ComboBox3_Change() '段
If xMsg = False Then ComboBox_list 3
xRng.Cells(1, 4) = ComboBox3.Value
End Sub
Private Sub ComboBox4_Change() '小段
If xMsg = False Then ComboBox_list 4
xRng.Cells(1, 5) = IIf(InStr(ComboBox4, "請選擇"), "", ComboBox4.Value)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
IE.Quit
End Sub
Private Sub button_Click() '查詢
Dim xIObject As Object, E
With IE
Do
Set xIObject = .Document.all.tags("INPUT")
Loop Until Not xIObject Is Nothing
For Each E In xIObject
If E.Value = "查詢" And E.Type = "button" Then
E.Click
Exit For
End If
Next
Do While .Busy Or .readyState <> 4: DoEvents: Loop
Do
Set xIObject = .Document.all.tags("STRONG")(0)
Loop Until Not xIObject Is Nothing
End With
E = xIObject.innertext
Label1 = Split(xIObject.innertext, "：")(1)
xRng.Cells(1, 6) = "'" & Split(xIObject.innertext, "：")(1)
End Sub