投稿動画一覧から動画URI・サムネイルURI・タイトルを持ってくる

もう1か所参考にしたサイトがあったんだけど、ちょっと失念。
思い出したら追記する。

テーブルはT_YouTube
項目は以下3フィールド
サムネイル画像
URI
タイトル

以下、標準モジュールに記述

'http://www.vba-ie.net/qanda/qanda.cgi?mode=viewthread&id=112


Option Compare Database

#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

Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Sub IEfind()

Dim ie As Object
Dim hwnd As Long
Dim dcall As HTMLDocument
Dim fLoop As Boolean
Dim htd As IHTMLElementCollection
Dim sId As String
Dim i As Long
Dim dOpen As Date
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim el() As HTMLDocument


hwnd = FindWindow("IEFrame", vbNullString)
For Each ie In CreateObject("Shell.Application").Windows()
If hwnd = ie.hwnd Then



If ie.StatusBar = False Then ie.StatusBar = True

ie.statusText = CStr(hwnd) '---(1)
If ie.statusText = CStr(hwnd) Then Exit For
End If
Next

If IsEmpty(ie) Then
MsgBox "Not Found"
fLoop = False
Else
sId = Split(ie.LocationURL, "/")(4)
Debug.Print sId
  fLoop = True
End If


  Dim timeOut As Date

  timeOut = Now + TimeSerial(0, 0, 20)

  Do While ie.Busy = True Or ie.ReadyState <> 4
    DoEvents
    Sleep 1
    If Now > timeOut Then
      ie.Refresh
      timeOut = Now + TimeSerial(0, 0, 20)
    End If
  Loop

  timeOut = Now + TimeSerial(0, 0, 20)

  Do While ie.Document.ReadyState <> "complete"
    DoEvents
    Sleep 1
    If Now > timeOut Then
      ie.Refresh
      timeOut = Now + TimeSerial(0, 0, 20)
    End If
   Loop

  

  Set db = CurrentDb
  Set rs = db.OpenRecordset("T_Youtube")
  
    
  For i = 0 To ie.Document.getElementsByClassName("yt-lockup-dismissable").length - 1
  
  With ie.Document.getElementsByClassName("yt-lockup-dismissable")(i)
        
    rs.AddNew
    rs.Fields(0) = .getElementsByTagName("img")(0).getAttribute("src")
    rs.Fields(1) = .getElementsByTagName("a")(0).getAttribute("href")
    rs.Fields(2) = .getElementsByTagName("h3")(0).getElementsByTagName("a")(0).innerText '.getElementsByTagName("h3")(0).innerText '⇒これやると視聴履歴とか再生時間とかも持ってきちゃう
    rs.Update
  End With
    
  Next i
  
  DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "Q_出力用", CurrentProject.Path & "\" & sId & "_YouTube動画一覧" & Format(Now(), "yymmddhhmmss") & ".xlsx", True
  
  'Stop



End Sub

Public Function getImgURI(sURI As String) As String
  getImgURI = Split(sURI, "?")(0)

End Function

以下、メインフォームに記述(ボタンは1個だけ)

Private Sub btn_Click()
  If MsgBox( _
  "以下、事前準備が完了しているか確認してください。" & vbCrLf & _
  "・取得対象となるユーザの動画画面(https://www.youtube.com/user/[ユーザ名]/videos)をInternetExplorerで開いていること" & vbCrLf & _
  "・「もっと読み込む」ボタンが表示されなくなるまで押下し、すべてのアイテムが表示されていること" & vbCrLf & _
  "・上記タブがアクティブになっていること", vbOKCancel + vbDefaultButton2 + vbExclamation, "取得開始前に確認してください。") = vbCancel Then Exit Sub
  
  DoCmd.SetWarnings False
  DoCmd.RunSQL "DELETE * FROM T_Youtube;"
  DoCmd.SetWarnings True
  Call IEfind

  
  MsgBox "T_YouTubeに動画情報を格納しました。"
  
  
End Sub

以下、クエリQ_出力用

SELECT getImgURI([サムネイル画像]) AS サムネイルURI, "https://www.youtube.com" & [URI] AS 動画URI, T_YouTube.[タイトル]
FROM T_YouTube;