Capture The Screen ! My Code is fast but not working !
I combained some codes from each of you to build a really fast screen monitor , but so far It did not work !
Module
Code:
Public 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
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Form : MonitorScreen
Code:
Dim ProgramDC As Long
Dim ScreenDC As Long
Dim ImageDC As Long
Dim CapErr As Long
Option Explicit
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Public pic() As Byte
Dim sa As SAFEARRAY2D
Dim bmp As BITMAP
Dim r As Long, g As Long, b As Long
Dim i As Integer
Dim j As Integer
Dim errmsg As Integer
Private Sub Cap_Click()
Refresher.Interval = 42
End Sub
Private Sub Form_Load()
ProgramDC = MonitorScreen.hDC
ScreenDC = GetWindowDC(0)
ImageDC = ImgField.hDC
End Sub
Private Sub Pause_Click()
Refresher.Interval = 0
End Sub
Private Sub PrtComm_Click()
Prt.Show
Prt.PrtForm.Text = ""
For i = 1 To 240
For j = 1 To 320
Prt.PrtForm.Text = pic(i, j)
Next j
Next i
End Sub
Private Sub Refresher_Timer()
CapErr = BitBlt(ImageDC, 0, 0, 320, 240, ScreenDC, 33, 214, vbSrcCopy)
GetObjectAPI ImgField.Picture, Len(bmp), bmp
With sa
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = bmp.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = bmp.bmWidthBytes
.pvData = bmp.bmBits
End With
CopyMemory ByVal VarPtrArray(pic), VarPtr(sa), 4
End Sub
the result is sad , PIC array contains nothing !
Thanks a lot for reading my rewbie code at first place !