Как сохранить картинку(PrintScrn) в *.bmp или *.jpg ?

[KeePer]

Собственно нужно, что б после нажатия клавишы PrintScrn программа сама сохраняла изображение в bmp или jpg. Как перехватить нажатие этой клавиши я знаю, а вот как сделать так, что бы она сама сохраняла то, что в данный момент находится на экране я не знаю. Нашел код по данной тематике на "vbrussian", но он оказался не рабочим или у меня руки кривые .
Помогите пожалуйста.

[Aleksej]

В модуль:

Код: Выделить всё

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
On Error Resume Next
 
  Dim hDCMemory As Long
  Dim hBmp As Long
  Dim hBmpPrev 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
    GetSystemPaletteEntries hDCSrc, 0, 256, LogPal.palPalEntry(0)
    hPal = CreatePalette(LogPal)
    hPalPrev = SelectPalette(hDCMemory, hPal, 0)
    RealizePalette hDCMemory
  End If
  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
  DeleteDC hDCMemory
  ReleaseDC hWndSrc, hDCSrc
  Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
On Error Resume Next
 
  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

OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
Set CreateBitmapPicture = IPic
End Function


в обработку Print Scrn:

Код: Выделить всё

Dim hWndScreen As Long
  Dim CaptureScreen As Picture
  hWndScreen = GetDesktopWindow()
 
  Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY)
  Picture1.Picture = CaptureScreen
  SavePicture Picture1, "c:\test.bmp"


[KeePer]

Код у меня почему-то не работает. Вроде говорит, что функция не определена и еще ругается на Dim LogPal As LOGPALETTE Наверное должен быть какой-нибудь class.

hWndScreen = GetDesktopWindow() - функция не определна(VB)


Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width \
[/u]

[Aleksej]

Вот тебе объявления в модуль:

Код: Выделить всё

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

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

Public Declare Function GetDesktopWindow Lib "USER32.DLL" () As Long


А так всё должно работать, проверял.