2017/12/18追記
akippaのサイトリニューアルに伴いVBAでの処理内容を変更が必要になりました。
こちらの記事の内容は使えなくなっています。
新しいサイトの操作はこちら(https://officevba.info/akippakyousouvba2/)をご覧ください。
駐車場予約サイトakippa
以前にこちらで紹介したことがありますが、登録されている駐車場を予約するakippaというサイトがあります。
駐車場が事前に予約できるので利用者としてはすごく便利なのですが、一部の利便性の高い駐車場は予約競争になってしまっているようです。
今回はその予約競争に勝つためのVBAコードを紹介します。
スポンサーリンク
駐車場の予約は最大30日
駐車場の予約は場所によっても違いますが、おそらく最大30日になっているようです。
今回作成したVBAコードは駐車場が予約可能になる日の決められた時間に起動するように設定しています。
15列目の開始時間の項目を0:00:00に設定しておくと予約システムが更新されたタイミングすぐに予約を取得するプログラムが実行されます。
作成したファイルのシートとVBAコード
シートの画像と説明
今回作成したファイルのシートの画像を以下に載せます。
シートには電話番号、メールアドレス、車種、車両ナンバー、カート番号、有効期限月、有効期限年、カード名義名、カード名義姓、駐車場URL、開始時間を登録できるようにしておき、時間が来たらInternetExplorerを起動して予約する仕組みにしています。
(*この画像では背景色を黒にして隠しています。)
最初の1回だけは予約するのにカードの情報などが必要ですが、2回目以降実行する際はクレジットの情報などは自動でサイトに登録されているのでこちらのファイルに情報を入力しておく必要はありません。
プログラムに直接クレジットの番号を記載することに抵抗のある方は、この欄を最初から空欄にしておいて、最後の予約画面で手入力して確定させても大丈夫です。
その他シート上には予約実行ボタン・予約解除のボタンを用意しています。
予約実行ボタンの目的は2つあり、一つは起動する手間を省くことです。
もう一つの目的は待機中、きちんと起動しているかどうかが確認できないので、起動中予約実行ボタンが赤くなるようにして、目で見て実行中であることを確認できるようにしています。
(ボタンの名前は「予約」にしておいて、VBAで色を変更できるように設定しています。)
予約解除ボタンはエラーなどが生じた際にマクロを中断できるようにする目的で設置しています。
作成したVBAコード
作成したVBAコードは以下のようになります。
指定した時間の1分前に一度画面を更新して、時間が来たらもう一度画面を更新して予約を取得するプログラムになっています。
1分前に1度更新しているのは、長時間放置した際にネットの接続が悪かったのか、きちんとページが表示されないことがあったので、その防止のためです。
起動は少なくとも1分30秒くらい空けておかないとその後の予約実行につながらないので注意してください。
その他の注意点ですが、IEの操作なので、VBEの参照設定の「Microsoft HTML Object Library」と「Microsoft Internet Controls」にチェックを入れないときちんと実行されません。
参照設定の手順はこちらの記事を参考にしてください。
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
予約実行時の動画
こちらでの動作確認時の動画を以下に載せます。
おすすめ書籍 (広告)
Amazon 楽天 Yahoo検索 |
---|
Amazon 価格:¥1,603円 |
bookfan 1号店 楽天市場店 価格:2,530円 |
bookfan 1号店 楽天市場店 価格:2,530円 |
VALUE BOOKS Yahoo!店 価格:413円 |
bookfanプレミアム 価格:2,530円 |
コメント