VB(#9) アメブロ自動巡回ペタ用Excelマクロ(VBA)を作ってみたｗ

またまた、Excel マクロ（VBA）を作ってみましたｗ

Visual Basic では、いまいち上手くいかなかったのですが、こちらは、意外にもちゃんと動いていますｗ　ま、ちゃんと確認しきれてはいないのでバグはあるかも知れませんがｗ




こちらが、操作画面ですｗ

Ameba ID をリストに登録して、「ペタ開始」ボタンをぽちっとするだけですｗ



一応、
　　①現在作業中の ID 表示、
　　②プログレスの表示、
　　③ペタの結果表示（○、△、×）、
　　④過去2回分の結果保存
と言う様な機能がありますｗ


＜Excel VBA のソースコード＞

Private Sub CommandButton1_Click()

Dim objIE As InternetExplorer
Dim urlName As String
Dim strHtlm As String

'urlName = "http://www.yahoo.co.jp/"
'Call ieView(objIE, urlName)

Dim waitSession As Variant
Dim errorFlag As Integer

Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
i = "0"
j = "1"
m = "0"
k = "0"

TextBox1.Text = "　"
TextBox2.Text = CStr(k) + " %"
staBar (m)

IdCheck:
'Ameba ID の空白判定
If Cells(6 + i, 5).Value = "" Then
If i ＜= 0 Then
GoTo Finish
End If
GoTo StatusIndicationPhase
End If
i = i + 1
'Cells(18, 2) = i '★★Debug用
GoTo IdCheck

StatusIndicationPhase:
For j = 1 To i

'作業中のID表示
TextBox1.Text = Cells(j + 5, 5)
'Cells(19, 2) = j '★★Debug用
'進捗率表示
k = j / i * 100
'Cells(20, 2) = k '★★Debug用
TextBox2.Text = CStr(k) + " %"
m = k / 10
Call staBar(m)

Initialization:

If j = 1 Then
Call pastRecord

Dim buf As String
buf = Date
Cells(5, 6) = buf
End If

BlogPagePhase:
'Ameba ブログ表示
urlName = "http://ameblo.jp/" & Cells(j + 5, 5) & "/"
If j = 1 Then
Call ieView(objIE, urlName)
Else
Call ieNavi(objIE, urlName)
End If
Application.Wait (Now() + TimeValue("00:00:01")) '3秒停止する。

If Cells(j + 5, 9) = "▲" Then
Cells(j + 5, 6) = "▲"
GoTo PetaDone
End If


PetaPagePhase:
'★「ぺたのページ」をIEで表示
Dim TargetName As String
TargetName = "ペタ"

Call ieButtonClick(objIE, TargetName)

If Cells(j + 5, 9) = "▲" Then
Cells(j + 5, 6) = "▲"
GoTo PetaDone
End If

Dim currentURL As String
currentURL = objIE.LocationURL
Dim checkPage As Integer
checkPage = InStr(currentURL, "addPeta")
'Cells(25, 2) = checkPage '★★Debug用
If checkPage ＞ 0 Then
GoTo PetaButtonPhase
End If
Cells(j + 5, 6) = "×"
GoTo PetaDone

PetaButtonPhase:

'★「ぺた」を実行する
Dim urlPeta As String
Dim StartNumber As Long
Dim PetaID As String

urlPeta = ""
StartNumber = "0"
PetaID = ""
Set doc = objIE.document
strHtml = doc.body.outerHTML

'Call saveHtml(objIE, strHtml)

'ペタが終了していないかをチェック
StartNumber = InStr(strHtml, "明日もペタしてね")
If StartNumber ＞ 0 Then
Cells(j + 5, 6) = "△" 'ペタ完了済み
GoTo PetaDone
End If

'ターゲットの文字列の開始位置を確認
StartNumber = InStr(strHtml, "link=/p/addPetaComplete.do")
'Cells(21, 2) = StartNumber '★★Debug用
'PetaIDを抽出
PetaID = Mid(strHtml, StartNumber + 38, 32)
'Cells(22, 2) = PetaID '★★Debug用
urlPeta = "http://peta.ameba.jp/p/addPetaComplete.do?petaId=" + PetaID + "&targetAmebaId=" + Cells(j + 5, 5)
'Cells(23, 2) = urlPeta '★★Debug用

Call ieNavi(objIE, urlPeta)
Application.Wait (Now() + TimeValue("00:00:03")) '3秒停止する。
Cells(j + 5, 6) = "○" 'ペタ実施
PetaDone:

Next j

Finish:
'IE(InternetExplorer)を閉じる
objIE.Quit

End Sub

Sub ieView(objIE As InternetExplorer, urlName As String, Optional viewFlg As Boolean = True)

'IE(InternetExplorer)のオブジェクトを作成する
Set objIE = CreateObject("InternetExplorer.Application")

'IE(InternetExplorer)を表示・非表示
objIE.Visible = viewFlg

'指定したURLのページを表示する
objIE.Navigate urlName

'IEが完全表示されるまで待機
Call ieCheck(objIE)

End Sub

Sub ieCheck(objIE As InternetExplorer)

Dim timeOut As Date
Dim timeError As Date
Dim waitTime As Date

timeOut = Now + TimeSerial(0, 0, 15)
timeError = Now + TimeSerial(0, 0, 60)
waitTime = DateAdd("s", 1, Now)
errorFlag = "0"

Do While objIE.Busy = True Or objIE.ReadyState <> 4
DoEvents
Application.Wait waitTime
If Now ＞ timeOut Then
objIE.Refresh
timeOut = Now + TimeSerial(0, 0, 10)
If Now ＞ timeError Then
Cells(j + 6, 9) = "▲"
GoTo Endsub
End If
End If
Loop

Do Until objIE.document.ReadyState = "complete"
DoEvents
Application.Wait waitTime
If Now ＞ timeOut Then
objIE.Refresh
timeOut = Now + TimeSerial(0, 0, 10)
If Now ＞ timeError Then
Cells(j + 6, 9) = "▲"
GoTo Endsub
End If
End If
Loop

Endsub:

End Sub

Sub ieNavi(objIE As InternetExplorer, urlName As String)

'指定したURLをIE(InternetExplorer)で表示
objIE.Navigate urlName

'IE(InternetExplorer)が完全表示されるまで待機
Call ieCheck(objIE)

End Sub

'指定した秒だけ停止する関数
Sub WaitFor(ByVal second As Integer)

Dim futureTime As Date
futureTime = DateAdd("s", second, Now)

While Now ＜ futureTime
DoEvents
Wend

End Sub

Sub saveHtml(objIE, strHtml)

Dim TXT As String

'Set doc = objIE.document
'strHtml = doc.body.outerHTML
TXT = ThisWorkbook.Path & "\PetaPage_Source.txt"
strHtml = Replace(strHtml, vbLf, vbCrLf)

i = FreeFile
Open TXT For Output As i
Print #i, strHtml
Close #i

'「Notepad」を開いて、サイトのソースを表示する
'ret = Shell("Notepad.Exe " & TXT, vbNormalFocus)

End Sub

Sub staBar(m As Integer)

Cells(16, 2) = String(m, "■") & String(10 - m, "□")

End Sub

Sub ieButtonClick(ByRef objIE As Object, TargetName As String)

Dim objTag As Object

For Each objTag In objIE.document.getElementsByTagName("a")
If objTag.innerText = TargetName Then
objTag.Click
Call ieCheck(objIE)
Application.Wait (Now() + TimeValue("00:00:03")) '3秒停止する。
Exit For
End If
Next

End Sub

Sub pastRecord()

Range("G5:G65535").Copy Range("H5:H65535")
Range("F5:F65535").Copy Range("G5:G65535")
Range("F5:F65535").ClearContents
Range("I6:I65535").ClearContents

End Sub


注意）不等号記号は、アメブロのエラー会費のため、全角文字を使用しています。