2. キーボードショートカットを設定する。例：Ctrl＋F12

3. 画像ファイルの保存場所を指定する。

4. ファイル名はページタイトルとして、同じ名前のファイルがある時は上書きするのチェックボックスを有効にする。

5. Excelマクロ

Const FIREFOX_TITLE = " - Mozilla Firefox"

Const IMG_FOLDER = "D:/work/images" 'ステップ3指定したフォルダー

Const MAX_RETRY = 20

Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Public Sub PrintScreen4Firefox()

  Dim wnd As Long

  Dim title As String

  Dim fso As FileSystemObject

  Dim filename as String

  Dim img

  Dim height As Long

  Dim f As File

  Dim timestamp As Date

  Dim cnt As Integer

  Dim reg As RegExp

  Dim printAreaBottomRow As Integer

  Set reg = New RegExp

  Set fso = New FileSystemObject

  AppActivate FIREFOX_TITLE

  Sleep 50

  wnd  = GetForegroundWindow()

  title = GetTitle(wnd)

  title = left(title, Lne(title) - Len(FIREFOX_TITLE))

  timestamp = Now

  SendKeys "^{F12}"  'ステップ2設定したショートカットキー

  

  Sleep 2500

  title = Replace(title, "/", "-")

  filename = title & ".png"

  cnt = 1

READ_FILE:

  DoEvents

  cnt = cnt + 1

  If cnt > MAX_RETRY Then

    MsgBox "イメージを取れませんでした。", vbOKOnly, "エラー"

    Exit Sub

  End If

  

  If hasFile(IMG_FOLDER, filename) Then

    Set f = getFile(IMG_FOLDER, filename)

    If f.DateLastModified <  timestamp Then

      Sleep 500

      GoTo READ_FILE

    End If

    Set img = ActiveSheet.Pictures.Insert(IMG_FOLDER & filename)

    img.ShapeRange.ScaleHeight 1, msoTrue, msoScaleFromTopLeft

    height = img.height

    With img

       .CopyPicture

       .Delete

    End With

    ActiveSheeet.Paste

  Else

    Sleep 500

    GoTo READ_FILE

  End If

  If ActiveSheet.Pictures.Count > 1 Then

     ActiveSheet.HPageBreak.Add before:=ActiveCell

  Else

     Application.PrintCommunication = False

     With ActiveSheet.PageSetup

        .PrintTitleRows = ""

        .PrintTitleColumns = ""

        .LeftHeader = ""

        .CenterHeader = ""

        .RightHeader = ""

        .LeftFooter = ""

        .CenterFooter = ""

        .RightFooter = ""

        .LeftMargin = Application.InchesToPoints(0m7)

        .RightMargin = Application.InchesToPoints(0.7)

        .TopMargin = Application.InchesToPoints(0.748)

        .BottomMargin = Application.InchesToPoints(0.748)

        .HeaderMargin = Application.InchesToPoints(0.31)

        .FooterMargin = Application.InchesToPoints(0.31)

        .PrintHeadings = False

        .PrintGridlines = False

        .PrintComments = xlPrintNoComments

        .PrintQuality = 600

        .CenterHorizontally = False

        .CenterVertically = False

        .Orientation = xlPortrait

        .Draft = False

        .PaperSize = xlPaperA4

        .FirstPageNumber = xlAutomatic

        .Order = xlDownThenOver

        .BlackAndWhite = False

        .Zoom = False

        .FitToPagesWide = 1

        .FitToPagesTall = False

        .PrintErrors = xlPrintErrorsDisplayed

        .OddAndEvenPagesHeaderFooter = False

        .DifferentFirstPageHeaderFooter = False

        .ScaleWithDocHeaderFooter = True

        .AlignMarginsHeaderFooter = True

        .EvenPage.LeftHeader.text = ""

        .EvenPage.CenterHeader.text = ""

        .EvenPage.RightHeader.text = ""

        .EvenPage.LeftFooter.text = ""

        .EvenPage.CenterFooter.text = ""

        .EvenPage.RightFooter.text = ""

        .FirstPage.LeftHeader.text = ""

        .FirstPage.CenterHeader.text = ""

        .FirstPage.RightHeader.text = ""

        .FirstPage.LeftFooter.text = ""

        .FirstPage.CenterFooter.text = ""

        .FirstPage.RightFooter.text = ""

      End With

      Application.PrintCommunication = True

      ActiveWindow.View = xlPageBreakPreview

      ActiveWindow.Zoom = 85

    End If

    height = ActiveSheet.Pictures(ActiveSheet.Pictures.Count).height

    Cells(ActiveCell.row + height / rows(1).height + 1, ActiveCell.Column).Select

    

    If ActiveSheet.PageSetup.PrintArea <> "" Then

       reg.Pattern = "¥d*$"

       printAreaBottomRow = reg.Execute(ActiveSheet.PageSetup.PrintArea)(0)

       If ActiveCell.row > printAreaBottomRow Then

          ActiveSheet.PageSetup.PrintArea = reg.Replace(ActiveSheet.PageSetup.PrintArea, ActiveCell.row)

       End If

    End If

End Sub

Public Function hasFile(dir As String, filename As String) As Boolean

  Dim fld As Folder

  Dim fso As FileSystemObject

  Dim f As File

  Set fso = New FileSystemObject

  Set fld = fso.getFolder(dir)

  For Each f In fld.Files

     If f.name = filename Then

        hasFile = True

        Exit Function

     End If

  Next

  hasFile = False

End Function

Public Function getTitle(hwnd As Long) As String

  Dim ret As Long

  Dim leng As Long

  Dim name As String

  

  name = String(255, Chr(0))

  leng = Len(name)

  ret = GetWindowTex(hwnd, name, leng)

  If ret <> 0 Then

    getTitle = left(name, InStr(1, name, vbNullChar) - 1)

  End If

End Function