有這種東西？小米產品自動搶購程式excel vba版

2014-03-17 13:02  #1

• 回文
• 私訊
• 連結
• 載圖
• 引言
• 收藏
• 評分
• 回報
• 推薦

這程式是因為都搶不到寫來用的,
不負責一定搶到或是衍生其他問題!
大家可以試用看看
其中結帳選單部分無法出現區域選單程式處理辦法也是自動點兩次結算
因為onchange一直無法觸發,不知為何原因, 可能是因為沒有內定值的關係, 還在研究
所有程式碼皆為vba撰寫, 所有程式碼都看得到, 沒有甚麼帳戶資料流出的可能

希望不要當成斂財工具
使用方法
1. 解開附件壓縮檔
2. 將1234.htm及1234_files資料夾放在任一磁碟的跟目錄如C:\
3. excel打開1.xls, 並填寫表單-->按載入網頁-->自動執行
PS.登錄檔位置有兩項, 一項是C:\1234.htm, 另一個是file:///C:/1234.htm
如1234.htm放在D槽要把C改成D(大寫, 不可小寫)

程式會自動登錄完後每"搜索延遲"時間內掃一次是否可以購買,可以就會自動一直買到"訂單數量"滿為止

程式碼如下

'宣告
Option Explicit
Public IE As Object
Public I As Long
Public j As Long
Public a As Long
Public objElement As Object
Public objCollection As Object
Public sh As Object, oWin As Object
Public wss As Object
Public objSELECTelement As Object
Public ads As String
Public det As Integer
Public ordno As Integer



Private Sub CommandButton1_Click()
'載入登陸網頁
Set wss = CreateObject("WScript.Shell")
Set sh = CreateObject("Shell.Application")
wss.exec "%ProgramFiles%/Internet Explorer/iexplore.exe -nomerge " + Cells(11, 2)
delay (1)
End Sub

Private Sub CommandButton2_Click()
'找尋網頁
For Each oWin In sh.Windows
If TypeName(oWin.document) = "HTMLDocument" And oWin.LocationUrl = Cells(11, 3) Then
Set IE = oWin
Exit For
Else
a = 1
End If
Next

'登陸
IE.document.all("username").Value = Cells(1, 2)
IE.document.all("userPwd").Value = Cells(2, 2)
IE.document.all("loginForm").Click

Dim oHTML_Element As Object
Dim htmlbutton As Object

For Each oHTML_Element In IE.document.getElementsByTagName("input")
If oHTML_Element.Type = "submit" Then oHTML_Element.Click: Exit For
Next

Checkieready

delay (0.5)

IE.navigate "http://www.xiaomi.tw/user/order"
Checkieready

'購買網址
ads = "http://www.xiaomi.tw/cart/add/" + CStr(Cells(4, 2)) + "-0-2"
det = CInt(Cells(10, 2))
ordno = CInt(Cells(3, 2))

'購買迴圈

For j = 1 To ordno
On Error GoTo p3

Do
Buyone

With IE.document.all("Cart_" + CStr(Cells(4, 2)) + "_0_buy").Value
End With
If IE.document.all("Cart_" + CStr(Cells(4, 2)) + "_0_buy").Value = "2" Then Exit Do

p3:
delay (det)
IE.navigate "http://www.xiaomi.tw/cart"
Checkieready
Resume p4

p4:
Loop

On Error GoTo p5

'結帳

Do
IE.document.all("mi_checkout").Click
Checkieready
Exit Do
p5:
IE.navigate "http://www.xiaomi.tw/cart"
Checkieready
Resume p6
p6:
Loop


IE.document.all("UserAddressName").Value = Cells(5, 2)
IE.document.all("UserAddressCity").Value = Cells(9, 2)

IE.document.all("checkoutFormBtn").Click
Checkieready

Set objSELECTelement = IE.document.all("UserAddressDistrict")
objSELECTelement.Value = Cells(9, 4)
objSELECTelement.FireEvent ("onchange")
Checkieready


IE.document.all("UserAddressDetail").Value = Cells(7, 2)
IE.document.all("zipcode").Value = Cells(8, 2)
IE.document.all("UserAddressTel").Value = Cells(6, 2)

IE.document.all("checkoutFormBtn").Click
Checkieready

Cells(12, 2) = j

Next j

End Sub
Sub Checkieready()
'busy check
Do While IE.busy
Application.Wait DateAdd("s", 1, Now)
Loop

End Sub

Sub delay(x)
'timer
Dim t As Long
t = Timer
Do Until Timer - t > x
If t > Timer Then t = t - 86400
DoEvents
Loop

End Sub

Sub Buyone()
'購買
IE.navigate ads
Checkieready
End Sub

2014/3/17 3:46更新程式bug, 請重新下載