指定したURLの画像をChromeで取得しExcelに貼り付ける

久しぶりにVBAを触ってみたので

個人的な備忘録として掲載します。

↓プログラム実行前

↓プログラム実行後

覚え書き程度なので詳細は省きます。

大体わかるように書いたつもりですが…

Option Explicit

'------------------------------------------------------------------------------
' Win32 API関数・定数の宣言
'------------------------------------------------------------------------------
#If VBA7 And Win64 Then '64bit

Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _
    ByVal dwMilliseconds As Long) As Long

Declare PtrSafe Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

#Else '32bit

Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, _
　　ByVal dwMilliseconds As Long) As Long

Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
　　ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

#End If

Private Const PROCESS_ALL_ACCESS As Long = &H1F0FFF
Private Const INFINITE As Long = &HFFFF

Private Const C_MAX_COL = 10
Private Const C_MAX_ROW = 10

Private imgFol1 As String
Private imgFol2 As String
Private wsSrc As Worksheet

'====================================================================
' 機能:　　 セルに記載しているURLの画像を取得し貼り付ける
'
' 戻値:　　 なし
'
' 機能説明: メイン処理
'
' 備考:　　 この処理を呼び出せば実行される。
'
'====================================================================
Sub Main()
Dim iCol As Integer
Dim iRow As Integer
Dim strCell As String

On Error GoTo Catch
    '画面の更新停止
    Application.ScreenUpdating = False
    'マウスカーソルを処理中にする
    Application.Cursor = xlWait
     
    Set wsSrc = Worksheets(1)
    
    '初期化
    Call InitMain
    
    'セルを巡回(とりあえず、10×10の範囲)
    For iCol = 1 To C_MAX_COL
        For iRow = 1 To C_MAX_ROW
            strCell = wsSrc.Cells(iRow, iCol)
            
            If Left(strCell, 4) = "http" Then
                        
                Call GamennCapture(iRow, iCol, strCell)
                        
            End If
           
        Next iRow
    Next iCol
    
    
    MsgBox "処理を終了しました。", vbInformation
Finally:
On Error Resume Next
    
    '後始末
    Set wsSrc = Nothing
    
    'マウスカーソルをデフォルトに戻す
    Application.Cursor = xlDefault
    '画面の更新停止解除
    Application.ScreenUpdating = True
    Exit Sub
Catch:
On Error Resume Next

Dim msg As String

    msg = "エラー発生アプリ: " & Err.Source & vbCrLf & _
            "エラー番号: " & Err.Number & vbCrLf & _
            "エラー内容: " & Err.Description & vbCrLf
    MsgBox msg, vbCritical
    
    GoTo Finally

End Sub

'====================================================================
' 機能:　　 処理前の初期化処理
'
' 戻値:　　 なし
'
' 機能説明: 画像保存フォルダの確認と処理対象エクセルシートの図形削除
'
' 備考:　　 先にwsSrcオブジェクトを作っておく
'
'====================================================================
Function InitMain()
Dim Fso As FileSystemObject

    Set Fso = New FileSystemObject
    
    'シート上の図形全削除
    wsSrc.Shapes.SelectAll
    Selection.Delete
  
    imgFol1 = ThisWorkbook.Path & "\images\"
    imgFol2 = ThisWorkbook.Path & "\images\resize\"
    
    'パスの存在確認
    CheckDir (imgFol1)
    CheckDir (imgFol2)
    
    'ファイル削除
    Call Fso.DeleteFile(imgFol1 & "*", True) ' すべてのファイルを削除
    Call Fso.DeleteFile(imgFol2 & "*", True) ' すべてのファイルを削除

    ' 後始末
    Set Fso = Nothing
    
    
End Function

'====================================================================
' 機能:　　 指定したパスの存在確認
'
' 引数:　　 targetPath 確認するパス
'
' 機能説明: 指定したパスの存在確認（存在しなければ新規作成する）
'
' 備考:
'
'====================================================================
Function CheckDir(targetPath As String)

    '画像の保存先のパスを確認して、なければ作成する
    If Dir(targetPath, vbDirectory) = "" Then
        MkDir targetPath
    End If

End Function

'====================================================================
' 機能:　　 画面のキャプチャ処理
'
' 引数:　　 RowIdx 行位置　ColIdx　列位置
'           targetURL 画像取得するURL
'
' 機能説明: 指定したパスの存在確認（存在しなければ新規作成する）
'
' 備考:     ブラウザは、Chrome固定にしている。
'
'====================================================================
Function GamennCapture(RowIdx As Integer, ColIdx As Integer, targetURL As String)
Dim cmd As String
Dim dt As String
Dim imgFileName1 As String
Dim imgFileName2 As String
Dim task_id As Long
Dim h_proc As Variant
    
    dt = Format(Now(), "yyyymmddhhmmss")
    imgFileName1 = imgFol1 & dt & ".png"
    imgFileName2 = imgFol2 & dt & ".png"
    
    'Chromeで画面のハードコピー
    cmd = ""
    cmd = cmd & "c:\Program Files (x86)\Google\Chrome\Application\chrome.exe"
    cmd = cmd & " --headless"
    cmd = cmd & " --disable-gpu"
    cmd = cmd & " --hide-scrollbars"
    cmd = cmd & " --screenshot=" & imgFileName1
    cmd = cmd & " --window-size=1920,1080"
    cmd = cmd & " " & targetURL
    task_id = Shell(cmd, vbHide)
    h_proc = OpenProcess(PROCESS_ALL_ACCESS, False, task_id)
    
    '処理終了待ち
    If OpenProcess(PROCESS_ALL_ACCESS, False, task_id) <> vbNull Then
        Call WaitForSingleObject(h_proc, INFINITE)
        CloseHandle h_proc
    End If
    DoEvents
        
    'ファイルのリサイズ（縮小）
    If Dir(imgFileName1) <> "" Then
        Call resizeImage(imgFileName1, imgFol2, 0.5)
    End If
    'URL記載セルに画像挿入
    If Dir(imgFileName2) <> "" Then
        Call InsertPNG(RowIdx, ColIdx, imgFileName2)
    End If

End Function

'====================================================================
' 機能:　　 画像ファイルのリサイズ
'
' 引数:　　 srcImgPath リサイズする画像のパス
'           destFolderPath 　リサイズしたファイルの保存先
'           resizeRatio リサイズする倍率 1→100% 例　0.5→50%縮小
'
' 機能説明: 画像を縮小して保存
'
' 備考:
'
'====================================================================
Function resizeImage(srcImgPath As String, destFolderPath As String, resizeRatio As Single)
Dim Fso As FileSystemObject
Dim srcImgName As String
Dim outImgName As String
Dim outImgPath As String
Dim Img As WIA.ImageFile
Dim oriWidth As Long
Dim oriHeight As Long
Dim newWidth As Long
Dim newHeight As Long
Dim ImgProcess As WIA.ImageProcess

    Set Fso = New FileSystemObject
    Set Img = New WIA.ImageFile
    Set ImgProcess = New WIA.ImageProcess
    
    srcImgName = Fso.GetFileName(srcImgPath)
    outImgName = srcImgName
    outImgPath = destFolderPath & "\" & outImgName
    
    If Fso.FileExists(outImgPath) Then
        Fso.DeleteFile (outImgPath)
    End If

    Img.LoadFile (srcImgPath)
    oriWidth = Img.Width
    oriHeight = Img.Height
    newWidth = oriWidth * resizeRatio
    newHeight = oriHeight * resizeRatio
 
    ImgProcess.Filters.Add (ImgProcess.FilterInfos("Scale").FilterID)
    ImgProcess.Filters(1).Properties("MaximumWidth").Value = newWidth
    ImgProcess.Filters(1).Properties("MaximumHeight").Value = newHeight
    ImgProcess.Filters(1).Properties("PreserveAspectRatio").Value = True
 
    Set Img = ImgProcess.Apply(Img)
    Img.SaveFile (outImgPath)
    
    '後始末
    Set Fso = Nothing
    Set Img = Nothing
    Set ImgProcess = Nothing

End Function

'====================================================================
' 機能:　　 画像の挿入
'
' 引数:　　 RowIdx　行位置　ColIdx　列位置
'           targetImg　挿入する画像ファイルのパス
'
' 機能説明: 画像を挿入（位置は、URL記載のセル　画像幅は、セルに合わせる）
'
' 備考:
'
'====================================================================
Function InsertPNG(RowIdx As Integer, ColIdx As Integer, targetImg As String)

    With ActiveSheet.Pictures.Insert(targetImg)
        .Top = Cells(RowIdx, ColIdx).Top
        .Left = Cells(RowIdx, ColIdx).Left
        .Width = Cells(RowIdx, ColIdx).Width
    End With

End Function