投稿‎ > ‎

FireFoxのPage Saverアドオンを利用して、画面イメージをExcelに自動取込

posted Dec 21, 2014, 4:45 PM by Zhang Wenxu   [ updated Dec 21, 2014, 4:46 PM ]
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


Comments