Option Explicit
'OutFile$:(IN):出力ファイル名(C:\TMP\a.txt等)
'BaseURL$:(IN):掲示板のURLで最後の/1-を除いたもの(https://dic.nicovideo.jp/b/a/c等)
'ST:(IN):抽出開始RES番号
'EN:(IN):抽出終了RES番号
Sub ExtractPic(OutFile$, BaseURL$, ST As Long, EN As Long) ' ここを呼ぶ
    Dim I30 As Long
    Dim S30 As Long
    Dim E30 As Long
    Dim FN As Long
    FN = FreeFile()
    S30 = Int((ST - 1) / 30) * 30 + 1
    E30 = Int((EN - 1) / 30) * 30 + 1
    Open OutFile$ For Output As #FN
    For I30 = S30 To E30 Step 30
        ExtractPicSub FN, BaseURL$ + "/" + Format(I30) + "/-", ST, EN
    Next
    Close #FN
End Sub

Sub ExtractPicSub(FN As Long, URL$, ST As Long, EN As Long)
    Dim I As Long
    Dim J As Long
    Dim objXML As New MSHTML.HTMLDocument
    Dim htmlDoc As New MSHTML.HTMLDocument
    Dim objITEM1 As Object
    Dim objITEM2 As Object
    Dim objITEM3 As Object
    Dim W$
    Dim ID$, TITLE$
    Dim ResNo
    Dim WI As Long, HI As Long
    Dim NH As Long
    Dim NW As Long
    Dim NHW As Long
    Const MAXH As Long = 128 '最大の高さ
    Const MAXW As Long = 128 '最大の幅

    Set htmlDoc = objXML.createDocumentFromUrl(URL$, vbNullString)
    Call untilReady(htmlDoc)
    
    For Each objITEM1 In htmlDoc.getElementsByTagName("DL")
        For Each objITEM2 In objITEM1.all
            If objITEM2.nodeName = "A" Then
                If objITEM2.Name <> "" Then
                    ResNo = Val(objITEM2.Name)
                End If
            ElseIf objITEM2.nodeName = "DD" Then
                For Each objITEM3 In objITEM2.all
                    If objITEM3.nodeName = "DIV" Then
                        W$ = objITEM2.innerText
                        I = InStrRev(W$, "タイトル:")
                        ID$ = objITEM3.ID
                        If I > 0 Then
                            I = I + 5
                            J = InStr(I, W$, vbCr)
                            If J > 0 Then
                                TITLE$ = Mid$(W$, I, J - I)
                            End If
                        End If
                    End If
                Next
            ElseIf objITEM2.nodeName = "IMG" Then
                If ST <= ResNo And ResNo <= EN Then
                    'WI$ = objITEM2.Width  なぜかこれだと0になる
                    'HI$ = objITEM2.Height なぜかこれだと0になる
                    W$ = objITEM2.outerHTML
                    I = InStrRev(W$, "height=")
                    If I > 0 Then
                        HI = Val(Mid$(W$, I + 7))
                        I = InStrRev(W$, "width=")
                        If I > 0 Then
                            WI = Val(Mid$(W$, I + 6))
                            If HI > MAXH Then
                                NH = -Int(-HI / MAXH)
                            Else
                                NH = 1
                            End If
                            If WI > MAXW Then
                                NW = -Int(-WI / MAXW)
                            Else
                                NW = 1
                            End If
                            If NH > NW Then
                                NHW = NH
                            Else
                                NHW = NW
                            End If
                            
                            Print #1, "<img title="""; Format(ResNo); ":"; TITLE$; """"; _
                               " alt="""; TITLE$; """"; _
                               " src=""/oekaki/"; Mid$(ID$, 7); ".png""";
                            Print #1, " width="; Format(Int(WI / NHW)); " height="; Format(Int(HI / NHW)); " />"
                        Else
                        End If
                    Else
                    End If
                End If
            End If
        Next
    Next
    Set objITEM1 = Nothing
    Set objITEM2 = Nothing
    Set objITEM3 = Nothing
    Set htmlDoc = Nothing
    Set objXML = Nothing
End Sub
Sub untilReady(htmlDoc As MSHTML.HTMLDocument, Optional ByVal WaitTime As Integer = 10)
    Dim starttime As Date
    starttime = Now()
    Do Until htmlDoc.ReadyState = "complete"
        DoEvents
        If Now() > DateAdd("S", WaitTime, starttime) Then
            Exit Do
        End If
    Loop
    DoEvents
End Sub