vba to take a screen dump of an IE window already open

[cjcass]

Hi,
I'm looking for some code that will take a screen dump of an IE window that is already open and copy it to the clipboard. So, the code mimics me moving from Excel to the IE window (that is already open and maximised), doing a printscreen/copying the whole page, and then pasting it into the worksheet as a picture. It would be good if the code could reference the last IE window opened, if not possible then navigate to a specific opened URL, eg. http://www.google.com
Any help much appreciated.

 

[cjcass]

anyone have any ideas on this one?
thanks.

 

[Jaafar Tribak]

This should create a new instace of internet explorer, open MrExcel.com URL, copy the current viewable section of the page and paste it on the active sheet as a picture :

The code lacks error handling.

Code in a Standard Module :

Option Explicit

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If VBA7 Then
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal format As Long) As Long
    Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function EmptyClipboard Lib "user32" () As Long
    Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal format As Long) As Long
    Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

Const READYSTATE_INTERACTIVE = 3
Const READYSTATE_COMPLETE = 4
Const SWP_NOSIZE As Long = &H1&
Const SWP_NOMOVE As Long = &H2&
Const SWP_SHOWWINDOW = &H40
Const SW_SHOWMAXIMIZED = 3
Const HWND_TOPMOST = -1&
Const HWND_NOTOPMOST = -2
Const SRCCOPY = &HCC0020
Const CF_BITMAP = 2

Sub SaveIEToClipboard()
    #If VBA7 Then
        Dim hdcScreen As LongPtr, hdc As LongPtr, hbmp As LongPtr
    #Else
        Dim hdcScreen As Long, hdc As Long, hbmp As Long
    #End If
        Dim tRect As RECT, IE As Object
    
        Set IE = CreateObject("internetexplorer.application")
        IE.Visible = True
        IE.navigate "http://www.Mrexcel.com"
        Do While (IE.Busy Or IE.READYSTATE <> READYSTATE_COMPLETE): DoEvents: Loop
        ShowWindow IE.hwnd, SW_SHOWMAXIMIZED
        Call Sleep(2000)
        Call SetWindowPos(IE.hwnd, HWND_TOPMOST, 0&, 0&, 0&, 0&, SWP_NOSIZE Or SWP_NOMOVE Or SWP_SHOWWINDOW)
        Call GetClientRect(IE.hwnd, tRect)
        hdcScreen = GetDC(0)
        hdc = CreateCompatibleDC(hdcScreen)
        hbmp = CreateCompatibleBitmap(hdcScreen, tRect.Right - tRect.Left, tRect.Bottom - tRect.Top)
        Call SelectObject(hdc, hbmp)
        Call BitBlt(hdc, 0, 0, tRect.Right - tRect.Left, tRect.Bottom - tRect.Top, hdcScreen, tRect.Left, tRect.Top, SRCCOPY)
        Call SetWindowPos(IE.hwnd, HWND_NOTOPMOST, 0&, 0&, 0&, 0&, SWP_NOSIZE Or SWP_NOMOVE Or SWP_SHOWWINDOW)
        Call OpenClipboard(0)
        Call EmptyClipboard
        Call SetClipboardData(CF_BITMAP, hbmp)
        Call CloseClipboard
        Call DeleteDC(hdc)
        Call DeleteObject(hbmp)
        Call ReleaseDC(0, hdcScreen)
        If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
            ActiveSheet.Paste
        End If
End Sub

 

[cjcass]

Hi, thanks for responding.
That's a very big section of code, I was expecting a couple of lines!!
One thing though - I don't want to open a new instance of IE, I need the code to copy the last instance that's already open, or have the code find a url that is already open.
Thanks

 

[Jaafar Tribak]

Hi, thanks for responding.
That's a very big section of code, I was expecting a couple of lines!!
One thing though - I don't want to open a new instance of IE, I need the code to copy the last instance that's already open, or have the code find a url that is already open.
Thanks

Do you just have one instance of IE opened ? If so then you could reference it by using the VB(a) GetObject function .

 

[cjcass]

Hi, yes I can ensure only one instance is open

 

[cjcass]

what would the code be?

 

[John_w]

Do you just have one instance of IE opened ? If so then you could reference it by using the VB(a) GetObject function .

I don't think GetObject works with InternetExplorer. The function below loops through Shell.Windows, and returns the first IE window/tab it finds or a specified window/tab.

Add this code at the bottom of the module:

Private Function Get_IE_Window(Optional partialURLorName As String) As Object

    'Look for an IE browser window or tab already open at the specified (partial) URL or location name and, if found,
    'return that browser as an InternetExplorer object.  Otherwise return Nothing

    Dim Shell As Object
    Dim IE As Object
    Dim i As Variant 'Must be a Variant to index Shell.Windows.Item() array
    
    Set Shell = CreateObject("Shell.Application")
    
    i = 0
    Set Get_IE_Window = Nothing
    While i < Shell.Windows.Count And Get_IE_Window Is Nothing
        Set IE = Shell.Windows.Item(i)
        If Not IE Is Nothing Then
            If TypeName(IE) = "IWebBrowser2" And IE.LocationURL <> "" And InStr(IE.LocationURL, "file://") <> 1 Then
                If InStr(IE.LocationURL & IE.LocationName, partialURLorName) > 0 Then
                    Set Get_IE_Window = IE
                End If
            End If
        End If
        i = i + 1
    Wend
    
End Function

To use (instead of opening a new IE window) replace all the lines from Set IE =... to Do While ..., inclusive, with the following code:

    Set IE = Get_IE_Window()
    If IE Is Nothing Then
        MsgBox "Internet Explorer isn't open"
        Exit Sub
    End If

You can also specify a full or partial URL or location name as the argument to Get_IE_Window:

    Set IE = Get_IE_Window("mrexcel")

 

[Jaafar Tribak]

Hi John_w,

True.. GetObject won't work with IE because it doesn't regiter itsef in the ROT... Your soultion works well to get a com pointer to the existing IE instance based on the opened URL.

Would this "Shell" method also work with other browsers like Opera or Firefox ?

Thanks.

 

[cjcass]

Hi, thanks for coming back but this is confusing (probably due to my inexperience).
Currently there is no existing macro. I'm looking for a standalone macro that I can execute from a button that will take a screen dump of an IE window that is already open and copy it to the clipboard ready for it to be pasted into Excel as a picture. If we can assume that the url for the target window is http://www.wordle.net/compose (to be in the code) that would be great.
Any further help much appreciated.