【Word VBA】一括画像データをダウンロードし表示マクロ▽ソースコード

Option Explicit

Option Base 0

'

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _

    (ByVal pCaller As Long, ByVal pszURL As String, _

     ByVal pszFileName As String, ByVal dwReserved As Long, _

     ByVal plpfnCB As Long) As Long

Public Sub 一括画像データをダウンロードし表示マクロ()

    'ダウンロードＵＲＬ(作者のココナラブログ一覧)

    Const DLBSURL = "https://coconala.com/blogs/1197395"

    'ダウンロード格納ファイル名

    Const DLTMPFN = "Temp.txt"

    '対象画像拡張子

    Const DLFEXTN = ".png"

    '画像取出しキーワード

    Const DLFKEY1 = "<img src="""

    Const DLFKEY2 = DLFEXTN & """"

    '

    Const DLPCFNH = "PIC"

    'ダウンロードエラーメッセージ

    Const DLEMSG1 = "ダウンロードが出来ませんでした!!" & _

                    vbCrLf & vbCrLf

    '

    Const DLPCLEFT = 15　　　'描画開始位置Ｘ

    Const DLPCTOPP = 10　　　'　　　　　　Ｙ

    '

    Const DLPCWIDT = 50　　　'画像幅

    Const DLPCHEIG = 40　　　'画像高さ

    '

    Const DLPCVSPC = 10　　　'横余白

    Const DLPCHSPC = 10　　　'縦余白

    '

    Const DLPCCOLS = 6　　　'横/画像数

    '---------------------------------------------------------------------------

    Dim Ip As Integer, intGNo As Integer

    Dim lngCp1 As Long, lngCp2 As Long

    Dim lngCp3 As Long, lngCp4 As Long

    Dim lngCp5 As Long, lngRes As Long

    Dim strTFn As String, strTxt As String

    Dim strDat As String, strGFn As String

    Dim strFld As String

    '

    strFld = "X:\Downloads"　　　'←DownLoad Folder

    '==================================

    '*一覧ページをダウンロード

    '==================================

    strTFn = strFld & "\" & DLTMPFN

    lngRes = URLDownloadToFile(0, DLBSURL, strTFn, 0, 0)

    If lngRes <> 0 Then

       MsgBox DLEMSG1 & "(" & DLBSURL & ")", _

              vbCritical

       Exit Sub

    End If

    '==================================

    'ダウンロードしたファイルを一括読込み

    '==================================

    With CreateObject("ADODB.Stream")

        .Charset = "UTF-8":

        .Open

        .LoadFromFile strTFn: strTxt = .ReadText

        .Close

    End With

    '==================================

    'ダウンロードしたデータから画像ＵＲＬを取出し、

    '画像をダウンロード、文書に貼り付け

    '==================================

    lngCp1 = InStr(1, strTxt, DLFKEY1)

    intGNo = 0

    Do While lngCp1 > 0

       lngCp2 = InStr(lngCp1 + 1, strTxt, DLFKEY2)

       If lngCp2 <= 0 Then Exit Do

       lngCp3 = lngCp1 + Len(DLFKEY1)

       lngCp4 = lngCp2 + Len(DLFKEY2) - lngCp3 - 1

       '*画像ソース名抜き出し

       strDat = Mid(strTxt, lngCp3, lngCp4)

       '*ソース名内に<">があれば、スキップ

       lngCp5 = InStr(strDat, """")

       If lngCp5 > 0 Then

          lngCp1 = InStr(lngCp3 + lngCp5 + 1, strTxt, DLFKEY1)

       Else

          strGFn = strFld & "\" & DLPCFNH _

                 & Format(intGNo + 1, "000") & DLFEXTN

          '*画像をダウンロード

          lngRes = URLDownloadToFile(0, strDat, strGFn, 0, 0)

          If lngRes <> 0 Then

             MsgBox DLEMSG1 & "(" & strDat & ")", _

             vbCritical

             Exit Sub

          End If

          '*画像を文書に貼り付け

          Call ActiveDocument.Shapes.AddPicture(strGFn, _

               True, True, _

               DLPCLEFT + (DLPCWIDT + DLPCVSPC) _

               * (intGNo Mod DLPCCOLS), _

               DLPCTOPP + (DLPCHEIG + DLPCHSPC) _

               * (intGNo \ DLPCCOLS), _

               DLPCWIDT, DLPCHEIG)

          intGNo = intGNo + 1

          lngCp1 = InStr(lngCp2 + Len(DLFKEY2), strTxt, DLFKEY1)

       End If

    Loop

End Sub