vba 如何使用VBA截取网页截图？

How to take screenshot of webpage using VBA?

提问by user3174245

How to take screenshot of webpage using VBA in Excel? The problem is that screenshots can be taken only by pressing F6 key of keyboard since Screenhunter is used for this purpose. The print screen key is disabled.

如何在Excel中使用VBA截取网页截图？问题是屏幕截图只能通过按键盘的 F6 键进行，因为 Screenhunter 用于此目的。打印屏幕键被禁用。

I used the following code but realised that sendkey function can not be used:

我使用了以下代码，但意识到无法使用 sendkey 功能：

sub test()

    application.sendkeys "{F6}"

end sub

回答by user3174245

I have added some delay after maximizing the screen, created a Word Doc and pasted the screen shot in it. The rest of the code is taken from the link which Siddharth has provided.

我在最大化屏幕后添加了一些延迟，创建了一个 Word Doc 并将屏幕截图粘贴到其中。其余代码取自 Siddharth 提供的链接。

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)

Private Const VK_SNAPSHOT As Byte = 44

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Const SW_SHOWMAXIMIZED = 3
Private Const VK_LCONTROL As Long = &HA2
Private Const VK_V = &H56
Private Const KEYEVENTF_KEYUP = &H2

Sub Sample()
    Dim IE As Object
    Dim hwnd As Long, IECaption As String

    Set IE = CreateObject("InternetExplorer.Application")

    IE.Visible = True

    IE.Navigate "www.Google.com"

    Sleep 5000

    '~~> Get the caption of IE
    IECaption = "Google - Internet Explorer"

    '~~> Get handle of IE
    hwnd = FindWindow(vbNullString, IECaption)

    If hwnd = 0 Then
        MsgBox "IE Window Not found!"
        Exit Sub
    Else
        '~~> Maximize IE
        ShowWindow hwnd, SW_SHOWMAXIMIZED
    End If
Sleep 3000
    DoEvents

    '~~> Take a snapshot
    Call keybd_event(VK_SNAPSHOT, 0, 0, 0)

    '~~> Start Word


    Set wordobj = CreateObject("Word.Application")

   Set objDoc = wordobj.Documents.Add

   wordobj.Visible = True

   Set objSelection = wordobj.Selection

   'Paste into Word
   objSelection.Paste

End Sub

回答by ashleedawg

This worked for me when I needed to create thumbnail images of several sites.

当我需要创建多个站点的缩略图时，这对我有用。

While not "elegant", it does the job, and I think it's pretty self-explanatory.

虽然不是“优雅”，但它可以完成工作，而且我认为这是不言自明的。

Option Explicit
'requires references: "Microsoft HTML Object Library" & "Microsoft Internet Controls"

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
    ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function ShowWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Sub getSS()
  Const url = "stackoverflow.com" 'page to get screenshot of (http is added below)
  Const fName = "x:\thumb_" & url & ".png" 'output filename (can be png/jpg/bmp/gif)
  Const imgScale = 0.25 'scale to 25% (to create thumbnail)

  Dim ie As InternetExplorer, ws As Worksheet, sz As Long
  Dim img As Picture, oCht As ChartObject
  Set ws = ThisWorkbook.Sheets("Sheet1")
  Set ie = GetIE()
  With ie
    .navigate "http://" & url
    Do: DoEvents: Loop While .busy Or .readyState <> 4 'wait for page load
    ShowWindow .hwnd, 5 'activate IE window
    Call keybd_event(44, 0, 0, 0) '44="VK_SNAPSHOT"
    Pause (0.25) 'pause so clipboard catches up
    With ws
      ShowWindow Application.hwnd, 5 'back to Excel
      .Activate
      .Paste
      Set img = Selection
      With img
        Set oCht = ws.ChartObjects.Add(.Left, .Top, .Left + .Width, .Top + .Height)
        oCht.Width = .Width * imgScale 'scale obj to picture size
        oCht.Height = .Height * imgScale
        oCht.Activate
        ActiveChart.Paste
        ActiveChart.Export fName, Mid(fName, InStrRev(fName, ".") + 1)
        oCht.Delete
        .Delete
      End With
      .Activate
    End With
    .FullScreen = False
    .Quit
  End With
  If Dir(fName) = "" Then Stop 'Something went wrong (file not created)
  sz = FileLen(fName)
  If sz = 0 Then Stop 'Something went wrong! (invalid filename maybe?)
  Debug.Print "Created '" & fName & "' from '" & url & "' (" & sz & " bytes)": Beep
End Sub

Sub Pause(sec As Single)
  Dim t As Single: t = Timer
  Do: DoEvents: Loop Until Timer > t + sec
End Sub

Function GetIE() As Object
'requires references: "Microsoft HTML Object Library" & "Microsoft Internet Controls"
'return an object for the open Internet Explorer window, or create new one
  For Each GetIE In CreateObject("Shell.Application").Windows() 'Loop to find
    If (Not GetIE Is Nothing) And GetIE.Name = "Internet Explorer" Then Exit For 'Found!
  Next GetIE
  If GetIE Is Nothing Then Set GetIE=CreateObject("InternetExplorer.Application") 'Create
  GetIE.Visible = True 'Make IE visible
  GetIE.FullScreen = True
End Function