削除

ループ処理でsetしたobjを無視して同じ物を取得してしまいます・・・削除

Message#2 2017年6月7日(水)18時51分
From: dream5

実際のコードを最低限で実行できるように記載します。
初心者な為にコメント部分が多く申し訳ありません。

下記がコードです。

よろしくお願いいたします。

Option Explicit

'sleep関数を64ビットでも使用可能にする
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If

'URLDownloadToFile関数を使用できるようにAPIの宣言する
Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long

'DeleteUrlCacheEntry関数を使用できるようにAPIの宣言する
Declare Function DeleteUrlCacheEntry Lib "wininet" _
Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

Dim objIE As InternetExplorer
Function tagCheck(objIE As InternetExplorer, _
methodType As String, _
elementName As String, _
keywords As String) As Boolean

Dim objDoc As Object
Dim myDoc As Object

tagCheck = False

Select Case methodType

Case "name"
Set objDoc = objIE.document.getElementsByName(elementName)

Case "class"
Set objDoc = objIE.document.getElementsByClassName(elementName)

Case "tag"
Set objDoc = objIE.document.getElementsByTagName(elementName)

End Select

For Each myDoc In objDoc

If InStr(myDoc.outerHTML, keywords) > 0 Then

tagCheck = True
Exit For

End If
Next

End Function
Sub search_test()

'変数の宣言
Dim i As Long
Dim strUrl As String
Dim sw As String
Dim sw2 As String
Dim htmlDoc As Object
Dim elPage As Object
Dim rc As VbMsgBoxResult
Dim elList As IHTMLElement
Dim elList2 As IHTMLElement
Dim colDiv As IHTMLElementCollection
Dim colDiv2 As IHTMLElementCollection
Dim el As IHTMLElement
Dim el2 As IHTMLElement
Dim elPre As IHTMLElement
Dim elPre2 As IHTMLElement

'検索結果シートを表示
Worksheets("検索結果").Activate

'入力シートの準備
Call DataClear
Call title
Call alignment

'IEを起動"食べログ"を表示
Set objIE = CreateObject("Internetexplorer.Application")

'rc = MsgBox("検索中状況を表示しますか？", vbYesNo + vbQuestion, "検索表示の選択")

'If rc = vbYes Then
'MsgBox "検索状況を表示して検索を開始します", vbInformation, "検索表示の選択"
objIE.Visible = True

'Else
'MsgBox "検索状況を非表示にして検索を開始します", vbInformation, "検索表示の選択"
'objIE.Visible = False

'End If

strUrl = "https://tabelog.com/"

objIE.navigate strUrl

Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop

'検索ワードを入力し検索
sw = "東京都" 'Worksheets("入力シート").Cells(4, 2).Value
sw2 = "焼肉" 'Worksheets("入力シート").Cells(4, 3).Value

Set htmlDoc = objIE.document

With htmlDoc

.getElementById("sa").Focus
.getElementById("sa").Value = sw

Sleep 1000

'地域の候補を取得
Set elList = htmlDoc.getElementById("ui-id-1")

Set colDiv = elList.Children

For Each el In colDiv

If el.getElementsByClassName("ui-corner-all") > 0 Then
'el.getElementsByClassName("ui-corner-all")(0).Click
Set elPre = el.getElementsByClassName("ui-corner-all")(0)
.getElementById("sa").Value = elPre.innerText
Exit For

End If
Next el

Sleep 1000

.getElementById("sk").Focus
.getElementById("sk").Value = sw2

Sleep 1000

'ジャンルの候補を取得
Set elList2 = htmlDoc.getElementById("ui-id-2")

Set colDiv2 = elList2.Children

For Each el2 In colDiv2

If el2.getElementsByClassName("ui-corner-all") > 0 Then

Set elPre2 = el2.getElementsByClassName("ui-corner-all")(0)
.getElementById("sk").Value = elPre2.innerText
Exit For

End If
Next el2

Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop

.getElementById("js-global-search-btn").Click

Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop

End With

Do While objIE.Busy = True Or objIE.readyState < READYSTATE_COMPLETE
DoEvents
Loop

End Sub
Sub img_List2()

Dim i As Long
Dim j As Long
Dim lastRow As Long
Dim imgURL As String
Dim folPass As String
Dim folName As String
Dim storFol As String
Dim fileName As String
Dim savePath As String
Dim docList As HTMLDocument
Dim cacheDel As Long
Dim result As Long

Call search_test

lastRow = Cells(Rows.Count, 9).End(xlUp).Row - 1

folPass = ActiveWorkbook.Path
folName = folPass & "\" & "image"

'既にnfolNameがあるかどうか確認
If Dir(folName, vbDirectory) = "" Then
'ない場合は作る
MkDir folName
'あるなら何もしない
Else: End If

For i = 0 To objIE.document.getElementsByClassName("list-rst__thumb-list").Length - 1

storFol = objIE.document.getElementsByClassName("list-rst__rst-name-target cpy-rst-name")(i).innerText

If Dir(folName & "\" & storFol & "\", vbDirectory) = "" Then
'ない場合は作る
MkDir folName & "\" & storFol & "\"
'あるなら何もしない
Else: End If

Set docList = Nothing
Set docList = objIE.document.getElementsByClassName("list-rst__thumb-list")(i)

'Debug.Print docList.outerHTML

For j = 0 To docList.document.getElementsByClassName("js-thumbnail-img js-cassette-img lazy-loaded").Length - 1
imgURL = docList.document.getElementsByClassName("js-thumbnail-img js-cassette-img lazy-loaded")(j).src
'Debug.Print docList.outerHTML
Debug.Print imgURL

'画像ファイル名
fileName = Mid(imgURL, InStrRev(imgURL, "/") + 1)

'画像保存先(+画像ファイル名）
savePath = folName & "\" & storFol & "\" & fileName 'ActiveWorkbook.Path & "\image\" & fileName

'キャッシュクリア
cacheDel = DeleteUrlCacheEntry(imgURL)

'画像ダウンロード
result = URLDownloadToFile(0, imgURL, savePath, 0, 0)

'If result = 0 Then
'MsgBox "ダウンロードできました"
'Else
'MsgBox "ダウンロードできませんでした"
'End If
Next

Next

objIE.Quit
End Sub

上のメッセージを削除します。
よければパスワードを入力し、削除ボタンをクリックしてください。