返回列表 上一主題 發帖

網頁查詢問題

網頁查詢問題

http://www.land.moi.gov.tw/ngis/chhtml/query2.asp

網頁.rar (576.23 KB)

回復 1# sillykin
試試看
  1. Option Explicit
  2. Sub Ex_土地段名代碼查詢系統()
  3.     Dim i As Integer, E As Object, xTile, Ar, iR As Integer
  4.     With CreateObject("InternetExplorer.Application")
  5. '        .Visible = True
  6.         .Navigate "http://www.land.moi.gov.tw/ngis/chhtml/query2.asp"
  7.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  8.         For i = 0 To .document.all.tags("SELECT").Length - 1
  9.                 Set E = .document.all.tags("SELECT")(i)
  10.                 ReDim Ar(1 To E.Length - 1)
  11.                 For iR = 1 To E.Length - 1
  12.                     Ar(iR) = iR & Space(1) & E(iR).INNERTEXT
  13.                 Next
  14.                 Do
  15.                 xTile = InputBox(Join(Ar, vbLf), E(0).INNERTEXT & "  1-" & E.Length - 1, 1)
  16.                 If Val(xTile) = 0 Then MsgBox "離開程式": GoTo OU
  17.                 Loop Until Val(xTile) >= 1 And Val(xTile) <= E.Length - 1
  18.                  
  19.                  E.selectedIndex = Val(xTile)
  20.                 E.fireEvent ("onchange")
  21.                 Do While .Busy Or .readyState <> 4: DoEvents: Loop
  22.             Next
  23.             Do
  24.                 Set E = .document.all.tags("INPUT")
  25.             Loop Until Not E Is Nothing
  26.             For Each Ar In E
  27.                 If Ar.Value = "查詢" And Ar.Type = "button" Then
  28.                     Ar.Click
  29.                     Exit For
  30.                 End If
  31.             Next
  32.             Do While .Busy Or .readyState <> 4: DoEvents: Loop
  33.             Do
  34.                 Set E = .document.all.tags("STRONG")(0)
  35.             Loop Until Not E Is Nothing
  36.             
  37.              MsgBox E.INNERTEXT
  38. OU:
  39.         .Quit        '關閉網頁
  40.     End With
  41. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 2# GBKEE


    謝謝g大的協助...試用沒問題...
但上述原理看不太懂...方便解釋一下嗎??
另一提要如何將代碼結果值放到[B11]中呢??

TOP

回復 3# sillykin

http://forum.twbts.com/tag.php?name=網頁元素
  1. 'MsgBox E.INNERTEXT
  2.          [B11]=E.INNERTEXT
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

謝謝大大耐心的回覆,小弟有很多不懂地方,會更加努力學習,感謝

TOP

回復 2# GBKEE


    G大能在請問
所輸入每筆的代號,名稱各出現在B11,c11,d11,e11,f11
方便核對輸入值是否正確

TOP

回復 6# sillykin [/
回復 2# GBKEE


    G大能在請問
所輸入每筆的代號,名稱各出現在B11,c11,d11,e11,f11
方便核對輸入值是否正確
能否給個提示

TOP

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

回復 7# sillykin
試試看
UserForm的程式碼
需制定如下的6個控制項
ComboBox0, ComboBox1, ComboBox2, ComboBox3, ComboBox4, Label1
  1. Option Explicit
  2. Dim IE As Object, Combo_Ar(), xMsg As Boolean, xButton As Boolean, xRng As Range
  3. Private Sub UserForm_Initialize()
  4.     'ComboBox 控制項 -> 縣市'事務所名稱 '鄉鎮市區'段'小段
  5.     Combo_Ar = Array(ComboBox0, ComboBox1, ComboBox2, ComboBox3, ComboBox4)
  6.     Set IE = CreateObject("InternetExplorer.Application")
  7.     Set xRng = [B11]
  8.     Label1 = ""
  9.     xRng.Resize(, 6) = ""
  10.     With IE
  11.         '.Visible = True '可不顯示IE
  12.         .Navigate "http://www.land.moi.gov.tw/ngis/chhtml/query2.asp"
  13.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  14.         ComboBox_list 0
  15.     End With
  16. End Sub
  17. Private Sub ComboBox_list(ByVal Op As Integer)
  18.     '縣市'事務所名稱 '鄉鎮市區'段'小段 的選項內容導入ComboBox的list
  19.     Dim xSelect As Object, i As Integer, x As Integer
  20.     xMsg = True
  21.     'xButton = True
  22.     For i = Op To UBound(Combo_Ar)
  23.         With Combo_Ar(i)
  24.             If i = Op And .ListCount = 0 Then
  25.                 Do
  26.                     Set xSelect = IE.Document.all.tags("SELECT")(i)
  27.                 Loop Until xSelect.Length > 0
  28.               ' MsgBox .List(1)
  29.                 For x = 0 To xSelect.Length - 1
  30.                     .AddItem
  31.                     .List(.ListCount - 1, 0) = xSelect(x).innertext
  32.                 Next
  33.                 .ListIndex = 0
  34.             ElseIf i = Op And .ListIndex > 0 Then
  35.                 Do
  36.                     Set xSelect = IE.Document.all.tags("SELECT")(i)
  37.                 Loop Until xSelect.Length > 0
  38.                 xSelect.selectedIndex = .ListIndex
  39.                 If Op <> UBound(Combo_Ar) Then
  40.                     xSelect.fireEvent ("onchange")
  41.                     Do While IE.Busy Or IE.readyState <> 4: DoEvents: Loop
  42.                     Do
  43.                         Set xSelect = IE.Document.all.tags("SELECT")(i + 1)
  44.                     Loop Until xSelect.Length > 0
  45.                     With Combo_Ar(i + 1)
  46.                         .Clear
  47.                         For x = 0 To xSelect.Length - 1
  48.                             .AddItem
  49.                             .List(.ListCount - 1, 0) = xSelect(x).innertext
  50.                         Next
  51.                         .ListIndex = 0
  52.                     End With
  53.                 End If
  54.             ElseIf i > 0 Then
  55.                 If Combo_Ar(i - 1).ListIndex = 0 Or Combo_Ar(i - 1).ListCount = 0 Then
  56.                     .Clear
  57.                 End If
  58.             End If
  59.             If .ListCount = 0 Or .ListIndex = 0 Then xButton = False
  60.             If UBound(Combo_Ar) = i And .ListCount > 0 Then
  61.                 If .ListCount = 2 And .List(1) = "" Then xButton = True
  62.                 If .ListCount = 2 And .List(1) <> "" And .ListIndex > 0 Then xButton = True
  63.                 If .ListCount > 2 And .ListIndex > 0 Then xButton = True
  64.             End If
  65.         End With
  66.     Next
  67.     If xButton Then
  68.         button_Click
  69.     Else
  70.         xRng.Cells(1, 6) = ""
  71.         Label1 = ""
  72.     End If
  73.     xMsg = False
  74. End Sub
  75. Private Sub ComboBox0_Change()      '縣市
  76.      If xMsg = False Then ComboBox_list 0
  77.      xRng.Cells(1, 1) = ComboBox0.Value
  78. End Sub
  79. Private Sub ComboBox1_Change()      '事務所名稱
  80.     If xMsg = False Then ComboBox_list 1
  81.     xRng.Cells(1, 2) = ComboBox1.Value
  82. End Sub
  83. Private Sub ComboBox2_Change()      '鄉鎮市區
  84.     If xMsg = False Then ComboBox_list 2
  85.     xRng.Cells(1, 3) = ComboBox2.Value
  86. End Sub
  87. Private Sub ComboBox3_Change()      '段
  88.     If xMsg = False Then ComboBox_list 3
  89.     xRng.Cells(1, 4) = ComboBox3.Value
  90. End Sub
  91. Private Sub ComboBox4_Change()      '小段
  92.     If xMsg = False Then ComboBox_list 4
  93.     xRng.Cells(1, 5) = IIf(InStr(ComboBox4, "請選擇"), "", ComboBox4.Value)
  94. End Sub
  95. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  96.     IE.Quit
  97. End Sub
  98. Private Sub button_Click() '查詢
  99.     Dim xIObject As Object, E
  100.     With IE
  101.         Do
  102.             Set xIObject = .Document.all.tags("INPUT")
  103.         Loop Until Not xIObject Is Nothing
  104.         For Each E In xIObject
  105.             If E.Value = "查詢" And E.Type = "button" Then
  106.                 E.Click
  107.                 Exit For
  108.             End If
  109.         Next
  110.         Do While .Busy Or .readyState <> 4: DoEvents: Loop
  111.         Do
  112.             Set xIObject = .Document.all.tags("STRONG")(0)
  113.         Loop Until Not xIObject Is Nothing
  114.     End With
  115.     E = xIObject.innertext
  116.     Label1 = Split(xIObject.innertext, ":")(1)
  117.     xRng.Cells(1, 6) = "'" & Split(xIObject.innertext, ":")(1)
  118. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

回復 8# GBKEE


    謝謝G大的協助...感謝
但試了一下..發生型態不符情形

型態不符1.JPG (68.05 KB)

型態不符1.JPG

TOP

回復 9# sillykin
因發生型態不符13,小弟加入下面一行
On Error Resume Next

但發生
物件值無法出現,又出現




此段有問題
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    IE.Quit
End Sub

9999999999.JPG (15.79 KB)

9999999999.JPG

TOP

        靜思自在 : 多做多得。少做多失。
返回列表 上一主題