Сделать скриншот окна приложения - VB
Формулировка задачи:
Добрый день!
Как сделать, чтобы при нажатии на кнопку программа делала скриншот самой себя (сама форма не на весь экран), а затем сохраняла бы скрин в том месте, где укажет пользователь.
Решение задачи: «Сделать скриншот окна приложения»
textual
Листинг программы
- Option Explicit
- Private Type PicBmp
- size As Long
- Type As Long
- hBmp As Long
- hpal As Long
- Reserved As Long
- End Type
- Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
- Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
- Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
- Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
- Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
- Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
- Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
- Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As Any, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
- Private Sub Form_Click()
- Dim sDC As Long, dDC As Long, oBmp As Long, Bmp As Long, Pic As PicBmp, GUID(3) As Long, IPic As IPicture
- sDC = GetWindowDC(Me.hwnd)
- dDC = CreateCompatibleDC(sDC)
- Bmp = CreateCompatibleBitmap(sDC, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY)
- oBmp = SelectObject(dDC, Bmp)
- BitBlt dDC, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, sDC, 0, 0, vbSrcCopy
- SelectObject dDC, oBmp
- DeleteDC dDC
- ReleaseDC Me.hwnd, sDC
- GUID(0) = &H7BF80980
- GUID(1) = &H101ABF32
- GUID(2) = &HAA00BB8B
- GUID(3) = &HAB0C3000
- Pic.size = Len(Pic)
- Pic.Type = vbPicTypeBitmap
- Pic.hBmp = Bmp
- OleCreatePictureIndirect Pic, GUID(0), True, IPic
- If Not IPic Is Nothing Then
- SavePicture IPic, App.Path & "\Test.BMP"
- End If
- End Sub
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д