VBA(Excel)でWebページをPDF化,PNG化,JPG化する方法

-概要-
業務でよく使うことがあったので作りました。

Seleniumは、簡単にブラウザ操作を自動化するようなツールです。
よく聞くのは、PythonやJavaScriptでSeleniumをつかう方法ですが、実はVisualBasicで動かすことができます。

特に、日本ではExcelへの依存度が高い企業が多いと思うので、GUIとしてExcelを用いることは心理的抵抗がないのではないでしょうか？（いろいろ言いたいことはあると思いますが...）

-手順-
1.Selenium Releaseから、SeleniumBasicをダウンロードする。
2.上のファイルをインストールする。
3.必要なブラウザにあったドライバをダウンロードする。（今回は、Chromeにします）
Chrome Driver
4.C:\Users[ユーザ名]\AppData\Local\SeleniumBasicのchromedriver.exeを3でダウンロードしたchromedriver.exeで更新する。（ファイル上書きするだけ）
5.vbaを書く

-詳説-
1.2.URL等は変わるかもしれません。各自調べてください。デフォルトでインストールすれば大丈夫です。
3.ここも、URLは変わるかもしれません。各自調べてください。Chromeの場合は、ご自身の使っているChromeのバージョンと同じバージョンをダウンロードしてきてください。
4.置き換えるだけです。
5.

4まで行うと、Excel 開発環境でツール->参照設定でSelenium Type Libraryが出てくるのでチェックしましょう。これをしないとSeleniumが使えないです。あと、Microsoft Scripting Runtime等の参照設定もチェックしてください。

以下,例です。
to~ (保存先ディレクトリ、保存ファイル名、WebページURL、シートの行番号(確認用にチェックとか保存ディレクトリの書き込みする用に)、保存できたか管理するシート)

PDF用

Option Explicit

Sub toPDF(ByVal directory, ByVal filename, ByVal url, ByVal i, ByVal sheetn As String)
  On Error GoTo myerror:
    Dim sheet1 As Worksheet
    Set sheet1 = Sheets(sheetn)
    Dim sPath As String, WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    sPath = WSH.SpecialFolders("Desktop") & "\"
    If (directory = "") Then directory = sPath
    If (Right(directory, 1) <> "\") Then directory = directory & "\"
    If (filename = "") Then filename = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
    Dim savepath As String
    savepath = directory & filename & ".pdf"
    Dim driver As New Selenium.ChromeDriver
    driver.SetPreference "download.default_directory", directory
    driver.SetPreference "download.directory_upgrade", True
    driver.SetPreference "download.prompt_for_download", False
    driver.SetPreference "safebrowsing.enabled", True
    driver.SetPreference "plugins.plugins_disabled", Array("Chrome PDF Viewer")
    driver.AddArgument "headless"
    driver.AddArgument "disable-gpu"
    driver.AddArgument "hide-scrollbars"
    Dim w As Long
    Dim h As Long

    driver.Start
    driver.Get url

    w = driver.ExecuteScript("return document.body.scrollWidth")
    h = driver.ExecuteScript("return document.body.scrollHeight")

    Dim pdf As Object

    driver.Window.SetSize w, h

    Set pdf = CreateObject("Selenium.PdfFile")
    pdf.SetPageSize 210, 297, "mm"
    pdf.AddImage driver.TakeScreenshot, True
    pdf.SaveAs savepath
    sheet1.Cells(i, 5).Value = 1
    sheet1.Cells(i, 6).Value = savepath
    driver.Quit
    Exit Sub
myerror:
    MsgBox "no"
    sheet1.Cells(i, 5).Value = 0
End Sub
Sub dopdf()
  Dim sPath As String, WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    sPath = WSH.SpecialFolders("Desktop") & "\"
    Dim directory As String
    Dim filename As String
    directory = sPath
    If (Right(Len(directory), 1) <> "\") Then directory = directory & "\"

  Dim sheet1 As String
  Dim i As Long

  sheet1 = "pdf用"

  Dim sheetn As Worksheet
  Set sheetn = Sheets(sheet1)
  Dim r As Long
  r = sheetn.Cells(Rows.Count, 4).End(xlUp).Row
  For i = 2 To r
    If (sheetn.Cells(i, 4).Value = "") Then
      GoTo a1:
    End If
    filename = sheetn.Cells(i, 3).Text
    If (filename = "") Then filename = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
    Dim result
    result = Dir(sheetn.Cells(i, 2).Text, vbDirectory)
    If (directory <> "" Or result <> True) Then sPath = sheetn.Cells(i, 2).Text
    Call toPDF(sPath, filename, sheetn.Cells(i, 4).Text, i, sheet1)
a1:
  Next i
End Sub

JPG用

Option Explicit

Sub toJPG(ByVal directory, ByVal filename, ByVal url, ByVal i, ByVal sheetn As String)
  On Error GoTo myerror:
    Dim sheet1 As Worksheet
    Set sheet1 = Sheets(sheetn)
    Dim sPath As String, WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    sPath = WSH.SpecialFolders("Desktop") & "\"
    If (directory = "") Then directory = sPath
    If (Right(directory, 1) <> "\") Then directory = directory & "\"
    If (filename = "") Then filename = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
    Dim savepath As String
    savepath = directory & filename & ".jpg"
    Dim driver As New Selenium.ChromeDriver
    driver.SetPreference "download.default_directory", directory
    driver.SetPreference "download.directory_upgrade", True
    driver.SetPreference "download.prompt_for_download", False
    driver.SetPreference "safebrowsing.enabled", True
    driver.SetPreference "plugins.plugins_disabled", Array("Chrome PDF Viewer")
    driver.AddArgument "headless"
    driver.AddArgument "disable-gpu"
    driver.AddArgument "hide-scrollbars"
    Dim w As Long
    Dim h As Long

    driver.Start
    driver.Get url
    driver.FindElementByClass("tab02").Click
    driver.ExecuteScript ("this.document.getElementById('tab01').setAttribute('class','tabContent01');")
    driver.ExecuteScript ("this.document.getElementById('tab03').setAttribute('class','tabContent03');")
    w = driver.ExecuteScript("return document.body.scrollWidth")
    h = driver.ExecuteScript("return document.body.scrollHeight")
    driver.Window.SetSize w, h
    driver.TakeScreenshot.SaveAs savepath
    sheet1.Cells(i, 5).Value = 1
    sheet1.Cells(i, 6).Value = savepath
    driver.Quit
    Exit Sub
myerror:

    sheet1.Cells(i, 5).Value = 0
End Sub
Sub dojpg()
  Dim sPath As String, WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    sPath = WSH.SpecialFolders("Desktop") & "\"
    Dim directory As String
    Dim filename As String
    directory = sPath
    If (Right(Len(directory), 1) <> "\") Then directory = directory & "\"

  Dim sheet1 As String
  Dim i As Long

  sheet1 = "jpg用"

  Dim sheetn As Worksheet
  Set sheetn = Sheets(sheet1)
  Dim r As Long
  r = sheetn.Cells(Rows.Count, 4).End(xlUp).Row
  For i = 2 To r
    If (sheetn.Cells(i, 4).Value = "") Then
      GoTo a1:
    End If
    filename = sheetn.Cells(i, 3).Text
    If (filename = "") Then filename = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
    Dim result
    result = Dir(sheetn.Cells(i, 2).Text, vbDirectory)
    If (directory <> "" Or result <> True) Then sPath = sheetn.Cells(i, 2).Text
    Call toJPG(sPath, filename, sheetn.Cells(i, 4).Text, i, sheet1)
a1:
  Next i
End Sub

PNG用

Option Explicit

Sub toPNG(ByVal directory, ByVal filename, ByVal url, ByVal i, ByVal sheetn As String)
  On Error GoTo myerror:
    Dim sheet1 As Worksheet
    Set sheet1 = Sheets(sheetn)
    Dim sPath As String, WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    sPath = WSH.SpecialFolders("Desktop") & "\"
    If (directory = "") Then directory = sPath
    If (Right(directory, 1) <> "\") Then directory = directory & "\"
    If (filename = "") Then filename = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
    Dim savepath As String
    savepath = directory & filename & ".png"
    Dim driver As New Selenium.ChromeDriver
    driver.SetPreference "download.default_directory", directory
    driver.SetPreference "download.directory_upgrade", True
    driver.SetPreference "download.prompt_for_download", False
    driver.SetPreference "safebrowsing.enabled", True
    driver.SetPreference "plugins.plugins_disabled", Array("Chrome PDF Viewer")
    driver.AddArgument "headless"
    driver.AddArgument "disable-gpu"
    driver.AddArgument "hide-scrollbars"
    Dim w As Long
    Dim h As Long

    driver.Start
    driver.Get url
    driver.FindElementByClass("tab02").Click
    driver.ExecuteScript ("this.document.getElementById('tab01').setAttribute('class','tabContent01');")
    driver.ExecuteScript ("this.document.getElementById('tab03').setAttribute('class','tabContent03');")
    w = driver.ExecuteScript("return document.body.scrollWidth")
    h = driver.ExecuteScript("return document.body.scrollHeight")
    driver.Window.SetSize w, h
    driver.TakeScreenshot.SaveAs savepath
    sheet1.Cells(i, 5).Value = 1
    sheet1.Cells(i, 6).Value = savepath
    driver.Quit
    Exit Sub
myerror:

    sheet1.Cells(i, 5).Value = 0
End Sub
Sub dopng()
  Dim sPath As String, WSH As Variant
    Set WSH = CreateObject("WScript.Shell")
    sPath = WSH.SpecialFolders("Desktop") & "\"
    Dim directory As String
    Dim filename As String
    directory = sPath
    If (Right(Len(directory), 1) <> "\") Then directory = directory & "\"

  Dim sheet1 As String
  Dim i As Long

  sheet1 = "png用"

  Dim sheetn As Worksheet
  Set sheetn = Sheets(sheet1)
  Dim r As Long
  r = sheetn.Cells(Rows.Count, 4).End(xlUp).Row
  For i = 2 To r
    If (sheetn.Cells(i, 4).Value = "") Then
      GoTo a1:
    End If
    filename = sheetn.Cells(i, 3).Text
    If (filename = "") Then filename = Format(Now(), "yyyy-mm-dd-hh-mm-ss")
    Dim result
    result = Dir(sheetn.Cells(i, 2).Text, vbDirectory)
    If (directory <> "" Or result <> True) Then sPath = sheetn.Cells(i, 2).Text
    Call toPNG(sPath, filename, sheetn.Cells(i, 4).Text, i, sheet1)
a1:
  Next i
End Sub

ブック構成は、"pdf用","png用","jpg用"シート3つです。

B,C,D列2行目以降に
保存先、保存名,URLを入れて
マクロを動かすと保存されます。

ちなみに、driver.executescirpts等で、DOM操作もできるので、WebページをいじってからそのWebページをキャプチャすることができます。

眠い。。。
また、写真とか後からつけます。

VBA(Excel)でWebページをPDF化,PNG化,JPG化する方法(Selenium Basic)

VBA(Excel)でWebページをPDF化,PNG化,JPG化する方法

JPG用

PNG用