Capture Any Browser [Windows]

[RASHAD]

Tested with IE8, Firefox 19.1 & Opera
Windows XP x86,Win 7 x64

Support multiple images in one session
The captured images in your Home Folder

Other browsers can be added

Code: Select all

Prototype printwindow(hwnd,hdc,flag)
Global printwindow.printwindow,Class$

lib = OpenLibrary(0,"User32.dll")
If lib
  printwindow = GetFunction(0,"PrintWindow")
EndIf   

Procedure GetHandle()
  hWnd = GetWindow_(GetDesktopWindow_(),#GW_CHILD)
  Repeat
    Class$ = Space(#MAX_PATH)
    GetClassName_(hWnd,@Class$,#MAX_PATH)
    If  (Class$ = "IEFrame" Or Class$ = "MozillaWindowClass" Or Class$ = "OperaWindowClass") And IsWindowVisible_(hWnd) = 1
      Finhwnd = hWnd
    Else
      hWnd = GetWindow_(hWnd,#GW_HWNDNEXT)
    EndIf
  Until hWnd=0 Or Finhwnd <> 0
  ProcedureReturn Finhwnd
EndProcedure

OpenWindow(0,0,0,300,200,"Capture Any Browser",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
ButtonGadget(0,10,160,60,30,"Capture")

Repeat
  Select WaitWindowEvent()
      
      Case #PB_Event_CloseWindow
            If lib
                CloseLibrary(0)
            EndIf   
            Quit = 1
      
      Case #PB_Event_Gadget
          Select EventGadget()
            Case 0 
                hWnd = GetHandle()
                If hWnd 
                    If IsIconic_(hWnd)
                        ShowWindow_(hWnd,#SW_RESTORE)
                        Flag =1
                    EndIf 
                    
                    GetWindowRect_(hWnd,r.RECT) 
                    hBitmap = CreateImage(0,r\right-r\left,r\bottom-r\top)
                    hdc = StartDrawing(ImageOutput(0))
                    PrintWindow(hwnd,hdc,0)
                    StopDrawing()
                    DeleteDC_(hdc)
                    Delay(200)
                    
                    SaveImage(0,GetHomeDirectory() + Class$+" "+Str(n)+".bmp",#PB_ImagePlugin_BMP)
                    n+1
                    If Flag = 1
                      ShowWindow_(hWnd,#SW_MINIMIZE	)
                    EndIf
                EndIf           
          EndSelect
  EndSelect 

Until Quit = 1
End

Edit :Code Modified

[idle]

you could also use PrintWindow so it will get the content even if it's covered
but it won't get it if the window is minimized

Code: Select all

Prototype printwindow(hwnd,hdc,flag)
Global printwindow.printwindow

lib = OpenLibrary(0,"User32.dll")
If lib 
  printwindow = GetFunction(0,"PrintWindow")
EndIf    

Procedure GetHandle(Wtext$)
  hWnd = GetWindow_(GetDesktopWindow_(),#GW_CHILD)
  Repeat
    Text$ = Space(#MAX_PATH)
    GetWindowText_(hWnd,@Text$,#MAX_PATH)
    If FindString(LCase(Text$), LCase(Wtext$),1) <>0 And IsWindowVisible_(hWnd) = 1
      Finhwnd = hWnd
    Else
      hWnd = GetWindow_(hWnd,#GW_HWNDNEXT)
    EndIf
  Until hWnd=0 Or Finhwnd <> 0
  ProcedureReturn Finhwnd
EndProcedure
;
For browser = 1 To 2
   Read.s Browser$ 
   hWnd = GetHandle(Browser$)
   If hWnd <> 0
      Break
   EndIf
Next
 

GetWindowRect_(hWnd,r.RECT)  
hBitmap = CreateImage(0,r\right-r\left,r\bottom-r\top)
hdc = StartDrawing(ImageOutput(0))
PrintWindow(hwnd,hdc,0)
StopDrawing()
DeleteDC_(hdc)              
Delay(200)

SaveImage(0,GetHomeDirectory() + "Image.bmp",#PB_ImagePlugin_BMP)

If lib 
  CloseLibrary(0)
EndIf   

DataSection
   Data.s "Explorer","Fire"
EndDataSection

[RASHAD]

First post modified

[IdeasVacuum]

Looks very interesting Rashad!

[Kwai chang caine]

Thanks at you two

The code of IDLE works great , but the code of RASHAD give sometime to me the half of the browxser in black

The top of the top will be, if the full browser can be capturing (With auto scrolling)
But perhaps, it's impossible with this method ??

[davido]

I have tested idle's code with FireFox version 20.0 and it works very well.

I have also tried RASHAD's code but this only produces a black screen!

Windows 7/64bit with PB5.11/64bit.

[RASHAD]

KCC & davido
Check the first post again
I just added Delay(200)

The capture engine is the same for both posts
I just changed how to get the handle of the browser because it did not work with Opera

[Kwai chang caine]

Sometime that works, sometime no

I believe i have found when that not works...but i'm not sure

With IE, if you open two webbrowser, and you put one under the other, sometime one of the picture is half black

[davido]

Hi RASHAD:

Works fine now.

Thank you, very much.

[IdeasVacuum]

KCC: I think that's because of how the loop in GetHandle() finds the browser Window. If there is more than one browser on screen, it's better to have the User pick the one to be captured. Especially true if the User has both FireFox and ThunderBird because their class names are the same, so you expect to get an image of your browser but instead you might get an image of your email app

Rashad: I didn't get to test your original code. The PrintWindow method seems limited to the size of the screen, so for most web pages only a % is captured, which was the bit I was trying to figure out as an 'auto scroll' solution.

[Kwai chang caine]

Thanks IdeasVacuum for your explanation

[RASHAD]

Using Kiffi code

- Press right-mouse-click in the Browser URL Edit
- Select the URL
- Paste it in the StringGadget
- Press Capture
- Repeat the previous steps for each web change

Tested with Explorer,FireFox & Opera
It should work with all the other browsers

Code: Select all

UsePNGImageEncoder()

Global sURL.s,imgn

Enumeration
  #WinSnapShot
  #WebSnapShot
EndEnumeration

  #DVASPECT_CONTENT  = 1
  #DVASPECT_THUMBNAIL = 2
  #DVASPECT_ICON = 4
  #DVASPECT_DOCPRINT = 8


Procedure CaptureWebPage(URL$, WBWidth.i, WBHeight.i, Filename.s)
;----------------------------------------------------------------

  Define.IWebBrowser2   m_pWebBrowser

  Define.IHTMLDocument2 pDocument
  Define.IHTMLDocument3 pDocument3
  Define.IHTMLElement   pElement
  Define.IHTMLElement2  pElement2
  Define.iDispatch      pDispatch
  Define.IViewObject2   pViewObject

  Define.i bodyHeight
  Define.i bodyWidth
  Define.i rootHeight
  Define.i rootWidth

  Define.RECT rcBounds

  Define.i bolFlag
  Define.i IsBusy
  Define.i hr

  bolFlag = #False

  If OpenWindow(#WinSnapShot, 0, 0, 0, 0, "", #PB_Window_Invisible | #PB_Window_BorderLess)

      WebGadget(#WebSnapShot, 0, 0, 0, 0, URL$)

      Repeat
        If GetGadgetAttribute(#WebSnapShot, #PB_Web_Busy) = 0
          Break
        EndIf

        While WindowEvent(): Delay(1) : Wend
      ForEver

      m_pWebBrowser = GetWindowLongPtr_(GadgetID(#WebSnapShot), #GWL_USERDATA)

         hr = m_pWebBrowser\get_document(@pDispatch)
      If hr = #S_OK

        If pDispatch

             hr = pDispatch\QueryInterface(?IID_IHTMLDocument2, @pDocument)
          If hr = #S_OK

            If pDocument

                 hr = pDocument\get_body(@pElement)
              If hr = #S_OK
                If pElement

                     hr = pElement\QueryInterface(?IID_IHTMLElement2, @pElement2)
                  If hr = #S_OK
                    If pElement2

                         hr = pElement2\get_scrollHeight(@bodyHeight)
                      If hr = #S_OK
                          ;Debug "bodyHeight: " + Str(bodyHeight)

                           hr = pElement2\get_scrollWidth(@bodyWidth)
                        If hr = #S_OK
                            ;Debug "bodyWidth: " + Str(bodyWidth)

                             hr = pDispatch\QueryInterface(?IID_IHTMLDocument3, @pDocument3)
                          If hr = #S_OK

                            If pDocument3

                                 hr = pDocument3\get_documentElement(@pElement)
                              If hr <> #S_OK : ProcedureReturn #False : EndIf

                                 hr = pElement\QueryInterface(?IID_IHTMLElement2, @pElement2)
                              If hr <> #S_OK : ProcedureReturn #False : EndIf

                                 hr = pElement2\get_scrollHeight(@rootHeight)
                              If hr <> #S_OK : ProcedureReturn #False : EndIf
                                ;Debug "rootHeight: " + Str(rootHeight)

                                 hr = pElement2\get_scrollWidth(@rootWidth)
                              If hr <> #S_OK : ProcedureReturn #False : EndIf
                                 ;Debug "rootWidth: " + Str(rootWidth)

                              Define.i width
                              Define.i height
                                                         width = bodyWidth
                              If rootWidth > bodyWidth : width = rootWidth : EndIf

                                                           height = bodyHeight
                              If rootHeight > bodyHeight : height = rootHeight : EndIf

                              width + 22

                              ResizeGadget(#WebSnapShot, 0, 0, width, height)

                              hr = m_pWebBrowser\QueryInterface(?IID_IViewObject2, @pViewObject)

                              If hr = #S_OK

                                If pViewObject

                                  Define.i hdcMain

                                     hdcMain = GetDC_(0)
                                  If hdcMain

                                    Define.i hdcMem

                                       hdcMem  = CreateCompatibleDC_(hdcMain)
                                    If hdcMem

                                      Define.i hBitmap

                                         hBitmap = CreateCompatibleBitmap_(hdcMain, width, height)
                                      If hBitmap

                                        Define.i oldImage

                                        oldImage = SelectObject_(hdcMem, hBitmap)

                                        rcBounds\top = 0
                                        rcBounds\left = 0
                                        rcBounds\right = width
                                        rcBounds\bottom = height

                                        pViewObject\Draw(#DVASPECT_CONTENT, -1, 0, 0, hdcMain, hdcMem, rcBounds, 0, 0, 0)

                                        Define.i Image

                                           Image = CreateImage(#PB_Any, width, height)
                                        If Image

                                          Define.i img_hDC

                                               img_hDC = StartDrawing(ImageOutput(Image))
                                            If img_hDC

                                              BitBlt_(img_hDC, 0, 0, width, height, hdcMem, 0, 0, #SRCCOPY)
                                            StopDrawing()

                                            SaveImage(Image,Filename,#PB_ImagePlugin_PNG)
                                            bolFlag = #True

                                          EndIf ; img_hDC

                                          FreeImage(Image)

                                        EndIf ; Image

                                        SelectObject_(hdcMem, oldImage)

                                      EndIf ; hBitmap

                                      DeleteDC_(hdcMem)

                                    EndIf ; hdcMem

                                    ReleaseDC_(0, hdcMain)

                                  EndIf ; hdcMain

                                  pViewObject\Release()

                                EndIf ; pViewObject
                              EndIf; HR

                              pDocument3\Release()

                            EndIf ; pDocument3

                          EndIf ; HR

                        EndIf ; HR

                      EndIf ; HR

                      pElement2\Release()

                    EndIf ; pElement2

                  EndIf ; HR

                  pElement\Release()

                EndIf ; pElement

              EndIf ; HR

              pDocument\Release()

            EndIf ; pDocument

          EndIf ; HR

          pDispatch\Release()

        EndIf ; pDispatch

      EndIf ; HR

      CloseWindow(#WinSnapShot)

  EndIf

  ProcedureReturn bolFlag

EndProcedure

Procedure Snapshot()
;-------------------

  ;Define sURL.s
  Define sFileOut.s
  Define sNow.s

      ;sURL = "http://www.purebasic.fr/english/"
  ;sFileOut = ReplaceString(sURL, ".", "_")

      ;sNow = FormatDate("_%yyyy_%mm_%dd_%hh_%ii_%ss", Date())

  ExamineDesktops()
   sFileOut = GetHomeDirectory()+"web_image_"+Str(imgn)+".png"
   imgn+1
  If CaptureWebPage(sURL, DesktopWidth(0), DesktopHeight(0), sFileOut)

  Else
          MessageRequester("Web Page", "Capture Failed")
  EndIf

EndProcedure

;Snapshot()
LoadFont(0,"Broadway",24)

OpenWindow(10,0,0,400,80,"Capture Web",#PB_Window_SystemMenu |#PB_Window_ScreenCentered)
StickyWindow(10,1)
StringGadget(20,10,10,380,24,"")
ButtonGadget(30,10,50,60,24,"Capture")
TextGadget(40,140,50,80,40,"")
SetGadgetFont(40,0)
SetGadgetColor(40,#PB_Gadget_FrontColor,#Red)


Repeat
  Select WaitWindowEvent()
      
      Case #PB_Event_CloseWindow
            Quit = 1
      
      Case #PB_Event_Gadget
          Select EventGadget()
           Case 30
                 SetGadgetText(40,"")
                 sURL.s = GetGadgetText(20)
                If sURL.s
                    Snapshot()
                EndIf
                SetGadgetText(20,"")
                SetGadgetText(40,"FINISHED")
                           
          EndSelect          
            
  EndSelect 

Until Quit = 1
End

End


DataSection

  IID_IHTMLDocument2:
  ;332C4425-26CB-11D0-B483-00C04FD90119
  Data.i $332C4425
  Data.w $26CB, $11D0
  Data.b $B4, $83, $00, $C0, $4F, $D9, $01, $19

  IID_IHTMLDocument3:
  ;3050F485-98B5-11CF-BB82-00AA00BDCE0B
  Data.i $3050F485
  Data.w $98B5, $11CF
  Data.b $BB, $82, $00, $AA, $00, $BD, $CE, $0B

  IID_IHTMLElement2:
  ;3050f434-98b5-11cf-bb82-00aa00bdce0b
  Data.i $3050F434
  Data.w $98B5, $11CF
  Data.b $BB, $82, $00, $AA, $00, $BD, $CE, $0B

  IID_IViewObject2:
  ;00000127-0000-0000-c000-000000000046
  Data.i $00000127
  Data.w $0000, $0000
  Data.b $C0, $00, $00, $00, $00, $00, $00, $46


EndDataSection

[IdeasVacuum]

Hi Rashad

Ah, that then folds back into my original rambling as it is the original method used. Since the WebPage has to be loaded into a PB Webgadget, it fails with secured pages and 'pages within pages' that have an identical URL.

What might work would be the temporary re-size of the browser, snapshot, restore size. Before that brilliant idea I was trying to work out how to 'auto scroll' a web page, since an image could then be made up of as many snapshots as necessary (usually a webpage length is not more than roughly 4 * screen height, so 4 snapshots).

[RASHAD]

Hi IdeasVacuum
Some Progress
Tested with IE,FireFox & Opera

To do :
- Calculate the height of the page so we can calculate how many times we need to
scroll down per Image
- Merge the captured Images in on Image and clean the unneeded ones

Code: Select all

Prototype printwindow(hwnd,hdc,flag)
Global printwindow.printwindow

lib = OpenLibrary(0,"User32.dll")
If lib
  printwindow = GetFunction(0,"PrintWindow")
EndIf

; Procedure LeftClick ()
;   In.INPUT
;   In\type        = #INPUT_MOUSE
;   In\mi\dwFlags  = #MOUSEEVENTF_LEFTDOWN
;   SendInput_(1,@In,SizeOf(INPUT))
; 
;   In\mi\dwFlags  = #MOUSEEVENTF_LEFTUP
;   SendInput_(1,@In,SizeOf(INPUT))
; EndProcedure

Procedure ScrollDown()
  In.INPUT
  In\type        = #INPUT_KEYBOARD
  In\ki\wVk      = #VK_DOWN
  ;In\ki\dwFlags  = #KEYEVENTF_KEYUP
  SendInput_(1,@In,SizeOf(INPUT))

  In\ki\dwFlags  = #KEYEVENTF_KEYUP
  SendInput_(1,@In,SizeOf(INPUT))
EndProcedure   

Procedure ScrollUp()
  In.INPUT
  In\type        = #INPUT_KEYBOARD
  In\ki\wVk      = #VK_UP
  ;In\ki\dwFlags  = #KEYEVENTF_KEYUP
  SendInput_(1,@In,SizeOf(INPUT))

  In\ki\dwFlags  = #KEYEVENTF_KEYUP
  SendInput_(1,@In,SizeOf(INPUT))
EndProcedure    

Procedure GetHandle(Wtext$)
  hWnd = GetWindow_(GetDesktopWindow_(),#GW_CHILD)
  Repeat
    Text$ = Space(#MAX_PATH)
    GetWindowText_(hWnd,@Text$,#MAX_PATH)
    If FindString(LCase(Text$), LCase(Wtext$),1) <>0 And IsWindowVisible_(hWnd) = 1
      Finhwnd = hWnd
    Else
      hWnd = GetWindow_(hWnd,#GW_HWNDNEXT)
    EndIf
  Until hWnd=0 Or Finhwnd <> 0
  ProcedureReturn Finhwnd
EndProcedure
;
For browser = 1 To 3
   Read.s Browser$
   hWnd = GetHandle(Browser$)
   If hWnd <> 0
      Break
   EndIf
Next
 
If hWnd
    If IsIconic_(hWnd)
        ShowWindow_(hWnd,#SW_RESTORE)
        Iconic =1
    EndIf
    SetForegroundWindow_(hWnd)
    SetWindowPos_(hWnd,#HWND_TOPMOST,0,0,0,0,#SWP_NOMOVE|#SWP_NOSIZE) 
    GetWindowRect_(hWnd,r.RECT)
    SetActiveWindow_(hWnd)
    ;SetCursorPos_(r\left + 500,r\top+500)
    ;LeftClick()
    For x = 1 To 10
        hBitmap = CreateImage(0,r\right-r\left,r\bottom-r\top)
        hdc = StartDrawing(ImageOutput(0))
        PrintWindow(hwnd,hdc,0)
        StopDrawing()
        DeleteDC_(hdc)             
        Delay(200)    
        SaveImage(0,GetHomeDirectory() + "Image "+Str(imn)+".bmp",#PB_ImagePlugin_BMP)
        imn + 1
        Delay(200)
        For key = 1 To 20
          ScrollDown()
        Next        
    Next
 EndIf
 For key = 1 To 1000
    ScrollUp()
 Next
 If Iconic = 1
    ShowWindow_(hWnd,#SW_MINIMIZE	)
 EndIf

If lib
  CloseLibrary(0)
EndIf   

DataSection
   Data.s "Explorer","Fire","Opera"
EndDataSection

Edit :Code updated for better performance

[IdeasVacuum]

Hi Rashad

Aha, this is the clever bit:

Code: Select all

Procedure ScrollDown()
  In.INPUT
  In\type        = #INPUT_KEYBOARD
  In\ki\wVk      = #VK_DOWN
  ;In\ki\dwFlags  = #KEYEVENTF_KEYUP
  SendInput_(1,@In,SizeOf(INPUT))

  In\ki\dwFlags  = #KEYEVENTF_KEYUP
  SendInput_(1,@In,SizeOf(INPUT))
EndProcedure

excellent stuff thank you