PureBasic Forums - English

Code: Select all

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

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

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) 
    GetWindowRect_(hWnd,r.RECT)
    cycle = (r\bottom-r\top)/58 - 1
    SetActiveWindow_(hWnd)
    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 cycle
          ScrollDown()
          ;Delay(50)
        Next
        Delay(200)        
    Next
 EndIf
 For key = 1 To cycle*10
    ScrollUp()
 Next
 If Iconic = 1
    ShowWindow_(hWnd,#SW_MINIMIZE	)
 EndIf

If lib
  CloseLibrary(0)
EndIf   

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

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 WindowProc(hWnd,uMsg,wParam,lParam)
  Result = #PB_ProcessPureBasicEvents
  Select uMsg
           
    Case #WM_NCACTIVATE
            Result = 1

  EndSelect
  ProcedureReturn Result
EndProcedure
  
Procedure.s EnumChildProc(hwnd, lParam)
  Protected Classname$ = Space(#MAX_PATH)
  Protected URL$ = Space(#MAX_PATH)
    GetClassName_(hwnd, @Classname$, #MAX_PATH-1)
    If ClassName$ = "Edit"
      SendMessage_(hwnd, #WM_GETTEXT, #MAX_PATH, @URL$)
      sURL.s = URL$
    EndIf 
  ProcedureReturn sURL.s
EndProcedure

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)
      m_pWebBrowser\put_Silent(#True)
         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 sFileOut.s
  Define sNow.s

  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

LoadFont(0,"Georgia",12,#PB_Font_Bold)

OpenWindow(10,0,0,300,40,"Capture Web",#PB_Window_SystemMenu |#PB_Window_ScreenCentered)
StickyWindow(10,1)
ButtonGadget(30,10,10,60,24,"Capture")
TextGadget(40,100,10,160,40,"")
SetGadgetFont(40,FontID(0))
SetGadgetColor(40,#PB_Gadget_FrontColor,#Red)

SetWindowCallback(@WindowProc())

Repeat
  Select WaitWindowEvent()
     
      Case #PB_Event_CloseWindow
            Quit = 1
     
      Case #PB_Event_Gadget
          Select EventGadget()
           Case 30            
                 hwndParent = FindWindow_("IEFrame", 0)
                 EnumChildWindows_(hwndParent, @EnumChildProc(), 0)
                If sURL.s
                    SetGadgetText(40,"Capturing...")
                    Snapshot()
                    SetGadgetText(40,"FINISHED")
                Else
                    MessageRequester("Error..","No URL to copy,please try again",#PB_MessageRequester_Ok|#MB_ICONERROR|#MB_SYSTEMMODAL)
                    End
                EndIf
                
          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

Code: Select all

iCycle = (iImgH) / 58 - 1

Code: Select all

UsePNGImageEncoder()
UsePNGImageDecoder()

EnableExplicit

Enumeration
#WinMsg
#TxtWinMsg
#WholePage
EndEnumeration

Global ighCrossCursor.i = LoadCursor_(#Null, #IDC_CROSS)

SetSystemCursor_(ighCrossCursor, #OCR_NORMAL)

Global igLEFTBTN.i = #VK_LBUTTON, igRIGHTBTN.i = #VK_RBUTTON

If(GetSystemMetrics_(#SM_SWAPBUTTON) = #True)

         igLEFTBTN = #VK_RBUTTON
        igRIGHTBTN = #VK_LBUTTON
EndIf

Global MouseUpL.INPUT
       MouseUpL\type = #INPUT_MOUSE
       MouseUpL\mi\dx = 0
       MouseUpL\mi\dy = 0
       MouseUpL\mi\mouseData = 0
       MouseUpL\mi\dwFlags = #MOUSEEVENTF_LEFTUP
       MouseUpL\mi\time = 0
       MouseUpL\mi\dwExtraInfo = 0

Global gPt1.POINT, gPt2.POINT

Procedure LeftButtonDown()
;#------------------------

               If(GetAsyncKeyState_(igLEFTBTN) & 32768)

                        ProcedureReturn #True
               Else
                        ProcedureReturn #False
               EndIf
EndProcedure

Procedure WinMsg(sMsg.s)
;#----------------------

        If OpenWindow(#WinMsg, 0, 0, 300, 30, "", #PB_Window_BorderLess | #PB_Window_ScreenCentered)

                SetWindowColor(#WinMsg,RGB(255,255,190)) ;Pale Yellow

                    TextGadget(#TxtWinMsg, 5, 5, 290, 20, "", #PB_Text_Center)
                SetGadgetColor(#TxtWinMsg, #PB_Gadget_BackColor, RGB(255,255,190))
                SetGadgetColor(#TxtWinMsg, #PB_Gadget_FrontColor, RGB(0,0,0))
                 SetGadgetText(#TxtWinMsg, sMsg)

                  StickyWindow(#WinMsg, #True)
        EndIf

EndProcedure

Procedure Pick2Pts(iImgID.i)
;#--------------------------
; Pick 2 points to define area of web page inside Browser Window
Protected iPick1.i = #False
Protected iPick2.i = #False
Protected iEvent.i
Protected sMsg1.s, sMsg2.s

   If LeftButtonDown() : SendInput_(1,@MouseUpL,SizeOf(INPUT)) : EndIf

   WinMsg("Pick top-left corner of web page")

   Repeat
             If(GetAsyncKeyState_(#VK_ESCAPE) & 32768)

                    Goto Pick2PtsQuit

             ElseIf(GetAsyncKeyState_(igLEFTBTN) & 32768) ;button is down

                     GetCursorPos_(gPt1)
                     iPick1 = #True
                     Break
             EndIf

   Until iPick1 = #True

   CloseWindow(#WinMsg)

   If LeftButtonDown() : SendInput_(1,@MouseUpL,SizeOf(INPUT)) : EndIf

   WinMsg("Pick bottom-right corner of web page")

   Repeat
             If(GetAsyncKeyState_(#VK_ESCAPE) & 32768)

                    Goto Pick2PtsQuit

             ElseIf(GetAsyncKeyState_(igLEFTBTN) & 32768) ;button is down

                     GetCursorPos_(gPt2)
                     iPick2 = #True
                     Break
             EndIf

   Until iPick2 = #True

   Pick2PtsQuit:

   CloseWindow(#WinMsg)

EndProcedure

Procedure ScrollDown()
;#--------------------
Protected In.INPUT
          In\type   = #INPUT_KEYBOARD
          In\ki\wVk = #VK_DOWN

              SendInput_(1,@In,SizeOf(INPUT))

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

Procedure ScrollUp()
;#------------------
Protected In.INPUT
          In\type   = #INPUT_KEYBOARD
          In\ki\wVk = #VK_UP

              SendInput_(1,@In,SizeOf(INPUT))

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

Procedure GetHandle(sWtxt.s)
;#--------------------------
Protected    hWnd.i = GetWindow_(GetDesktopWindow_(), #GW_CHILD)
Protected hwndFin.i
Protected sWinTxt.s

              Repeat

                    sWinTxt = Space(#MAX_PATH)
                    GetWindowText_(hWnd, @sWinTxt, #MAX_PATH)

                    If( (FindString(LCase(sWinTxt), LCase(sWtxt), 1) <> 0) And (IsWindowVisible_(hWnd) = 1) )

                            hwndFin = hWnd
                    Else
                               hWnd = GetWindow_(hWnd, #GW_HWNDNEXT)
                    EndIf

              Until hWnd = 0 Or hwndFin <> 0

              ProcedureReturn(hwndFin)
EndProcedure

Procedure CaptureWebPage()
;#------------------------
Protected iX.i = 0, iY.i = 0
Protected iCnt.i, iBrowser.i, iKey.i, iCycle.i, hWnd.i, iTotal.i = 10
Protected iImgW.i, iImgH.i, iIconic.i = #False
Protected WinRect.RECT
Protected sBrowser.s
Protected        dm.DEVMODE ;structure for CreateDC()
Protected screenDC.i, trgDC.i, hBmp.i

              For iBrowser = 1 To 4

                    Read.s sBrowser
                    hWnd = GetHandle(sBrowser)

                    If(hWnd <> 0)

                           Break
                    EndIf

              Next iBrowser

              If hWnd

                      If IsIconic_(hWnd)

                             ShowWindow_(hWnd, #SW_RESTORE)
                             iIconic = #True
                      EndIf

                      SetForegroundWindow_(hWnd)

                      Pick2Pts(hWnd)

                       iImgW = (gPt2\x - gPt1\x)
                       iImgH = (gPt2\y - gPt1\y)
                      iCycle = (iImgH) / 58 - 1

                      SetActiveWindow_(hWnd)

                      If CreateImage(#WholePage, iImgW, (iImgH  * iTotal), 24, RGB(255,255,255))

                               For iCnt = 1 To iTotal

                                    screenDC = CreateDC_("DISPLAY", "", "", dm) ;Initialise dm
                                       trgDC = CreateCompatibleDC_(screenDC)
                                        hBmp = 0

                                         If StartDrawing(ImageOutput(#WholePage))

                                                 hBmp = CreateCompatibleBitmap_(screenDC, iImgW, iImgH)

                                                 SelectObject_(trgDC, hBmp)
                                                       BitBlt_(trgDC, 0, 0, iImgW, iImgH, screenDC, gPt1\x, gPt1\y, #SRCCOPY)

                                                         DrawImage(hBmp, iX, iY)
                                                       StopDrawing()

                                                             iY = iY + iImgH

                                                             Delay(100)

                                                 For iKey = 1 To iCycle

                                                       ScrollDown()
                                                 Next
                                         EndIf

                                    ;Clean up
                                     DeleteDC_(trgDC)
                                    ReleaseDC_(hBmp, screenDC)

                               Next iCnt

                                    Delay(100)
                                SaveImage(#WholePage,"C:\WebPageImage.png", #PB_ImagePlugin_PNG, 10, 24)
                                    Delay(100)
                               RunProgram("C:\WebPageImage.png")
                      EndIf

                      For iKey = 1 To iCycle * 10

                            ScrollUp()
                      Next

                      If iIconic = #True

                              ShowWindow_(hWnd, #SW_MINIMIZE)
                      EndIf
               EndIf
EndProcedure

CaptureWebPage()

;Reset Cursor Pointers Set
SystemParametersInfo_(#SPI_SETCURSORS,0,#Null,#Null)

End

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