Repetitive Screen Captures

Category: Screen Capture

Date: 03-28-2012

Return to Index


 
'Compilable Example:
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#Debug Error On     'catch array/pointer errors - OFF in production
#Debug Display On   'display untrapped errors   - OFF in production
#Include "Win32api.inc"
 
%IDC_Graphic = 500
 
Global hDlg, hDC, memDC, hBMP, hGraphic As Dword
Global pt, ptDrawOrig, truept As Point
Global DrawInWork, SnapToGrid, ShowGrid, iMsgCount, GridSize As Long
Global x1,y1,x2,y2 As Long
 
Function PBMain() As Long
   Local w,h As Long
   Desktop Get Size To w,h
   Dialog New Pixels, 0, "",0,0,w,h, %WS_Popup To hDlg
   Control Add Graphic, hDlg, %IDC_Graphic, "", 0,0,w,h
   Control Handle hDlg, %IDC_Graphic To hGraphic
   Graphic Attach hDlg, %IDC_Graphic
   Dialog Show Modal hDlg Call DlgProc
End Function
 
CallBack Function DlgProc() As Long
   Local i,x,y,w,h,iReturn As Long
   Select Case Cb.Msg
      Case %WM_InitDialog
         CreateInvisibleBitmap
         CaptureScreen
      Case %WM_Paint
         RefreshDrawing   '1=PB 0=API
      Case %WM_SetCursor
         Dialog Get Client hDlg To w,h
         GetCursorPos pt : ScreenToClient hDlg, pt
         Select Case Hi(Word, Cb.LParam)  'monitors the 3 basic mouse actions, lbuttondown, mousemose, lbuttonup
            Case %WM_LButtonDown
               If (pt.x>-1) And (pt.x<(w+1)) And (pt.y>0) And (pt.y<h) Then 'inside GUI bounds
                  DrawInWork = 1
                  ptDrawOrig = pt
               End If
            Case %WM_MouseMove
               If DrawInWork Then
                  RefreshDrawing
               End If
            Case %WM_LButtonUp
               If DrawInWork Then
                  DrawInWork = 0
                  RefreshDrawing
               End If
         End Select
   End Select
End Function
 
Sub RefreshDrawing   'using PB Bitmap
   Local i,x,y,w,h As Long
   Dialog Get Client hDlg To w,h
   Graphic Clear     'clear/fill with color
   If DrawInWork Then Graphic Box (ptDrawOrig.x, ptDrawOrig.y) - (pt.x, pt.y),, %Red   'draw rectangle that follows the mouse
   hDC = GetDC(hDlg)
   BitBlt hDC, 0, 0, w, h, memDC, 0, 0, %SRCCopy
   ReleaseDC(hDlg,hDC)
End Sub
 
Sub CreateInvisibleBitmap
   Local x,y,w,h As Long
   Desktop Get Size To w,h
   Graphic Bitmap New w,h To hBMP
   Graphic Attach hBMP, 0
   Graphic Get DC To memDC
End Sub
 
Sub CaptureScreen
   keybd_event(%VK_SnapShot, 0, 0, 0)    'screen image
   Dialog DoEvents
   Clipboard Get Bitmap To hBMP          'put screen image into Graphic Control
   Graphic Copy hBMP, 0
End Sub
 
MACRO AddLine(value)
   IF cntProcs>=maxProcs THEN
      maxProcs = maxProcs + 1000
      REDIM PRESERVE procs(maxProcs)
   END IF
   procs(cntProcs)=value
   INCR cntProcs
   END MACRO
 
Sub GetProcNames(value As String)
   DIM maxProcs AS INTEGER
   maxProcs=1000
   DIM procs(maxProcs) As String
   DIM cntProcs AS INTEGER
   cntProcs = 0
   DIM translate(255) AS STATIC BYTE
   ARRAY ASSIGN translate() = _
      0, 0, 0, 0, 0, 0, 0, 0, 0, 32, 0, 0, 0, 13, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 32, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 0, 0, 0, 61, 0, 0 _
      , 0, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79 _
      , 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 0, 0, 0, 0, 95 _
      , 0, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79 _
      , 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
      , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
 
   REGISTER i AS INTEGER, p AS INTEGER
   DIM t AS INTEGER
   i=MAX(LEN(value)-13, 0): ' Forget last 13 characters
   DIM v AS BYTE PTR, d AS BYTE PTR
   v = STRPTR(value)
   DIM dest As String
   dest = STRING$(i,32)
   d = STRPTR(dest)
   DIM lastSpace AS INTEGER
   DIM c AS BYTE
   p = 0
   DO WHILE i
      DO
         ' Skip leading spaces
         WHILE i AND translate(@v)<=32
            DECR i
            INCR v
         WEND
         ' Only consider possible lines
         IF INSTR("CFIMOPST",CHR$(translate(@v)))>0 THEN EXIT DO
         ' So find next carriage return
         WHILE i AND translate(@v)<>13
            DECR i
            INCR v
         WEND
      LOOP WHILE i
      IF i=0 THEN EXIT DO
      ' translate possible line
      lastSpace=0
      DO
         c=translate(@v)
         IF c=0 THEN
            ' Skip over rubbish
            WHILE i AND translate(@v)<>13
               DECR i
               INCR v
            WEND
            c = 13
         END IF
         IF lastSpace AND c=32 THEN
            c=0
         ELSE
            lastSpace = (c = 32)
         END IF
         IF c THEN
            @d = c
            INCR d
         END IF
         DECR i
         INCR v
      LOOP WHILE i AND c<>13
   LOOP
   value=RTRIM$(dest)
   p = PARSECOUNT(value, $CR)
   DIM iLines(p-1) As String
   PARSE value, iLines(), $CR
   FOR i=0 TO p-1
      IF LEFT$(iLines(i), 9) = "CALLBACK THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 6) = "CLASS THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 9) = "Function AND INSTR(iLines(i), "=")=0 THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 10) = "INTERFACE THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 6) = "MACRO THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 7) = "METHOD AND INSTR(iLines(i), "=")=0 THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 9) = "OVERRIDE THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 9) = "PROPERTY AND INSTR(iLines(i), "=")=0 THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 4) = "SUB THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
      IF LEFT$(iLines(i), 7) = "THREAD THEN
         AddLine(iLines(i))
         ITERATE FOR
      END IF
   NEXT
   REDIM PRESERVE procs(cntProcs)
End Sub
 
'gbs_01003
'Date: 03-10-2012


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm