找十五田的程式碼 VB6

我用VB6寫的, 有興趣的朋友, 可以拿去研究 !


Option Explicit
Private Obj_IE As SHDocVw.InternetExplorer ' 引用項目 Microsoft Internet Controls
Private hdoc As MSHTML.HTMLDocument ' 引用項目 Microsoft HTML Object Library

Private Sub Command1_Click()
Dim sHTML As String, sHTML_1 As String, intS As Integer, intL As Integer, I As Long
Dim A As Integer, B As Integer, C As Integer, E As Integer, d As Integer, F As Integer
Dim mX$, mY$, md$, mc$, X As Integer, Y As Integer, vX As Integer, vY As Integer
Dim Db As Database, Rs As Recordset, Ts As Long, 網址 As String
Command1.Enabled = False
網址 = "http://s1.travian.tw"
Set Db = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\db1.mdb")
Set Rs = Db.OpenRecordset("A")
Rs.Index = "PrimaryKey"
I = 222396 <-- 地圖中心
X = 116 <-- 開拓者中心座標
Y = 130
Ts = Timer
Do
sHTML = GetHTML(網址 + "/karte.php?z=" & I)
Text1.Text = I
intS = InStr(sHTML, "")
Do While intS
A = InStr(intS, sHTML, "x_y('")
If A > 0 Then
B = InStr(A, sHTML, "','")
mX$ = Mid$(sHTML, A + 5, B - A - 5): vX = Val(mX$)
C = InStr(B, sHTML, "')")
mY$ = Mid$(sHTML, B + 3, C - B - 3): vY = Val(mY$)
Text1.Text = Text1.Text & vbCrLf & " (" & mX$ & "," & mY$ & ")"
A = InStr(C, sHTML, "karte.php?d=")
B = InStr(A, sHTML, "&c=")
C = InStr(B, sHTML, Chr$(34) + ">")
md$ = Mid$(sHTML, A + 12, B - A - 12)
mc$ = Mid$(sHTML, B + 7, C - B - 7)
Rs.Seek "=", md$
If Rs.NoMatch Then
sHTML_1 = GetHTML(網址 + "/karte.php?d=" & md$ & "&c=" & mc$)
A = InStr(sHTML_1, "荒廢的山谷")
B = InStr(sHTML_1, "資源分配")
F = 0
If A > 0 And B > 0 Then
d = InStr(sHTML_1, "img/un/r/4.gif")
E = InStr(d, sHTML_1, "s7 b")
F = Val(Mid$(sHTML_1, E + 6, 2))
End If
Text1.Text = Text1.Text & " " & F & "田"
With Rs
.AddNew
.Fields("X") = mX$
.Fields("Y") = mY$
.Fields("d") = md$
.Fields("c") = mc$
.Fields("米") = F
.Fields("路") = Int(Sqr((vX - X) ^ 2 + (vY - Y) ^ 2) + 0.5)
.Fields("中") = False
.Update
End With
End If
Else
Exit Do
End If
intS = C
Loop
Data1.Refresh
Data2.Refresh
With Data1.Recordset
If .RecordCount = 0 Then Exit Do
I = .Fields("d")
mX$ = .Fields("X")
mY$ = .Fields("Y")
.Edit
.Fields("中") = True
.Update
End With
Db.Execute "update [A] set [中]=true where (abs([X]-" & mX$ & ") + abs([Y]-" & mY$ & "))<6"
Data1.Refresh
Data1.Caption = Data1.Recordset.RecordCount
Data2.Caption = Data2.Recordset.RecordCount
DoEvents
Loop
MsgBox "搜尋結束!"
End Sub

Private Function GetHTML(ByVal InUrl As String) As String
Set Obj_IE = New SHDocVw.InternetExplorer
With Obj_IE
'.Visible = True
DoEvents
.navigate InUrl
End With
'等待網頁開啟完成
Do Until Obj_IE.readyState = 4
DoEvents
Loop
'抓取 IE 的網頁內容物件
Set hdoc = Obj_IE.document
GetHTML = LCase(hdoc.body.outerHTML)
Obj_IE.Quit
Set hdoc = Nothing
Set Obj_IE = Nothing
End Function

Private Sub Form_Load()
With Data1
.DatabaseName = App.Path & "\db1.mdb"
.RecordSource = "select [d],[X],[Y],[路],[中] from [A] where [中]=false order by [路]"
.Refresh
End With
With Data2
.DatabaseName = App.Path & "\db1.mdb"
.RecordSource = "select [X],[Y],[米],[路] from [A] order by [米] desc,[路] asc"
.Refresh
End With
End Sub