- Код: Выделить всё
Public Function CaptureWindow(ByVal hWndSrc&, ByVal LeftSrc&, _
ByVal TopSrc&, ByVal WidthSrc&, _
ByVal HeightSrc&) As Picture
Dim hDCMemory&
Dim hBmp&
Dim hBmpPrev&
Dim r&
Dim hDCSrc&
Dim hPal&
Dim hPalPrev&
Dim RasterCapsScrn&
Dim HasPaletteScrn&
Dim PaletteSizeScrn&
Dim LogPal As LOGPALETTE
' Depending on the value of Client get the proper device context.
hDCSrc = GetDCEx(hWndSrc, 0&, DCX_CACHE Or DCX_CLIPCHILDREN) ' Get device context for client area.
' Create a memory device context for the copy process.
hDCMemory = CreateCompatibleDC(hDCSrc)
' Create a bitmap and place it in the memory DC.
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
' Get screen properties.
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster capabilities.
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette support.
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of palette.
' If the screen has a palette make a copy and realize it.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
' Create a copy of the system palette.
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
' Select the new palette into the memory DC and realize it.
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
' Copy the on-screen image into the memory DC.
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
' Remove the new copy of the on-screen image.
hBmp = SelectObject(hDCMemory, hBmpPrev)
' If the screen has a palette get back the palette that was
' selected in previously.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
' Release the device context resources back to the system.
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)
' Call CreateBitmapPicture to create a picture object from the
' bitmap and palette handles. Then return the resulting picture
' object.
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function
Public Function CreateBitmapPicture(ByVal hBmp&, ByVal hPal&) As Picture
Dim r&
Dim Pic As PicBmp
' IPicture requires a reference to "Standard OLE Types."
Dim IPic As IPicture
Dim IID_IDispatch As GUID
' Fill in with IDispatch Interface ID.
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Fill Pic with necessary parts.
With Pic
.Size = Len(Pic) ' Length of structure.
.Type = vbPicTypeBitmap ' Type of Picture (bitmap).
.hBmp = hBmp ' Handle to bitmap.
.hPal = hPal ' Handle to palette (may be null).
End With
' Create Picture object.
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
' Return the new Picture object.
Set CreateBitmapPicture = IPic
End Function
В чём проблема и как её решить?
