Email Embedded Microsoft Browser Map

G

Galius

New Member
Joined
Jul 27, 2018
Messages
30
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.

drive.google.com

Google Map Excel.xlsm

drive.google.com 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.
 
Sort by date Sort by votes
I'm just rereading your original post - you don't actually need it saved to an image file - is that right? You just need to embed it into an email? It might be worth just saving it as an image file anyway, but I thought I'd just check. Which email software do you use, out of curiosity? Do you have any particularly preference on image format?
 
Upvote 0

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Hi, this is a bit inelegant (with all the public variables, etc), but I wanted to get you something sooner rather than later.

I haven't tested it yet as thoroughly as I would like (that is to say, I haven't tested in on 32bit systems), but it should work for both 32bit and 64bit. I have only tested it on userforms as it transpires that in fact I can't get access to the WebBrowser control on my worksheet after all (but thank you for trying). Assuming that the webbrowser is still located on Sheet1 and is called WebBrowserMap, it should just be a matter of running the following test routine.

VBA Code: 
Sub TestRoutine()
    CaptureWindow Sheet1.WebBrowserMap
End Sub

This will output a BMP file called ImageCapture_YYMMDD-HHNNSS.BMP at directory D:\TEMP\. You can change the output directory by updating the following line:
VBA Code: 
Private Const BASEPATH              As String = "D:\TEMP"
Note that there is no \ at the end. I can update it so you can enter your own preferred filename, but lets first check to make sure that it works! Please remember to save all open Excel files before running this. Again, apologies for the delay. Fingers crossed.

Please copy the following into a new standard module. It's not critically important what it's called, but I propose calling it: modWindowCapture
VBA Code: 
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 VBA7 Then
        Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Long
        Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
        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 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
        Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
        
        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 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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
        Dim hDC As LongPtr, hDCMem As LongPtr, hBmp As LongPtr, hBmpOld As LongPtr, TargethWnd As LongPtr, hLib As LongPtr
    #Else
        Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
        Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
        Private Declare Function GetDC Lib "user32" (ByVal hWnd 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 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
        Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
        
        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 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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule 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)
   
     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
     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
         SavePicture IPic, BASEPATH & "\ImageCapture_" & Format(Now, "yymmdd-hhnnss") & ".bmp"
     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()
    
    Dim TargetRect As RECT, Result As Long
    
    GetWindowRect TargethWnd, TargetRect
    With TargetRect
        hDC = GetDC(0)
        hDCMem = CreateCompatibleDC(hDC)
        hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
        hBmpOld = SelectObject(hDCMem, hBmp)
        Result = BitBlt(hDCMem, 0, 0, .Right - .Left, .Bottom - .Top, hDC, .Left, .Top, VBSRCCOPY)
        hBmp = SelectObject(hDCMem, hBmpOld)
    End With
    
End Sub
 
Upvote 0
Solution
Dan_W said:
Hi, this is a bit inelegant (with all the public variables, etc), but I wanted to get you something sooner rather than later.

I haven't tested it yet as thoroughly as I would like (that is to say, I haven't tested in on 32bit systems), but it should work for both 32bit and 64bit. I have only tested it on userforms as it transpires that in fact I can't get access to the WebBrowser control on my worksheet after all (but thank you for trying). Assuming that the webbrowser is still located on Sheet1 and is called WebBrowserMap, it should just be a matter of running the following test routine.

VBA Code: 
Sub TestRoutine()
    CaptureWindow Sheet1.WebBrowserMap
End Sub

This will output a BMP file called ImageCapture_YYMMDD-HHNNSS.BMP at directory D:\TEMP\. You can change the output directory by updating the following line:
VBA Code: 
Private Const BASEPATH              As String = "D:\TEMP"
Note that there is no \ at the end. I can update it so you can enter your own preferred filename, but lets first check to make sure that it works! Please remember to save all open Excel files before running this. Again, apologies for the delay. Fingers crossed.

Please copy the following into a new standard module. It's not critically important what it's called, but I propose calling it: modWindowCapture
VBA Code: 
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 VBA7 Then
        Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Long
        Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
        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 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
        Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
       
        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 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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
        Dim hDC As LongPtr, hDCMem As LongPtr, hBmp As LongPtr, hBmpOld As LongPtr, TargethWnd As LongPtr, hLib As LongPtr
    #Else
        Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
        Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
        Private Declare Function GetDC Lib "user32" (ByVal hWnd 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 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
        Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
       
        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 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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule 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)
  
     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
     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
         SavePicture IPic, BASEPATH & "\ImageCapture_" & Format(Now, "yymmdd-hhnnss") & ".bmp"
     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()
   
    Dim TargetRect As RECT, Result As Long
   
    GetWindowRect TargethWnd, TargetRect
    With TargetRect
        hDC = GetDC(0)
        hDCMem = CreateCompatibleDC(hDC)
        hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
        hBmpOld = SelectObject(hDCMem, hBmp)
        Result = BitBlt(hDCMem, 0, 0, .Right - .Left, .Bottom - .Top, hDC, .Left, .Top, VBSRCCOPY)
        hBmp = SelectObject(hDCMem, hBmpOld)
    End With
   
End Sub
Click to expand...
Hey Dan,

This worked great on the sample sheet I attached! :)

For some reason though when I try and put it on the actual spreadsheet I want it added on though it's telling me Compile error: Method or data member not found. Even though the sheet is still Sheet1 and the browser is still called WebBrowserMap... Any ideas what could be causing that?
 
Upvote 0
Galius said:
Hey Dan,

This worked great on the sample sheet I attached! :)

For some reason though when I try and put it on the actual spreadsheet I want it added on though it's telling me Compile error: Method or data member not found. Even though the sheet is still Sheet1 and the browser is still called WebBrowserMap... Any ideas what could be causing that?
Click to expand...
Further to that I just added it to an entire new workbook as well and it worked fine... this is confusing why it won't work in the one I want it it too lol.
 
Upvote 0
Galius said:
Further to that I just added it to an entire new workbook as well and it worked fine... this is confusing why it won't work in the one I want it it too lol.
Click to expand...
Nevermind! I Figured it out! For some reason it was named Sheet1 on the tab but was named Sheet3 according to VBA.. Thanks so much Dan!
 
Upvote 0
Dan_W said:
Hi, this is a bit inelegant (with all the public variables, etc), but I wanted to get you something sooner rather than later.

I haven't tested it yet as thoroughly as I would like (that is to say, I haven't tested in on 32bit systems), but it should work for both 32bit and 64bit. I have only tested it on userforms as it transpires that in fact I can't get access to the WebBrowser control on my worksheet after all (but thank you for trying). Assuming that the webbrowser is still located on Sheet1 and is called WebBrowserMap, it should just be a matter of running the following test routine.

VBA Code: 
Sub TestRoutine()
    CaptureWindow Sheet1.WebBrowserMap
End Sub

This will output a BMP file called ImageCapture_YYMMDD-HHNNSS.BMP at directory D:\TEMP\. You can change the output directory by updating the following line:
VBA Code: 
Private Const BASEPATH              As String = "D:\TEMP"
Note that there is no \ at the end. I can update it so you can enter your own preferred filename, but lets first check to make sure that it works! Please remember to save all open Excel files before running this. Again, apologies for the delay. Fingers crossed.

Please copy the following into a new standard module. It's not critically important what it's called, but I propose calling it: modWindowCapture
VBA Code: 
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 VBA7 Then
        Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
        Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, ByRef lpRect As RECT) As Long
        Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
        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 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
        Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
       
        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 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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
        Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
        Dim hDC As LongPtr, hDCMem As LongPtr, hBmp As LongPtr, hBmpOld As LongPtr, TargethWnd As LongPtr, hLib As LongPtr
    #Else
        Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
        Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
        Private Declare Function GetDC Lib "user32" (ByVal hWnd 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 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
        Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
       
        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 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 LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
        Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule 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)
  
     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
     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
         SavePicture IPic, BASEPATH & "\ImageCapture_" & Format(Now, "yymmdd-hhnnss") & ".bmp"
     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()
   
    Dim TargetRect As RECT, Result As Long
   
    GetWindowRect TargethWnd, TargetRect
    With TargetRect
        hDC = GetDC(0)
        hDCMem = CreateCompatibleDC(hDC)
        hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
        hBmpOld = SelectObject(hDCMem, hBmp)
        Result = BitBlt(hDCMem, 0, 0, .Right - .Left, .Bottom - .Top, hDC, .Left, .Top, VBSRCCOPY)
        hBmp = SelectObject(hDCMem, hBmpOld)
    End With
   
End Sub
Click to expand...
One question, is there anyway to get it to print it all even if it all isn't visible on the screen? Right now it all has to be within view for it copy it properly.
 
Upvote 0
Might be able to use the clipboard - I would need to check, but basically, it would copy a designated object/range, and then convert the image stored on the clipboard to an image file. That might be one way of getting around the webbrowser control needing to be visible. There should be some code that does something similar on this site - let me check and will let you know.

But it's all working ok? That's a relief!
 
Upvote 0
Actually, I think I've done something (slightly) silly - try changing the GetImageOfObject with the following, and see if it works better:

VBA Code: 
Private Sub GetImageOfObject()
    
    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)
        Result = BitBlt(hDCMem, 0, 0, .Right - .Left, .Bottom - .Top, hDC, 0, 0, VBSRCCOPY)
        hBmp = SelectObject(hDCMem, hBmpOld)
    End With
    
End Sub
 
Upvote 0
Dan_W said:
Might be able to use the clipboard - I would need to check, but basically, it would copy a designated object/range, and then convert the image stored on the clipboard to an image file. That might be one way of getting around the webbrowser control needing to be visible. There should be some code that does something similar on this site - let me check and will let you know.

But it's all working ok? That's a relief!
Click to expand...
Thank you Dan :) Yeah it's all working great just need to see if it can do it while it isn't visible. Thanks so much.
 
Upvote 0
N
Dan_W said:
Actually, I think I've done something (slightly) silly - try changing the GetImageOfObject with the following, and see if it works better:

VBA Code: 
Private Sub GetImageOfObject()
   
    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)
        Result = BitBlt(hDCMem, 0, 0, .Right - .Left, .Bottom - .Top, hDC, 0, 0, VBSRCCOPY)
        hBmp = SelectObject(hDCMem, hBmpOld)
    End With
   
End Sub
Click to expand...
No luck, still only shows what is visible on the screen and all black below it.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Take screenshots & simultaneously capture the link, place it into an Excel file which is linked to a FileMaker/Claris db.
Replies
3
Views
358
Dan_W
D
D
  • Question Question
Fixing Macro on Yahoo Finance Historical Data
Replies
3
Views
788
sverrealbech
S
L
  • Question Question
How I edit my code VBA mapping Value and send output to a new column
Replies
3
Views
505
Fluff
Fluff
S
  • Question Question
Search Filter Mapping Matrix - via VBA code
2 3 4
Replies
30
Views
5K
ShuStar
S
D
  • Solved
Count total award value per unique supplier
Replies
4
Views
72
Fluff
Fluff

Forum statistics

Threads
1,223,236
Messages
6,170,915
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top