*************coloque isso em um form que contenha um timer, e uma picturebox
Dim c As New cDIBSection
Private Sub Timer1_Timer()
Call ScreenShot(Form2.hDc)
SavePicture Form2.Image, "C: este.bmp"
c.CreateFromPicture LoadPicture("C: este.bmp")
SaveJPG c, "C:Teste.jpg", 26
'função para enviar por winsock arquivo c: este.jpg
************Classe nome: cDIBSection
Option Explicit
' ==================================================================================
' Requires: mIJLmod.cls
' ijl15.dll (Intel)
' ==================================================================================
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDc As Long, pBitmapInfo As BITMAPINFO, ByVal un As _
Long, lplpVoid As Long, ByVal handle As Long, ByVal dw 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 SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Const BI_RGB = 0&
Private Const BI_RLE4 = 2&
Private Const BI_RLE8 = 1&
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
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
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, _
lpObject As Any) As Long
' Handle to the current DIBSection:
Private m_hDIb As Long
' Handle to the old bitmap in the DC, for clear up:
Private m_hBmpOld As Long
' Handle to the Device context holding the DIBSection:
Private m_hDC As Long
' Address of memory pointing to the DIBSection's bits:
Private m_lPtr As Long
' Type containing the Bitmap information:
Private m_tBI As BITMAPINFO
Public Property Get BytesPerScanLine() As Long
' Scans must align on dword boundaries:
BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property
Public Property Get Width() As Long
Width = m_tBI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
Height = m_tBI.bmiHeader.biHeight
End Property
Public Sub LoadPictureBlt(ByVal lhDC As Long, Optional ByVal lSrcLeft As Long = 0, Optional ByVal lSrcTop _
As Long = 0, Optional ByVal lSrcWidth As Long = -1, Optional ByVal lSrcHeight As Long = -1, Optional ByVal _
eRop As RasterOpConstants = vbSrcCopy)
If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lhDC, lSrcLeft, lSrcTop, eRop
End Sub
Public Property Get DIBSectionBitsPtr() As Long
DIBSectionBitsPtr = m_lPtr
End Property
Public Sub ClearUp()
If (m_hDC <> 0) Then
If (m_hDIb <> 0) Then
SelectObject m_hDC, m_hBmpOld
DeleteObject m_hDIb
End If
DeleteObject m_hDC
End If
m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
End Sub
Public Function CreateFromPicture(ByRef picThis As StdPicture)
Dim lhDC As Long
Dim lhDCDesktop As Long
Dim lhBmpOld As Long
Dim tBMP As BITMAP
GetObjectAPI picThis.handle, Len(tBMP), tBMP
If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
lhDCDesktop = GetDC(GetDesktopWindow())
If (lhDCDesktop <> 0) Then
lhDC = CreateCompatibleDC(lhDCDesktop)
DeleteDC lhDCDesktop
If (lhDC <> 0) Then
lhBmpOld = SelectObject(lhDC, picThis.handle)
LoadPictureBlt lhDC
SelectObject lhDC, lhBmpOld
DeleteObject lhDC
End If
End If
End If
End Function
Public Function CreateDIB(ByVal lhDC As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByRef hDib As Long _
) As Boolean
With m_tBI.bmiHeader
.biSize = Len(m_tBI.bmiHeader)
.biWidth = lWidth
.biHeight = lHeight
.biPlanes = 1
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = BytesPerScanLine * .biHeight
End With
hDib = CreateDIBSection(lhDC, m_tBI, DIB_RGB_COLORS, m_lPtr, 0, 0)
CreateDIB = (hDib <> 0)
End Function
Public Function Create(ByVal lWidth As Long, ByVal lHeight As Long) As Boolean
ClearUp
m_hDC = CreateCompatibleDC(0)
If (m_hDC <> 0) Then
If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
m_hBmpOld = SelectObject(m_hDC, m_hDIb)
Create = True
Else
DeleteObject m_hDC
m_hDC = 0
End If
End If
End Function
********************em um módulo qualquer:
Option Explicit
' ==================================================================================
' Requires: cDIBSectionmod.cls
' ijl15.dll (Intel)
' An interface to Intel's IJL (Intel JPG Library) for use in VB.
' ==================================================================================
Private Enum IJLERR
IJL_OK = 0
End Enum
Private Enum IJLIOTYPE
''// Write an entire JFIF bit stream.
IJL_JFILE_WRITEWHOLEIMAGE = 8&
End Enum
Type JPEG_CORE_PROPERTIES_VB
UseJPEGPROPERTIES As Long '// default = 0
'// DIB specific I/O data specifiers.
DIBBytes As Long '; '// default = NULL 4
DIBWidth As Long '; '// default = 0 8
DIBHeight As Long '; '// default = 0 12
DIBPadBytes As Long '; '// default = 0 16
DIBChannels As Long '; '// default = 3 20
DIBColor As Long '; '// default = IJL_BGR 24
DIBSubsampling As Long '; '// default = IJL_NONE 28
'// JPEG specific I/O data specifiers.
JPGFile As Long 'LPTSTR JPGFile; 32 '// default = NULL
JPGBytes As Long '; '// default = NULL 36
JPGSizeBytes As Long '; '// default = 0 40
JPGWidth As Long '; '// default = 0 44
JPGHeight As Long '; '// default = 0 48
JPGChannels As Long '; '// default = 3
JPGColor As Long '; '// default = IJL_YCBCR
JPGSubsampling As Long '; '// default = IJL_411
JPGThumbWidth As Long ' ; '// default = 0
JPGThumbHeight As Long '; '// default = 0
'// JPEG conversion properties.
cconversion_reqd As Long '; '// default = TRUE
upsampling_reqd As Long '; '// default = TRUE
jquality As Long '; '// default = 75. 90 is my preferred quality setting.
'// Low-level properties - 20,000 bytes. If the whole structure
' is written out then VB fails with an obscure error message
' "Too Many Local Variables" !
' These all default if they are not otherwise specified so there
' is no trouble.
jprops(0 To 19999) As Byte
End Type
Private Declare Function ijlInit Lib "ijl15.dll" (jcprops As Any) As Long
Private Declare Function ijlFree Lib "ijl15.dll" (jcprops As Any) As Long
Private Declare Function ijlWrite Lib "ijl15.dll" (jcprops As Any, ByVal ioType As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy _
As Long)
Public Function SaveJPG(ByRef cDib As cDIBSection, ByVal sFile As String, Optional ByVal lQuality As Long _
= 90) As Boolean
Dim tJ As JPEG_CORE_PROPERTIES_VB
Dim bFile() As Byte
Dim lptr As Long
Dim lR As Long
lR = ijlInit(tJ)
If lR = IJL_OK Then
' Set up the DIB information:
' Store DIBWidth:
tJ.DIBWidth = cDib.Width
' Store DIBHeight:
tJ.DIBHeight = -cDib.Height
' Store DIBBytes (pointer to uncompressed JPG data):
tJ.DIBBytes = cDib.DIBSectionBitsPtr
' Very important: tell IJL how many bytes extra there
' are on each DIB scan line to pad to 32 bit boundaries:
tJ.DIBPadBytes = cDib.BytesPerScanLine - cDib.Width * 3
' Set up the JPEG information:
' Store JPGFile:
bFile = StrConv(sFile, vbFromUnicode)
ReDim Preserve bFile(0 To UBound(bFile) + 1) As Byte
bFile(UBound(bFile)) = 0
lptr = VarPtr(bFile(0))
CopyMemory tJ.JPGFile, lptr, 4
' Store JPGWidth:
tJ.JPGWidth = cDib.Width
' .. & JPGHeight member values:
tJ.JPGHeight = cDib.Height
' Set the quality/compression to save:
tJ.jquality = lQuality
' Write the image:
lR = ijlWrite(tJ, IJL_JFILE_WRITEWHOLEIMAGE)
If lR = IJL_OK Then
SaveJPG = True
Else
' Throw error
MsgBox "Failed to save to JPG", vbExclamation
End If
' Ensure we have freed memory:
ijlFree tJ
Else
' Throw error:
MsgBox "Failed to initialise the IJL library: " & lR, vbExclamation
End If
End Function
Depois de tudo isso, no site da intel baixe a dllijl15.dll (Intel)
