1. Page Saverアドオンをインストール 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 getFile(dir As String, filename As String) As File 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 Set getFile = f Exit Function End If Next Set getFile = Nothing 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 |
投稿 >