VBA

#If Win64 Then
   Private Declare PtrSafe 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
#Else
   Private 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
#End If

Const BASE_PATH = "https://bbs.animanch.com/img/"

Sub HOGE()
GetImages "※保存したいフォルダ名※", "※スレッド番号※"

' サンプル
GetImages "C:\Downloads\あにまんch\テスト", "1526400"

End Sub

Sub GetImages(SaveDir As String, No As String, Optional MaxCnt As Long = 200)

   Dim URL As String
   Dim FileName As String
   Dim NotFoundImage As String

Dim var As Variant
Dim tmp As String

   If Dir(SaveDir, vbDirectory) = "" Then
       var = Split(SaveDir, "\")
       If Dir(var(0) & "\", vbDirectory) = "" Then
           Exit Sub
       End If

       tmp = var(0)
       If UBound(var) > 0 Then
           For i = 1 To UBound(var)
               tmp = tmp & "\" & var(i)
               If Dir(tmp, vbDirectory) = "" Then MkDir tmp
           Next i
       End If
   End If

   URL = BASE_PATH & No & "/0"
   FileName = No & "_" & Format(0, "000") & ".png"
   Call DownloadImage(URL, SaveDir, FileName)
   NotFoundImage = ReadBmpAsString(SaveDir & "\" & FileName)
   Kill SaveDir & "\" & FileName

   For i = 1 To MaxCnt
       URL = BASE_PATH & No & "/" & i
       FileName = No & "_" & Format(i, "000") & ".png"
       Call DownloadImage(URL, SaveDir, FileName)

       If ReadBmpAsString(SaveDir & "\" & FileName) = NotFoundImage Then
           Kill SaveDir & "\" & FileName
       End If

Next i

End Sub

Function DownloadImage(ByRef URL As String, ByRef SaveDir As String, ByRef FileName As String)

Dim SavePath As String
Dim res As Integer

SavePath = SaveDir & "\" & FileName

res = URLDownloadToFile(0, URL, SavePath, 0, 0)

End Function

Function ReadBmpAsString(file_name As String) As String

   Dim bmp() As Byte
   Open file_name For Binary As #1
       ReDim bmp(LOF(1))
       Get #1, , bmp
   Close #1

ReadBmpAsString = bmp

End Function

VBA

Report Page