define.bas

很好的教程原代码！

Attribute VB_Name = "Define"
Option Explicit

'常量说明
Public Const RASTERCAPS As Long = 38
Public Const RC_PALETTE As Long = &H100
Public Const SIZEPALETTE As Long = 104
Public Const EWX_LOGOFF = 0
Public Const EWX_REBOOT = 2
Public Const EWX_SHUTDOWN = 1

'Win32API函数的声明
Declare Function CreateCompatibleDC Lib "GDI32" _
    (ByVal hDC As Long) As Long
Declare Function CreateCompatibleBitmap Lib "GDI32" _
    (ByVal hDC As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long _
    ) As Long
Declare Function GetDeviceCaps Lib "GDI32" _
    (ByVal hDC As Long, _
    ByVal iCapabilitiy As Long _
    ) As Long
Declare Function GetSystemPaletteEntries Lib "GDI32" _
    (ByVal hDC As Long, _
    ByVal wStartIndex As Long, _
    ByVal wNumEntries As Long, _
    lpPaletteEntries As PALETTEENTRY _
    ) As Long
Declare Function CreatePalette Lib "GDI32" _
    (lpLogPalette As LOGPALETTE) As Long
Declare Function SelectObject Lib "GDI32" _
    (ByVal hDC As Long, _
    ByVal hObject As Long _
    ) As Long
Declare Function BitBlt Lib "GDI32" _
    (ByVal hDCDest As Long, _
    ByVal XDest As Long, _
    ByVal YDest As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hDCSrc As Long, _
    ByVal XSrc As Long, _
    ByVal YSrc As Long, _
    ByVal dwRop As Long _
    ) As Long
Declare Function DeleteDC Lib "GDI32" _
    (ByVal hDC As Long) As Long
Declare Function SelectPalette Lib "GDI32" _
    (ByVal hDC As Long, _
    ByVal hPalette As Long, _
    ByVal bForceBackground As Long _
    ) As Long
Declare Function RealizePalette Lib "GDI32" _
    (ByVal hDC As Long) As Long
Declare Function SetWindowPos Lib "USER32" _
    (ByVal hWnd As Long, _
    ByVal hWndInsertAfter As Long, _
    ByVal X As Long, ByVal Y As Long, _
    ByVal cx As Long, _
    ByVal cy As Long, _
    ByVal wFlags As Long _
    ) As Long
Declare Function ExitWindowsEx Lib "USER32" _
    (ByVal uFlags As Long, _
    ByVal dwReserved As Long _
    ) As Long
Declare Function GetWindowDC Lib "USER32" _
    (ByVal hWnd As Long) As Long
Declare Function GetDC Lib "USER32" _
    (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "USER32" _
    (ByVal hWnd As Long, _
    ByVal hDC As Long) As Long
Declare Function GetDesktopWindow Lib "USER32" () As Long
Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
    (PicDesc As PicBmp, _
    RefIID As GUID, _
    ByVal fPictureOwnsHandle As Long, _
    IPic As IPicture _
    ) As Long

'Win32API类型的声明
Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Type PicBmp
  Size As Long
  Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

Type PALETTEENTRY
  peRed As Byte
  peGreen As Byte
  peBlue As Byte
  peFlags As Byte
End Type

Type LOGPALETTE
  palVersion As Integer
  palNumEntries As Integer
  palPalEntry(255) As PALETTEENTRY
End Type

Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
    Dim r As Long
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With Pic
        .Size = Len(Pic)
        .Type = vbPicTypeBitmap
        .hBmp = hBmp
        .hPal = hPal
    End With
    r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    Set CreateBitmapPicture = IPic
End Function

Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim r As Long
    Dim hDCSrc As Long
    Dim hPal As Long
    Dim hPalPrev As Long
    Dim RasterCapsScrn As Long
    Dim HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long
    Dim LogPal As LOGPALETTE
    If Client Then
        hDCSrc = GetDC(hWndSrc)
    Else
        hDCSrc = GetWindowDC(hWndSrc)
    End If
    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        r = RealizePalette(hDCMemory)
    End If
    r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
    hBmp = SelectObject(hDCMemory, hBmpPrev)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If
    r = DeleteDC(hDCMemory)
    r = ReleaseDC(hWndSrc, hDCSrc)
    Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function