Screencapture in frm Webbrowser control (1 Viewer)

FAB1

Registered User.
Local time
Today, 16:54
Joined
Jul 27, 2007
Messages
40
Hi

I wanted to replicate google Screencapture app that you can get for the Chrome browser

Idea was to have 3 buttons on the webbrowsers frm
1. Copy & Save Visible area in Webbrowser
2. Copy & Save Highlighted area in Webbrowser
3. Copy & Save Full page in Webbrowser

Unfortunately practical the entire websites visited in the frms webbrowser control will feature dynamic content.

I got as far as getting the area of the control to the memory/clipboard

Next on the list
Convert to .jpg
Name & Save file from memory/clipboard
Import saved file/path to db

Any thoughts on Highlighted & FullPage capture?

Ta
Stewart

Quick sample attached (after capture open paint and Ctrl&V to see result)
Also code

PHP:
Option Compare Database
Option Explicit
'some declarations and comments for constants are from http://mvps.org/access/api/api0042.htm
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, 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 OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private 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
Private Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetTopWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal aint As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function apiGetFocus Lib "user32" Alias "GetFocus" () As Long
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const CF_BITMAP = 2 'A handle to a bitmap (HBITMAP)
Const CF_OEMTEXT = 7 'A handle to a text
Const SRCCOPY = &HCC0020 'Copies the source rectangle directly to the destination rectangle.
Const HWND_DESKTOP As Long = 0
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
'constants for GetSystemMetrics are from http://support.microsoft.com/kb/210603/en
Const SM_CYCAPTION = 4  ' Height of caption or title
Const SM_CXBORDER = 5   ' Width of window frame that cannot be sized
Const SM_CYBORDER = 6   ' Height of window frame that cannot be sized
Const SM_CXFRAME = 32   ' Width of window frame
Const SM_CYFRAME = 33   ' Height of window frame
Const SM_CXDLGFRAME = 7 ' Width of dialog frame window
Const SM_CYDLGFRAME = 8 ' Height of dialog frame window
Const RDW_ALLCHILDREN = &H80
Const RDW_UPDATENOW = &H100
Const GW_HWNDNEXT = 2
Const GW_HWNDPREV = 3
Const GW_CHILD = 5
Const MAXLEN = 255
'conversion functions are from http://support.microsoft.com/kb/94927/en
Private Function TwipsPerPixelX() As Single
Dim DC As Long
  DC = GetDC(HWND_DESKTOP)
  TwipsPerPixelX = 1440& / GetDeviceCaps(DC, LOGPIXELSX)
  ReleaseDC HWND_DESKTOP, DC
End Function
Private Function TwipsPerPixelY() As Single
Dim DC As Long
  DC = GetDC(HWND_DESKTOP)
  TwipsPerPixelY = 1440& / GetDeviceCaps(DC, LOGPIXELSY)
  ReleaseDC HWND_DESKTOP, DC
End Function
'BitBlt understanding is from http://support.microsoft.com/kb/147810
Public Function Img2Clp(oName$, oType$) As Boolean
Dim DC As Long, CompDC As Long, BMP As Long, _
h As Long, Wdth As Long, Hght As Long, tp As Long, _
lft As Long, o As Object, isRS As Boolean, h_new As Long, h_original As Long, i%, tmp_var As Variant
    If oType <> "control" Then
    If oType = "form" Then
        Set o = Forms(oName)
        isRS = o.RecordSelectors
        If isRS Then o.RecordSelectors = False
    Else
        Set o = Reports(oName)
    End If
    Wdth = o.WindowWidth / TwipsPerPixelX
    Hght = o.WindowHeight / TwipsPerPixelY
    Select Case o.BorderStyle
    Case 1 ' thin
        lft = -GetSystemMetrics(SM_CXBORDER) * 2
        Wdth = Wdth - GetSystemMetrics(SM_CXBORDER)
        Hght = Hght - GetSystemMetrics(SM_CYBORDER)
        tp = -GetSystemMetrics(SM_CYBORDER) * 2 - GetSystemMetrics(SM_CYCAPTION)
    Case 2 ' sizeable
        lft = -GetSystemMetrics(SM_CXFRAME) * 1.5
        Wdth = Wdth '- GetSystemMetrics(SM_CXFRAME)
        Hght = Hght '- GetSystemMetrics(SM_CYFRAME)
        tp = -GetSystemMetrics(SM_CYFRAME) * 1.5 - GetSystemMetrics(SM_CYCAPTION)
    Case 3 ' dialog
        lft = -GetSystemMetrics(SM_CXDLGFRAME)
        Wdth = Wdth '- GetSystemMetrics(SM_CXDLGFRAME)
        Hght = Hght '- GetSystemMetrics(SM_CYDLGFRAME)
        tp = -GetSystemMetrics(SM_CYDLGFRAME) - GetSystemMetrics(SM_CYCAPTION)
    End Select
    If oType = "form" Then o.RecordSelectors = isRS
    h = o.hwnd
    Else
        Set o = Screen.ActiveForm.Controls(oName)
        Wdth = o.Width / TwipsPerPixelX
        Hght = o.Height / TwipsPerPixelY
        h = fhWnd(o)
    End If
    tmp_var = ListMDIWindows
    For i = 0 To UBound(tmp_var)
        If tmp_var(i) = h Then
            h_new = tmp_var(0)
            If i = UBound(tmp_var) Then
                h_original = tmp_var(UBound(tmp_var))
            Else
                h_original = tmp_var(i - 1)
            End If
        End If
    Next i
    SetWindowPos h, h_new, lft, tp, Wdth, Hght, SWP_NOMOVE Or SWP_NOSIZE
    UpdateWindow Application.hWndAccessApp
    DC = GetDC(h)
    CompDC = CreateCompatibleDC(DC)
    BMP = CreateCompatibleBitmap(DC, Wdth, Hght)
    SelectObject CompDC, BMP
    BitBlt CompDC, 0&, 0&, Wdth, Hght, DC, lft, tp, SRCCOPY
    OpenClipboard h
    EmptyClipboard
    SetClipboardData CF_BITMAP, BMP
    CloseClipboard
    DeleteObject BMP
    DeleteDC CompDC
    ReleaseDC h, DC
    SetWindowPos h, h_original, lft, tp, Wdth, Hght, SWP_NOMOVE Or SWP_NOSIZE
    UpdateWindow Application.hWndAccessApp
End Function
'Access main window children searching is from http://social.msdn.microsoft.com/Forums/en-US/accessdev/thread/d7492ca6-b8f7-450e-862c-b1c847fee613 by Dirk Goldgar
Private Function fGetNextWindow(ByVal hwnd As Long) As Long
    fGetNextWindow = GetWindow(hwnd, GW_HWNDNEXT)
End Function
Private Function fGetClassName(hwnd As Long) As String
Dim strBuffer$, intCount%
    strBuffer = String$(MAXLEN - 1, 0)
    intCount = GetClassName(hwnd, strBuffer, MAXLEN)
    If intCount > 0 Then
        fGetClassName = Left$(strBuffer, intCount)
    End If
End Function
Private Function fGetCaption(hwnd As Long) As String
Dim strBuffer$, intCount$
    strBuffer = String$(MAXLEN - 1, 0)
    intCount = GetWindowText(hwnd, strBuffer, MAXLEN)
    If intCount > 0 Then
        fGetCaption = Left$(strBuffer, intCount)
    End If
End Function
Private Function ListMDIWindows() As Variant
Dim hWndAccess As Long, hWndWindow As Long, tmp_var As Variant, i%
    tmp_var = Array(0)
    i = 0
    ' Get Access application window.
    hWndAccess = hWndAccessApp
    ' Get that window's first child.
    hWndWindow = GetWindow(hWndAccess, GW_CHILD)
    ' Cycle through the direct children to find the MDI Client window.
    Do While hWndWindow <> 0
        If fGetClassName(hWndWindow) = "MDIClient" Then Exit Do
        hWndWindow = fGetNextWindow(hWndWindow)
    Loop
    If hWndWindow = 0 Then
        Debug.Print "Didn't find MDI Client!"
    Else
    ' Get the MDI Client window's first child.
        hWndWindow = GetWindow(hWndWindow, GW_CHILD)
    ' List this window and its children.
        Do While hWndWindow <> 0
            'Debug.Print hWndWindow, "Class = " & fGetClassName(hWndWindow), _
            "Caption = '" & fGetCaption(hWndWindow) & "'"
            tmp_var(i) = hWndWindow
            i = i + 1
            ReDim Preserve tmp_var(i)
            hWndWindow = fGetNextWindow(hWndWindow)
        Loop
    End If
    ListMDIWindows = tmp_var
End Function
Function fhWnd(ctl As Control) As Long
'This code sample was originally here http://access.mvps.org/access/api/api0027.htm
    On Error Resume Next
    ctl.SetFocus
    If Err Then
        fhWnd = 0
    Else
        fhWnd = apiGetFocus
    End If
    On Error GoTo 0
End Function
 

Attachments

  • ControlCaptureTest.accdb
    404 KB · Views: 419

FAB1

Registered User.
Local time
Today, 16:54
Joined
Jul 27, 2007
Messages
40
Anybody? 10 downloads and still not a bite
 

FAB1

Registered User.
Local time
Today, 16:54
Joined
Jul 27, 2007
Messages
40
Please anybody?
 

Users who are viewing this thread

Top Bottom