Email Embedded Microsoft Browser Map

[Galius]

Hey Guys,

So I have a basic spreadsheet here where I put addresses and then click View Map and it'll load the map in an embedded Microsoft Web Browser ActiveX Control. All I want to do is right a script to basically screenshot that embedded map then paste it in an email to send.

Google Map Excel.xlsm

drive.google.com

I've uploaded the sheet to the google drive above. I tried posting images but it kept telling me too large even though they were only 250kb.

 

[Dan_W]

Can you post a sample image? The 'all black below it' bit is something I would expect from a userform - there would ordinarily be a black bar at the bottom, which represents the now missing titlebar of the userform. I wasn't entirely certain what would happen when it came to the webbrowser control though. Thanks.

 

[Dan_W]

Also, not sure if this will help with Google Maps, but might be worth giving it a try? Website Snapshots
It's an article (and code solution) I wrote for taking snapshots of webpages.

 

[Galius]

Can you post a sample image? The 'all black below it' bit is something I would expect from a userform - there would ordinarily be a black bar at the bottom, which represents the now missing titlebar of the userform. I wasn't entirely certain what would happen when it came to the webbrowser control though. Thanks.

Here's what it is doing right now. The part its actually showing is what is visible on the screen, rest below it isn't visible.

 

[Dan_W]

The whole thing might be less problematic if you were to use a userform instead of embedding it on the worksheet - you could still make it look like it was embedded on the worksheet, but it would in fact be hovering above it. But that still doesn't solve the 'needing to be visible when the image is captured' problem, I think. Can you talk me through what it is you're trying to accomplish exactly? I have a tendency of not asking enough questions, only to later discover that had I only inquired a bit more, I could've come up with a better/quicker solution, but taking a different approach....

 

[Galius]

The whole thing might be less problematic if you were to use a userform instead of embedding it on the worksheet - you could still make it look like it was embedded on the worksheet, but it would in fact be hovering above it. But that still doesn't solve the 'needing to be visible when the image is captured' problem, I think. Can you talk me through what it is you're trying to accomplish exactly? I have a tendency of not asking enough questions, only to later discover that had I only inquired a bit more, I could've come up with a better/quicker solution, but taking a different approach....

Basically I've got a ordering template that someone will enter all the values into including the address of the job and then I run a macro to take all that information and put it in an email to be sent to the supplier to order. What this map is supposed to do is take an image of the address and then paste that into email so the supplier can see the general area if they have a hard time finding the location.

 

[Dan_W]

Got it. Thanks. What software will you be sending it with, and what email software will it be viewed with? I ask because I'm wondering if there might be an easier solution that this approach. I'll give it some more thought on my way to work today - I feel like I might be missing something obvious, but right now, my immediate thought is that the browser needs to be visible in order for an image to be captured, but I will let you know where I get to on this.

 

[Galius]

Got it. Thanks. What software will you be sending it with, and what email software will it be viewed with? I ask because I'm wondering if there might be an easier solution that this approach. I'll give it some more thought on my way to work today - I feel like I might be missing something obvious, but right now, my immediate thought is that the browser needs to be visible in order for an image to be captured, but I will let you know where I get to on this.

Using outlook to send and assume outlook is on the other end they are viewing. I know I can make it work by moving to a new sheet where its all in view then screenshotting and moving back to the main sheet. Might end up just doing that.

 

[Dan_W]

So I think I may have solved it. I found a way of taking a capture of a given window (eg., the webbrowser control) even if it isn't visible at the time of the capture - that is to say, it is obscured by some other window. I have not tested to see whether or not it will work properly if the target window has been minimised, but I wouldn't expect it to, to be honest. The code below now includes the PrintWindow API, which is pretty handy.

I took the opportunity to adjust a bit of the code so that now you can opt to provide your own preferred filename for the output image (the second argument) when you call the main CaptureWindow routine. The third argument is a simple True/False switch that asks if the target window is visible. By default, this is set to True, but in you case you will want to change this to False. I have included a sample test routine to show how to go about using the code.

Based on what you said above about VBA confusing Sheet1 with Sheet3, etc, I have added some code below to point it to the webbrowser control (ActiveWorkbook.Sheets("Sheet1").WebBrowserMap), but you may need to adjust it:

Sub TestWindowCapture()
    
    Dim TargetFileName As String
    TargetFileName = "D:\MyImage_CaptureWindow_DanW2.BMP"
    If Len(Dir(TargetFileName)) > 0 Then Kill TargetFileName
        
    CaptureWindow ActiveWorkbook.Sheets("Sheet1").WebBrowserMap, TargetFileName, False

End Sub

Although there were only a few changes to the code, I'd suggest replacing the entirety of the code I posted above with the following. Please be sure to place it in a new standard module, and please remove the previous module from your project so as to avoid any potential conflicts with the legacy code.

Let me know how it goes...

    Option Explicit
    
    Private Type uPicDesc
       Size As Long
       type As Long
       #If VBA7 Then
            hPic As LongPtr
            hPal As LongPtr
       #Else
            hPic As Long
            hPal As Long
       #End If
    End Type
   
    Private Type GUID
       Data1 As Long
       Data2 As Integer
       Data3 As Integer
       Data4(0 To 7) As Byte
    End Type
   
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    
    #If Win64 Then
        Private 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
        Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
        Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
        Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
        Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
        Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, ByRef lpRect As RECT) As Long
        Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
        Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleaut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
        Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
        Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
        Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
        Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr

        Dim hDC As LongPtr, hDCMem As LongPtr, hBmp As LongPtr, hBmpOld As LongPtr, TargethWnd As LongPtr, hLib As LongPtr
    #Else
        Private 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
        Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
        Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
        Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
        Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
        Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
        Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
        Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
        Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
        Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function PrintWindow Lib "user32" (ByVal hwnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
        Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
        Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

        Dim hDC As Long, hDCMem As Long, hBmp As Long, hBmpOld As Long, TargethWnd As Long, hLib As Long
    #End If
 
    Private Const PICTYPE_BITMAP        As Long = &H1
    Private Const VBSRCCOPY             As Long = &HCC0020
    Private Const BASEPATH              As String = "D:\TEMP"
    
 Public Sub CaptureWindow(ByVal Target As Object, Optional ByVal Filename As String, Optional ByVal WindowVisible As Boolean = True)
   
     Dim IID_IPicture As GUID, uPicInfo As uPicDesc
     Dim IPic As IPicture, Result As Long
    
     On Error GoTo ErrHandler
     
     IUnknown_GetWindow Target, VarPtr(TargethWnd)
     If TargethWnd = 0 Then
        MsgBox "There was an error with the object that you're trying to screencapture. Please check the CaptureWindow argument and try again.", , "Problem with the target object"
        Exit Sub
     Else
        GetImageOfObject WindowVisible
     End If
     
     With IID_IPicture
         .Data1 = &H7BF80981
         .Data2 = &HBF32
         .Data3 = &H101A
         .Data4(0) = &H8B
         .Data4(1) = &HBB
         .Data4(3) = &HAA
         .Data4(5) = &H30
         .Data4(6) = &HC
         .Data4(7) = &HAB
     End With
     
     With uPicInfo
         .Size = Len(uPicInfo)
         .type = PICTYPE_BITMAP
         .hPic = hBmp
         .hPal = 0
     End With
     
     hLib = LoadLibrary("oleAut32.dll")
     If hLib Then
         Result = OleCreatePictureIndirectAut(uPicInfo, IID_IPicture, True, IPic)
     Else
         Result = OleCreatePictureIndirectPro(uPicInfo, IID_IPicture, True, IPic)
     End If
     
     If Not Result Then
        If Len(Filename) = 0 Then Filename = BASEPATH & "\ImageCapture_" & Format(Now, "yymmdd-hhnnss") & ".bmp"
        SavePicture IPic, Filename
     End If
       
ErrHandler:
    FreeLibrary hLib
    DeleteObject hBmp
    DeleteDC hDCMem
    ReleaseDC TargethWnd, hDC
    If Err.Number <> 0 Then MsgBox Err.Number & ": " & Err.Description, , "Error"
    
End Sub

Private Sub GetImageOfObject(Optional ByVal WindowVisible As Boolean = True)
    
    Dim TargetRect As RECT, Result As Long
    
    GetWindowRect TargethWnd, TargetRect
    
    With TargetRect
        hDC = GetDC(TargethWnd)
        hDCMem = CreateCompatibleDC(hDC)
        hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
        hBmpOld = SelectObject(hDCMem, hBmp)
        If WindowVisible Then
            Result = BitBlt(hDCMem, 0, 0, .Right - .Left, .Bottom - .Top, hDC, .Left, .Top, VBSRCCOPY)
        Else
            PrintWindow TargethWnd, hDCMem, False
        End If
        hBmp = SelectObject(hDCMem, hBmpOld)
    End With
    
End Sub

 

[Galius]

So I think I may have solved it. I found a way of taking a capture of a given window (eg., the webbrowser control) even if it isn't visible at the time of the capture - that is to say, it is obscured by some other window. I have not tested to see whether or not it will work properly if the target window has been minimised, but I wouldn't expect it to, to be honest. The code below now includes the PrintWindow API, which is pretty handy.

I took the opportunity to adjust a bit of the code so that now you can opt to provide your own preferred filename for the output image (the second argument) when you call the main CaptureWindow routine. The third argument is a simple True/False switch that asks if the target window is visible. By default, this is set to True, but in you case you will want to change this to False. I have included a sample test routine to show how to go about using the code.

Based on what you said above about VBA confusing Sheet1 with Sheet3, etc, I have added some code below to point it to the webbrowser control (ActiveWorkbook.Sheets("Sheet1").WebBrowserMap), but you may need to adjust it:

Sub TestWindowCapture()
   
    Dim TargetFileName As String
    TargetFileName = "D:\MyImage_CaptureWindow_DanW2.BMP"
    If Len(Dir(TargetFileName)) > 0 Then Kill TargetFileName
       
    CaptureWindow ActiveWorkbook.Sheets("Sheet1").WebBrowserMap, TargetFileName, False

End Sub

Although there were only a few changes to the code, I'd suggest replacing the entirety of the code I posted above with the following. Please be sure to place it in a new standard module, and please remove the previous module from your project so as to avoid any potential conflicts with the legacy code.

Let me know how it goes...

    Option Explicit
   
    Private Type uPicDesc
       Size As Long
       type As Long
       #If VBA7 Then
            hPic As LongPtr
            hPal As LongPtr
       #Else
            hPic As Long
            hPal As Long
       #End If
    End Type
  
    Private Type GUID
       Data1 As Long
       Data2 As Integer
       Data3 As Integer
       Data4(0 To 7) As Byte
    End Type
  
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
   
    #If Win64 Then
        Private 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
        Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
        Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
        Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
        Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
        Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, ByRef lpRect As RECT) As Long
        Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
        Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleaut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
        Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
        Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
        Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
        Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr

        Dim hDC As LongPtr, hDCMem As LongPtr, hBmp As LongPtr, hBmpOld As LongPtr, TargethWnd As LongPtr, hLib As LongPtr
    #Else
        Private 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
        Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
        Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
        Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
        Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
        Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
        Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
        Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
        Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
        Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
        Private Declare Function PrintWindow Lib "user32" (ByVal hwnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
        Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
        Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long

        Dim hDC As Long, hDCMem As Long, hBmp As Long, hBmpOld As Long, TargethWnd As Long, hLib As Long
    #End If
 
    Private Const PICTYPE_BITMAP        As Long = &H1
    Private Const VBSRCCOPY             As Long = &HCC0020
    Private Const BASEPATH              As String = "D:\TEMP"
   
 Public Sub CaptureWindow(ByVal Target As Object, Optional ByVal Filename As String, Optional ByVal WindowVisible As Boolean = True)
  
     Dim IID_IPicture As GUID, uPicInfo As uPicDesc
     Dim IPic As IPicture, Result As Long
   
     On Error GoTo ErrHandler
    
     IUnknown_GetWindow Target, VarPtr(TargethWnd)
     If TargethWnd = 0 Then
        MsgBox "There was an error with the object that you're trying to screencapture. Please check the CaptureWindow argument and try again.", , "Problem with the target object"
        Exit Sub
     Else
        GetImageOfObject WindowVisible
     End If
    
     With IID_IPicture
         .Data1 = &H7BF80981
         .Data2 = &HBF32
         .Data3 = &H101A
         .Data4(0) = &H8B
         .Data4(1) = &HBB
         .Data4(3) = &HAA
         .Data4(5) = &H30
         .Data4(6) = &HC
         .Data4(7) = &HAB
     End With
    
     With uPicInfo
         .Size = Len(uPicInfo)
         .type = PICTYPE_BITMAP
         .hPic = hBmp
         .hPal = 0
     End With
    
     hLib = LoadLibrary("oleAut32.dll")
     If hLib Then
         Result = OleCreatePictureIndirectAut(uPicInfo, IID_IPicture, True, IPic)
     Else
         Result = OleCreatePictureIndirectPro(uPicInfo, IID_IPicture, True, IPic)
     End If
    
     If Not Result Then
        If Len(Filename) = 0 Then Filename = BASEPATH & "\ImageCapture_" & Format(Now, "yymmdd-hhnnss") & ".bmp"
        SavePicture IPic, Filename
     End If
      
ErrHandler:
    FreeLibrary hLib
    DeleteObject hBmp
    DeleteDC hDCMem
    ReleaseDC TargethWnd, hDC
    If Err.Number <> 0 Then MsgBox Err.Number & ": " & Err.Description, , "Error"
   
End Sub

Private Sub GetImageOfObject(Optional ByVal WindowVisible As Boolean = True)
   
    Dim TargetRect As RECT, Result As Long
   
    GetWindowRect TargethWnd, TargetRect
   
    With TargetRect
        hDC = GetDC(TargethWnd)
        hDCMem = CreateCompatibleDC(hDC)
        hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
        hBmpOld = SelectObject(hDCMem, hBmp)
        If WindowVisible Then
            Result = BitBlt(hDCMem, 0, 0, .Right - .Left, .Bottom - .Top, hDC, .Left, .Top, VBSRCCOPY)
        Else
            PrintWindow TargethWnd, hDCMem, False
        End If
        hBmp = SelectObject(hDCMem, hBmpOld)
    End With
   
End Sub

Thanks Dan. I tried the above and still producing the same effect of cutting off what isn't visible.

 

[Dan_W]

Ok, I really need to see exactly what's happening because I've tried this on 22 different non-visible windows/window handles, and they all worked, so I'm at a bit of a loss.

Can you please show me:
(1) a full screen capture of the webbrowser control in the worksheet in Excel;
(2) the image that you want to have output at the end of it; and
(3) the images that you're instead getting (through methods #1, #2, and now #3) (i.e., the 'failures').

i suspect that something else is causing the problems, but I can't quite think what it might be. Thanks.