Code:
Private Declare Function CreateDIBSectionPtr Lib "gdi32.dll" Alias "CreateDIBSection" (ByVal hDC As Long, ByRef pBMI As Any, ByVal iUsage As Long, ByRef ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long
Public Function CaptureCurrentImage() As Boolean
Dim BufferPointer As Long, BufferLength As Long
Dim lheap As Long
Dim oBasicVideo As IAMBasicVideo
Dim bResult As Boolean
On Error Resume Next
Set oBasicVideo = m_objManager
Call oBasicVideo.GetCurrentImage(BufferLength, ByVal 0&)
If BufferLength > 0& Then
lheap = GetProcessHeap()
'BufferPointer is a packed DIB
BufferPointer = HeapAlloc(lheap, HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, BufferLength)
If BufferPointer <> 0 Then
Call oBasicVideo.GetCurrentImage(BufferLength, ByVal BufferPointer)
Set oBasicVideo = Nothing
If (Err.Number = 0&) Then
Select Case m_eDSVideoOutputMode
Case eSaveAsFile
If Len(m_sOutputFileName) Then
CaptureCurrentImage = SaveToBitmap(m_uBIH, BufferPointer, BufferLength, m_sOutputFileName)
End If
HeapFree lheap, 0, BufferPointer
m_bCaptureInProgress = False
Exit Function
Case eCopytoClipboard
If (CopyPackedDIBtoClipboard(BufferPointer)) Then
bResult = HeapFree(lheap, 0&, BufferPointer)
If Not bResult Then
'MsgBox "Call to HeapFree has failed", vbCritical, "HeapFree Failed"
End If
CaptureCurrentImage = True
m_bCaptureInProgress = False
Exit Function
End If
Case eCopytoDIBSection
Dim DIBDataPtr As Long, hDC As Long, hOldDIB As Long, dDC As Long, hDIB As Long
dDC = GetDC(GetDesktopWindow())
hDC = CreateCompatibleDC(dDC)
ReleaseDC GetDesktopWindow(), dDC
If (hDC <> 0) Then
hDIB = CreateDIBSectionPtr(hDC, ByVal BufferPointer, DIB_RGB_COLORS, DIBDataPtr, 0&, 0&)
If (hDIB <> 0) Then
hOldDIB = SelectObject(hDC, hDIB)
Else
Call DeleteDC(hDC)
End If
If (hDIB) Then ' Copy Bitmap data into DIBSection
'BufferPointer is a packed DIB,we need to retrieve raw DIB bits (DIBSection)
Call RtlMoveMemory(ByVal DIBDataPtr, ByVal (BufferPointer + 40), BufferLength - 40)
' Return DIBSection handle
RaiseEvent DSCopyFrametoDIB(hDIB)
CaptureCurrentImage = True
m_bCaptureInProgress = False
End If
End If
If (hDC <> 0) Then
If (hDIB <> 0) Then
Call SelectObject(hDC, hOldDIB)
Call DeleteObject(hDIB)
End If
Call DeleteDC(hDC)
End If
'-- Reset DIB vars.
hDC = 0
hDIB = 0
hOldDIB = 0
End Select
End If
End If
HeapFree lheap, 0, BufferPointer
Call Err.Clear
End If
Set oBasicVideo = Nothing
End Function
Private Function SaveToBitmap(tBIH As BITMAPINFOHEADER, ByVal lPtrBits As Long, ByVal PtrBitsSize As Long, ByVal sFileName As String) As Boolean
Dim uBFH As BITMAPFILEHEADER
Dim hFile As Long
Dim lBytesWritten As Long
Dim lSize As Long
Dim lRet As Long
Dim bErr As Boolean
Dim lheap As Long, lPtr As Long
Dim lErr As Long
Dim lColors As Long
Dim bOk As Boolean
' Prepare the BITMAPFILEHEADER
bOk = DeleteTheFile(sFileName, m_bUseUnicode)
'If Not bOK Then Exit Function
hFile = CreateTheFile(sFileName, False, m_bUseUnicode)
lErr = Err.LastDllError
If (hFile = INVALID_HANDLE_VALUE) Then
' error
Exit Function
Else
'-- Get palette entries count
lColors = IIf(tBIH.biBitCount <= 8, 2 ^ tBIH.biBitCount, 0)
With uBFH
.bfType = BITMAPTYPE
.bfSize = Len(tBIH) + 4 * lColors + tBIH.biSizeImage
.bfOffBits = Len(uBFH) + Len(tBIH) + 4 * lColors
End With
' Writing the BITMAPFILEINFOHEADER is somewhat painful
' due to non-byte alignment of structure...
lheap = GetProcessHeap()
lPtr = HeapAlloc(lheap, HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, Len(uBFH))
CopyMemory ByVal lPtr, uBFH.bfType, 2
CopyMemory ByVal lPtr + 2, uBFH.bfSize, 4
CopyMemory ByVal lPtr + 6, 0&, 4
CopyMemory ByVal lPtr + 10, uBFH.bfOffBits, 4
lSize = Len(uBFH)
lRet = WriteFile(hFile, ByVal lPtr, lSize, lBytesWritten, ByVal 0&)
HeapFree lheap, 0, lPtr
' Add the BITMAPINFOHEADER and colour palette:
bErr = FileErrHandler(lRet, lSize, lBytesWritten)
If Not bErr Then
lSize = Len(tBIH)
lRet = WriteFile(hFile, tBIH, lSize, lBytesWritten, ByVal 0&)
bErr = FileErrHandler(lRet, lSize, lBytesWritten)
Else
CloseHandle hFile
End If
If Not bErr Then
' Its easy to write the bitmap data, though...
lSize = PtrBitsSize 'tBIH.biSizeImage
lRet = WriteFile(hFile, ByVal (lPtrBits + Len(tBIH)), lSize, lBytesWritten, ByVal 0&)
bErr = FileErrHandler(lRet, lSize, lBytesWritten)
Else
CloseHandle hFile
End If
bErr = FileErrHandler(lRet, lSize, lBytesWritten)
CloseHandle hFile
SaveToBitmap = Not (bErr)
End If
End Function
Private Function FileErrHandler(ByVal lR As Long, ByVal lSize As Long, ByVal lBytes As Long) As Boolean
If (lR = 0) Or Not (lSize = lBytes) Then
'Err.Raise
FileErrHandler = True
End If
End Function
Private Function pvByteAlignOnWord(ByVal BitDepth As Byte, ByVal Width As Long) As Long
' function to align any bit depth on dWord boundaries
pvByteAlignOnWord = (((Width * BitDepth) + &H1F&) And Not &H1F&) \ &H8&
End Function
Private Function CopyPackedDIBtoClipboard(ByVal hGlobal As OLE_HANDLE) As Boolean
If hGlobal = 0& Then Exit Function
If (0& <> OpenClipboard(0&)) Then
If (0& <> EmptyClipboard()) Then
CopyPackedDIBtoClipboard = CBool(SetClipboardData(vbCFDIB, hGlobal) <> 0)
End If
Call CloseClipboard
End If
End Function
Reply With Quote