Go to Qiita Advent Calendar 2024 Top
LoginSignup
2
9

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 3 years have passed since last update.

@apoanzann(apoanzann)

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

Last updated at Posted at 2020-04-02

#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ページをキャプチャすることができます。

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

2
9
1

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
2
9

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?