駐車場予約サイトakippaの予約競争に勝つVBAコード

スポンサーリンク

2017/12/18追記

akippaのサイトリニューアルに伴いVBAでの処理内容を変更が必要になりました。
こちらの記事の内容は使えなくなっています。
新しいサイトの操作はこちら(https://officevba.info/akippakyousouvba2/)をご覧ください。

駐車場予約サイトakippa

以前にこちらで紹介したことがありますが、登録されている駐車場を予約するakippaというサイトがあります。

駐車場予約サイト「akippa」

駐車場が事前に予約できるので利用者としてはすごく便利なのですが、一部の利便性の高い駐車場は予約競争になってしまっているようです。

今回はその予約競争に勝つためのVBAコードを紹介します。

スポンサーリンク

駐車場の予約は最大30日

駐車場の予約は場所によっても違いますが、おそらく最大30日になっているようです。
今回作成したVBAコードは駐車場が予約可能になる日の決められた時間に起動するように設定しています。

15列目の開始時間の項目を0:00:00に設定しておくと予約システムが更新されたタイミングすぐに予約を取得するプログラムが実行されます。

作成したファイルのシートとVBAコード

シートの画像と説明

今回作成したファイルのシートの画像を以下に載せます。

79-1

シートには電話番号、メールアドレス、車種、車両ナンバー、カート番号、有効期限月、有効期限年、カード名義名、カード名義姓、駐車場URL、開始時間を登録できるようにしておき、時間が来たらInternetExplorerを起動して予約する仕組みにしています。
(*この画像では背景色を黒にして隠しています。)

最初の1回だけは予約するのにカードの情報などが必要ですが、2回目以降実行する際はクレジットの情報などは自動でサイトに登録されているのでこちらのファイルに情報を入力しておく必要はありません。

プログラムに直接クレジットの番号を記載することに抵抗のある方は、この欄を最初から空欄にしておいて、最後の予約画面で手入力して確定させても大丈夫です。

その他シート上には予約実行ボタン・予約解除のボタンを用意しています。

予約実行ボタンの目的は2つあり、一つは起動する手間を省くことです。
もう一つの目的は待機中、きちんと起動しているかどうかが確認できないので、起動中予約実行ボタンが赤くなるようにして、目で見て実行中であることを確認できるようにしています。
(ボタンの名前は「予約」にしておいて、VBAで色を変更できるように設定しています。)

予約解除ボタンはエラーなどが生じた際にマクロを中断できるようにする目的で設置しています。

作成したVBAコード

作成したVBAコードは以下のようになります。

指定した時間の1分前に一度画面を更新して、時間が来たらもう一度画面を更新して予約を取得するプログラムになっています。

1分前に1度更新しているのは、長時間放置した際にネットの接続が悪かったのか、きちんとページが表示されないことがあったので、その防止のためです。

起動は少なくとも1分30秒くらい空けておかないとその後の予約実行につながらないので注意してください。

その他の注意点ですが、IEの操作なので、VBEの参照設定の「Microsoft HTML Object Library」と「Microsoft Internet Controls」にチェックを入れないときちんと実行されません。
参照設定の手順はこちらの記事を参考にしてください。

Option Explicit
Dim colSh As Object
Dim win As Object
Dim IE As Object
Dim objIE(5) As Object
Dim txtInput(16) As Object
Dim txtInput2(20) As Object
Dim anchor As Object
Declare Sub Sleep Lib “kernel32” (ByVal dwMilliseconds As Long)

Dim stopflag

Sub 予約中断()

stopflag = False
表示標準

End Sub

Sub タイマー実行()

Dim 駐車場URL As String
駐車場URL = Cells(8, 3)

Dim 予約実行時間
予約実行時間 = Cells(1, 15)

Dim 予約実行前更新時間

Set IE = CreateObject(“InternetExplorer.application”)
IE.Visible = True

IE.navigate (“https://officevba.info/akippakyousouvba/”)
Do While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 100

For Each anchor In IE.document.getElementsByTagName(“A”)
If InStr(anchor.innerText, “駐車場予約サイト「akippa」”) > 0 Then
anchor.Click
Exit For
End If
Next

Do While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 5000

Set IE = Nothing

Dim IeFlag
IeFlag = False ’きちんと読み込めたときのフラグ

Set colSh = CreateObject(“Shell.Application”)
For Each win In colSh.Windows
If TypeName(win.document) = “HTMLDocument” Then
’If InStr(win.document.Title, “akippa”) > 0 Then
If win.document.Url = “https://www.akippa.com/” Then
Set IE = win
IeFlag = True
Exit For
End If
End If
Next

If IeFlag = False Then ’もう一度読み込み実行する
Sleep 5000
For Each win In colSh.Windows
If TypeName(win.document) = “HTMLDocument” Then
’If InStr(win.document.Title, “akippa”) > 0 Then
If win.document.Url = “https://www.akippa.com/” Then
Set IE = win
IeFlag = True
Exit For
End If
End If
Next

End If

IE.navigate (駐車場URL)
Do While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 1000

Set IE = Nothing

stopflag = True
表示実行中

予約実行前更新時間 = 予約実行時間 - 1 / 1440
Do Until stopflag = False
If Hour(Time) = Hour(予約実行前更新時間) And Minute(Time) = Minute(予約実行前更新時間) And Second(Time) >= Second(予約実行前更新時間) Then
Beep
IE更新
Exit Do
End If
Sleep 1
DoEvents
Loop

Do Until stopflag = False

If Hour(Time) = Hour(予約実行時間) And Minute(Time) = Minute(予約実行時間) And Second(Time) >= Second(予約実行時間) Then
Beep
IE更新と予約実行
stopflag = False
End If
Sleep 1
DoEvents

Loop

End Sub

Private Sub IE更新()

Set colSh = CreateObject(“Shell.Application”)
For Each win In colSh.Windows
If TypeName(win.document) = “HTMLDocument” Then
’If InStr(win.document.Title, “akippa”) > 0 Then
If win.document.Url = Cells(8, 3).Text Then
Set objIE(0) = win
Exit For
End If
End If
Next
objIE(0).Refresh

End Sub

Private Sub IE更新と予約実行()

Set colSh = CreateObject(“Shell.Application”)
For Each win In colSh.Windows
If TypeName(win.document) = “HTMLDocument” Then
’If InStr(win.document.Title, “akippa”) > 0 Then
If win.document.Url = Cells(8, 3).Text Then
Set objIE(1) = win
Exit For
End If
End If
Next
objIE(1).Refresh

Do While objIE(1).Busy Or objIE(1).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop

予約実行
表示標準

End Sub

Private Sub 予約実行()

Dim 電話番号
Dim メールアドレス
Dim 車種
Dim 車両ナンバー
Dim 取得希望日

電話番号 = Cells(2, 3)
メールアドレス = Cells(3, 3)
車種 = Cells(4, 3)
車両ナンバー = Cells(5, 3)
取得希望日 = Cells(10, 3).Text

Dim カード番号
カード番号 = Cells(2, 5)

On Error GoTo 待機

Set colSh = CreateObject(“Shell.Application”)
For Each win In colSh.Windows
If TypeName(win.document) = “HTMLDocument” Then
’If InStr(win.document.Title, “akippa”) > 0 Then
If win.document.Url = Cells(8, 3).Text Then
Set objIE(2) = win
Exit For
End If
End If
Next

Dim Doc As HTMLDocument
Set Doc = objIE(2).document

Dim i As Long
Dim x As Long

On Error Resume Next
Set txtInput(0) = objIE(2).document.getElementById(“car_number”)
txtInput(0).Value = 車両ナンバー
Sleep 100
Do While objIE(2).Busy Or objIE(2).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
On Error GoTo 待機

For i = 800 To 1500
If Replace(Doc.all(i).innerText, ” “, “”) = Replace(Replace(取得希望日, “(“, “(”), “)”, “)”) Then
If Replace(Doc.all(i + 8).innerText, ” “, “”) = “空” Then
Doc.all(i).Click

Set txtInput2(0) = objIE(2).document.getElementsByClassName(“cartype_selector”)(0)
txtInput2(0).Value = 車種

Sleep 100
Do While objIE(2).Busy Or objIE(2).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop

Set txtInput(4) = objIE(2).document.getElementsByName(“phone_number”)(0)
txtInput(4).Value = Replace(電話番号, “-“, “”)

Sleep 100
Do While objIE(2).Busy Or objIE(2).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop

On Error Resume Next
Set txtInput(5) = objIE(2).document.getElementById(“email”)
txtInput(5).Value = メールアドレス
Sleep 100
Do While objIE(2).Busy Or objIE(2).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
On Error GoTo 0

On Error Resume Next
Set txtInput(6) = objIE(2).document.getElementById(“car_number”)
txtInput(6).Value = 車両ナンバー
Sleep 100
Do While objIE(2).Busy Or objIE(2).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop

Set txtInput(7) = objIE(2).document.getElementById(“dailyCorpPaymentCheck”)
txtInput(7).Click

On Error GoTo 待機

Set txtInput(8) = objIE(2).document.getElementsByClassName(“daily_pay_credit_btn daily_submit_btn buttonA”)(0)
txtInput(8).Click

Sleep 3000
Do While objIE(2).Busy Or objIE(2).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 3000

If カード番号 = “” Then
決済入力クレジット登録なし
Else
決済入力
End If

Exit For

ElseIf Replace(Doc.all(i + 8).innerText, ” “, “”) = “満” Then
Cells(10, 4) = “×”

End If
End If
Next i

Exit Sub
待機:

DoEvents
Sleep 100
Resume

End Sub

Private Sub 決済入力()

Dim 電話番号
Dim メールアドレス

Dim カード番号
Dim 有効期限月
Dim 有効期限年
Dim カード名義名
Dim カード名義姓

電話番号 = Cells(2, 3)
メールアドレス = Cells(3, 3)

カード番号 = Cells(2, 5)
有効期限月 = Cells(3, 5)
有効期限年 = Cells(4, 5)
カード名義名 = Cells(5, 5)
カード名義姓 = Cells(6, 5)

Set colSh = CreateObject(“Shell.Application”)
For Each win In colSh.Windows
If TypeName(win.document) = “HTMLDocument” Then
If InStr(win.document.Title, “決済”) > 0 Then
Set objIE(3) = win
Exit For
End If
End If
Next

On Error GoTo 決済実行

Set txtInput(10) = objIE(3).document.getElementById(“cardno”)
txtInput(10).Value = Replace(カード番号, “-“, “”)

Set txtInput2(1) = objIE(3).document.getElementById(“expdate_m”)
txtInput2(1).Value = Format(有効期限月, “00”)

Set txtInput2(2) = objIE(3).document.getElementById(“expdate_y”)
txtInput2(2).Value = Format(有効期限年, “0000”)

Set txtInput(11) = objIE(3).document.getElementById(“firstname”)
txtInput(11).Value = カード名義名

Set txtInput(12) = objIE(3).document.getElementById(“lastname”)
txtInput(12).Value = カード名義姓

Set txtInput(13) = objIE(3).document.getElementById(“tel”)
txtInput(13).Value = Replace(電話番号, “-“, “”)

Set txtInput(14) = objIE(3).document.getElementById(“email”)
txtInput(14).Value = メールアドレス

Set txtInput(15) = objIE(3).document.getElementById(“Button1”)
txtInput(15).Click

Do While objIE(3).Busy Or objIE(3).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 2000

On Error GoTo 0

Set txtInput(16) = objIE(3).document.getElementById(“Button1”)
txtInput(16).Click

Cells(10, 4) = “〇”

Exit Sub
決済実行:

Set txtInput(16) = objIE(3).document.getElementById(“Button1”)
txtInput(16).Click
Cells(10, 4) = “〇”

End Sub

Private Sub 決済入力クレジット登録なし()

Set colSh = CreateObject(“Shell.Application”)
For Each win In colSh.Windows
If TypeName(win.document) = “HTMLDocument” Then
If InStr(win.document.Title, “決済”) > 0 Then
Set objIE(4) = win
Exit For
End If
End If
Next

On Error GoTo 待機

Set txtInput(15) = objIE(4).document.getElementById(“Button1”)
txtInput(15).Click

Sleep 100
Do While objIE(4).Busy Or objIE(4).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 500

Do While objIE(4).Busy Or objIE(4).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop

Cells(10, 3) = “〇”

Exit Sub
待機:

DoEvents
Sleep 100
Resume

End Sub

Private Sub 表示実行中()

Dim shp
For Each shp In ActiveSheet.Shapes
If shp.Name = “予約” Then
shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
End If
Next

End Sub

Sub 表示標準()

Dim shp
For Each shp In ActiveSheet.Shapes
If shp.Name = “予約” Then
shp.Fill.ForeColor.RGB = RGB(242, 220, 219)
End If
Next

End Sub

予約実行時の動画

こちらでの動作確認時の動画を以下に載せます。


おすすめ書籍 (広告)

コメント