またまた、Excel マクロ(VBA)を作ってみましたw
Visual Basic では、いまいち上手くいかなかったのですが、こちらは、意外にもちゃんと動いていますw ま、ちゃんと確認しきれてはいないのでバグはあるかも知れませんがw
こちらが、操作画面ですw
Ameba ID をリストに登録して、「ペタ開始」ボタンをぽちっとするだけですw
一応、
①現在作業中の ID 表示、
②プログレスの表示、
③ペタの結果表示(○、△、×)、
④過去2回分の結果保存
と言う様な機能がありますw
<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
注意)不等号記号は、アメブロのエラー会費のため、全角文字を使用しています。