home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / I_A_F_-_Im216152912009.psc / BMPcapture.bas < prev    next >
BASIC Source File  |  2009-07-23  |  5KB  |  132 lines
  1. Attribute VB_Name = "BMPcapture"
  2.  
  3. Option Explicit
  4. Option Base 0
  5. Dim picht As Integer
  6. Dim picwt As Integer
  7. Dim clflag As Boolean
  8.  
  9. Private Type PALETTEENTRY
  10.    peRed As Byte
  11.    peGreen As Byte
  12.    peBlue As Byte
  13.    peFlags As Byte
  14. End Type
  15.  
  16. Private Type LOGPALETTE
  17.    palVersion As Integer
  18.    palNumEntries As Integer
  19.    palPalEntry(255) As PALETTEENTRY  ' Enough for 256 colors.
  20. End Type
  21.  
  22. Private Type GUID
  23.    Data1 As Long
  24.    Data2 As Integer
  25.    Data3 As Integer
  26.    Data4(7) As Byte
  27. End Type
  28.  
  29. Private Const RASTERCAPS As Long = 38
  30. Private Const RC_PALETTE As Long = &H100
  31. Private Const SIZEPALETTE As Long = 104
  32.  
  33. Private Type RECT
  34.    left As Long
  35.    top As Long
  36.    Right As Long
  37.    Bottom As Long
  38. End Type
  39.  
  40. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  41. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  42. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
  43. Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
  44. Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
  45. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  46. Private 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
  47. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  48. Private Declare Function GetForegroundWindow Lib "user32" () As Long
  49. Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
  50. Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
  51. Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
  52. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  53. Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  54. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
  55. Private Declare Function GetDesktopWindow Lib "user32" () As Long
  56.  
  57. Private Type PicBmp
  58.    Size As Long
  59.    Type As Long
  60.    hBmp As Long
  61.    hPal As Long
  62.    Reserved As Long
  63. End Type
  64. Dim sFile As String
  65. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  66.  
  67. Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
  68.   Dim R As Long
  69.    Dim Pic As PicBmp
  70.    Dim IPic As IPicture
  71.    Dim IID_IDispatch As GUID
  72.    With IID_IDispatch
  73.       .Data1 = &H20400
  74.       .Data4(0) = &HC0
  75.       .Data4(7) = &H46
  76.    End With
  77.    With Pic
  78.       .Size = Len(Pic)
  79.       .Type = vbPicTypeBitmap
  80.       .hBmp = hBmp
  81.       .hPal = hPal
  82.    End With
  83.    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
  84.    Set CreateBitmapPicture = IPic
  85. End Function
  86.   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
  87.   Dim hDCMemory As Long
  88.   Dim hBmp As Long
  89.   Dim hBmpPrev As Long
  90.   Dim R As Long
  91.   Dim hDCSrc As Long
  92.   Dim hPal As Long
  93.   Dim hPalPrev As Long
  94.   Dim RasterCapsScrn As Long
  95.   Dim HasPaletteScrn As Long
  96.   Dim PaletteSizeScrn As Long
  97.   Dim LogPal As LOGPALETTE
  98.    If Client Then
  99.       hDCSrc = GetDC(hWndSrc)
  100.    Else
  101.       hDCSrc = GetWindowDC(hWndSrc)
  102.    End If
  103.    hDCMemory = CreateCompatibleDC(hDCSrc)
  104.    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
  105.    hBmpPrev = SelectObject(hDCMemory, hBmp)
  106.    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)                                                   ' capabilities.
  107.    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
  108.    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
  109.    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
  110.       LogPal.palVersion = &H300
  111.       LogPal.palNumEntries = 256
  112.       R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
  113.       hPal = CreatePalette(LogPal)
  114.       hPalPrev = SelectPalette(hDCMemory, hPal, 0)
  115.       R = RealizePalette(hDCMemory)
  116.    End If
  117.    R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
  118.    hBmp = SelectObject(hDCMemory, hBmpPrev)
  119.    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
  120.       hPal = SelectPalette(hDCMemory, hPalPrev, 0)
  121.    End If
  122.    R = DeleteDC(hDCMemory)
  123.    R = ReleaseDC(hWndSrc, hDCSrc)
  124.    Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
  125. End Function
  126.  
  127. Public Function CaptureScreen(left As Single, top As Single, Width As Single, Height As Single) As Picture
  128.    Set CaptureScreen = CaptureWindow(GetDesktopWindow(), False, left, top, Width, Height)
  129. End Function
  130.  
  131.  
  132.