简单的,发送一个PrintScreen键出去, Option ExplicitPrivate Declare Sub keybd_event Lib "user32" ( _ ByVal bVk As Byte, _ ByVal bScan As Byte, _ ByVal dwFlags As Long, _ ByVal dwExtraInfo As Long)Private Const VK_SNAPSHOT As Byte = 44Private Sub Form_Load() Picture1.AutoRedraw = True End SubPrivate Sub Command1_Click() Dim x As Long Me.WindowState = 1 DoEvents Clipboard.Clear x = 0 '0-全屏 1-本窗口 keybd_event VK_SNAPSHOT, x, 0, 0 DoEvents Picture1.PaintPicture Clipboard.GetData(), 0, 0 End Sub 复杂的去网络上找现成代码吧,如果鼠标都要,则动用到更多的API函数就是.
我有一个例子 FrmCapture文件: VERSION 5.00 Begin VB.Form FrmCapture Caption = "Capture Screen" ClientHeight = 4470 ClientLeft = 60 ClientTop = 345 ClientWidth = 7605 Icon = "FrmCapture.frx":0000 LinkTopic = "Form1" ScaleHeight = 4470 ScaleWidth = 7605 StartUpPosition = 3 'Windows Default Begin VB.TextBox TxtPathName Height = 285 Left = 2820 TabIndex = 2 Top = 60 Width = 4755 End Begin VB.CommandButton CmdSave Caption = "Save To disk" Height = 330 Left = 1440 TabIndex = 1 Top = 60 Width = 1320 End Begin VB.VScrollBar VScroll1 Height = 3795 Left = 7320 TabIndex = 3 Top = 420 Width = 255 End Begin VB.HScrollBar HScroll1 Height = 255 Left = 0 TabIndex = 4 Top = 4200 Width = 7275 End Begin VB.PictureBox PicContainer AutoRedraw = -1 'True Height = 3765 Left = 0 ScaleHeight = 3705 ScaleWidth = 7245 TabIndex = 5 TabStop = 0 'False Top = 420 Width = 7305 Begin VB.PictureBox PicCapture AutoRedraw = -1 'True BorderStyle = 0 'None Height = 2070 Left = 60 ScaleHeight = 2070 ScaleWidth = 3645 TabIndex = 6 TabStop = 0 'False Top = 60 Width = 3645 End End Begin VB.Timer TCapture Enabled = 0 'False Interval = 1000 Left = 7260 Top = 4080 End Begin VB.CommandButton CmdCapture Caption = "Capture screen" Height = 330 Left = 75 TabIndex = 0 Top = 60 Width = 1320 End End Attribute VB_Name = "FrmCapture" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option ExplicitPrivate Type POINTAPI x As Long y As Long End TypePrivate Type PCURSORINFO cbSize As Long flags As Long hCursor As Long ptScreenPos As POINTAPI End Type 'To grab cursor shape -require at least win98 as per Microsoft documentation... Private Declare Function GetCursorInfo Lib "user32.dll" (ByRef pci As PCURSORINFO) As Long 'To get a Handle to the cursor Private Declare Function GetCursor Lib "USER32" () As Long 'To draw cursor shape on bitmap Private Declare Function DrawIcon Lib "USER32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
'to get the cursor position Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long 'to end a waiting loopp Dim GotIt As Boolean 'To use the scrollbars Dim lngVer As Long Dim lngHor As Long Const iconSize As Integer = 9 Private Sub CmdCapture_Click()
'hide the form Me.Visible = False
'start timer TCapture.Enabled = True 'wait Do While Not GotIt 'let windows work DoEvents Loop
'reset gotit GotIt = False
'enable saving CmdSave.Enabled = True 'show form again Me.Visible = True End SubPrivate Sub CmdSave_Click() On Error GoTo errHandler SavePicture PicCapture.Picture, TxtPathName.Text MsgBox "Picture " & TxtPathName.Text & " saved" Exit Sub errHandler: MsgBox "Error saving bmp as " & TxtPathName.Text & vbCrLf & "(" & Err.Description & ")" End SubPrivate Sub Form_Load() 'do not let save untill somethging has been captured CmdSave.Enabled = False 'size the internal picture to the size of the screen With PicCapture .Top = 0 .Left = 0 .Width = Screen.Width .Height = Screen.Height 'permit persistent drawing .AutoRedraw = True End With 'default path and name of bitmap saved TxtPathName.Text = AddSlash(App.Path) & "aaScreen.bmp" 'initialize scrollbars Call InitScroll(VScroll1) Call InitScroll(HScroll1) 'to move inside picture when changing scrollbars values 'lngVer = PicCapture.Height - PicContainer.Height 'lngHor = PicCapture.Width - PicContainer.Width End SubPrivate Sub Form_Resize() Dim TheHeight As Long Dim TheWidth As Long
If Me.WindowState <> vbMinimized Then TheHeight = Me.ScaleHeight - (CmdCapture.Top + CmdCapture.Height + 20 + HScroll1.Height) TheWidth = Me.ScaleWidth - VScroll1.Width - 20 'to move inside picture when changing scrollbars values With PicContainer If TheHeight > 100 Then .Height = TheHeight HScroll1.Top = Me.ScaleHeight - HScroll1.Height VScroll1.Height = TheHeight lngVer = PicCapture.Height - .Height 'make pictresize Call VScroll1_Change End If If TheWidth > 100 Then .Width = TheWidth VScroll1.Left = TheWidth + 20 HScroll1.Width = TheWidth lngHor = PicCapture.Width - .Width Call HScroll1_Change End If End With End If End SubPrivate Sub TCapture_Timer()
Dim Point As POINTAPI 'disable timer TCapture.Enabled = False 'capture screen If GetWinVersion >= 5 Then PicCapture.PaintPicture MCapture.getBackGround, 0, 0 Else
PicCapture.PaintPicture MCapture.CaptureScreen, 0, 0 End If
'get cursor position GetCursorPos Point
'now to get the icon of mouse and paint on form the mouse Dim pcin As PCURSORINFO pcin.hCursor = GetCursor pcin.cbSize = Len(pcin) Dim ret ret = GetCursorInfo(pcin) DrawIcon PicCapture.hDC, Point.x - iconSize, Point.y - iconSize, pcin.hCursor 'The following paint only mouse shape for this app 'DrawIcon PicCapture.hdc, Point.x - iconSize, Point.y - iconSize, CopyIcon(GetCursor) 'assign to picture the image Set PicCapture.Picture = PicCapture.Image 'clear clipboard here if you can On Error Resume Next Clipboard.Clear 'signal you've done to exit the waiting loop GotIt = True
End SubPrivate Function AddSlash(ByVal sPath As String) As String 'be sure a path ends correctly sPath = Trim(sPath) If Len(sPath) > 0 Then If Right$(sPath, 1) <> "/" Then If Right$(sPath, 1) <> "\" Then sPath = sPath & "\" End If End If AddSlash = sPath End If End FunctionPrivate Sub VScroll1_Change() 'make piccapture move on top down PicCapture.Top = -(lngVer * VScroll1.Value \ 100) End SubPrivate Sub HScroll1_Change() 'make inside picture mofe on left -right PicCapture.Left = -(lngHor * HScroll1.Value \ 100) End SubPrivate Sub InitScroll(ByVal vS As Object) With vS .Min = 0 .Max = 100 .SmallChange = 2 .LargeChange = 20 End With End Sub
MCapture.bas文件: Attribute VB_Name = "MCapture" Option Explicit 'This is enough for win2k 'capture screen-works finer on win2k Private Const VK_SNAPSHOT As Long = &H2C Private Const KEYEVENTF_KEYUP = &H2 'to press and release the print screen key Private Declare Sub keybd_event Lib "USER32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) '----------------------------------------------------------------- Private Declare Function GetVersion Lib "kernel32" () As Long '----------------------------------------------------------------- 'if win9x, the keybd_event trick to get a printscreen may fail 'thus the following is another way to get a screenshot 'These routines come from Msdn "HowTo Capture screen, a form or any window" Private Type PALETTEENTRY peRed As Byte peGreen As Byte peBlue As Byte peFlags As Byte End Type Private Type LOGPALETTE palVersion As Integer palNumEntries As Integer palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors. End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type #If Win32 Then Private Const RASTERCAPS As Long = 38 Private Const RC_PALETTE As Long = &H100 Private Const SIZEPALETTE As Long = 104 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC 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 GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, ByVal wStartIndex As Long, _ ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) As Long Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long 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 Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long Private Declare Function GetForegroundWindow Lib "USER32" () As Long Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette As Long, _ ByVal bForceBackground As Long) As Long Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function GetDesktopWindow Lib "USER32" () As Long Private Type PicBmp Size As Long Type As Long hBmp As Long hPal As Long Reserved As Long End Type Private Declare Function OleCreatePictureIndirect _ Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _ ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long #ElseIf Win16 Then Private Const RASTERCAPS As Integer = 38 Private Const RC_PALETTE As Integer = &H100 Private Const SIZEPALETTE As Integer = 104 Private Type RECT Left As Integer Top As Integer Right As Integer Bottom As Integer End Type Private Declare Function CreateCompatibleDC Lib "GDI" ( _ ByVal hDC As Integer) As Integer Private Declare Function CreateCompatibleBitmap Lib "GDI" ( _ ByVal hDC As Integer, ByVal nWidth As Integer, _ ByVal nHeight As Integer) As Integer Private Declare Function GetDeviceCaps Lib "GDI" ( _ ByVal hDC As Integer, ByVal iCapabilitiy As Integer) As Integer Private Declare Function GetSystemPaletteEntries Lib "GDI" ( _ ByVal hDC As Integer, ByVal wStartIndex As Integer, _ ByVal wNumEntries As Integer, _ lpPaletteEntries As PALETTEENTRY) As Integer Private Declare Function CreatePalette Lib "GDI" ( _ lpLogPalette As LOGPALETTE) As Integer Private Declare Function SelectObject Lib "GDI" ( _ ByVal hDC As Integer, ByVal hObject As Integer) As Integer Private Declare Function BitBlt Lib "GDI" ( _ ByVal hDCDest As Integer, ByVal XDest As Integer, _ ByVal YDest As Integer, ByVal nWidth As Integer, _ ByVal nHeight As Integer, ByVal hDCSrc As Integer, _ ByVal XSrc As Integer, ByVal YSrc As Integer, _ ByVal dwRop As Long) As Integer Private Declare Function DeleteDC Lib "GDI" ( _ ByVal hDC As Integer) As Integer Private Declare Function GetForegroundWindow Lib "USER" _ Alias "GetActiveWindow" () As Integer Private Declare Function SelectPalette Lib "USER" ( _ ByVal hDC As Integer, ByVal hPalette As Integer, ByVal _ bForceBackground As Integer) As Integer Private Declare Function RealizePalette Lib "USER" ( _ ByVal hDC As Integer) As Integer Private Declare Function GetWindowDC Lib "USER" ( _ ByVal hWnd As Integer) As Integer Private Declare Function GetDC Lib "USER" ( _ ByVal hWnd As Integer) As Integer Private Declare Function GetWindowRect Lib "USER" ( _ ByVal hWnd As Integer, lpRect As RECT) As Integer Private Declare Function ReleaseDC Lib "USER" ( _ ByVal hWnd As Integer, ByVal hDC As Integer) As Integer Private Declare Function GetDesktopWindow Lib "USER" () As Integer Private Type PicBmp Size As Integer Type As Integer hBmp As Integer hPal As Integer Reserved As Integer End Type Private Declare Function OleCreatePictureIndirect _ Lib "oc25.dll" (PictDesc As PicBmp, RefIID As GUID, _ ByVal fPictureOwnsHandle As Integer, IPic As IPicture) _ As Integer #End If (后面还有)
'------------------------------------------------------------------ 'This is enough on win2K Public Function getBackGround() As StdPicture 'IPictureDisp On Error Resume Next ' press prntScr key Dim picTmp As StdPicture 'try to clear clipboard Do DoEvents Err.Clear Clipboard.Clear Loop While Err.Number <> 0
keybd_event VK_SNAPSHOT, 0, 0, 0 ' release C key
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
Do
DoEvents Err.Clear Set picTmp = Clipboard.GetData(vbCFDIB)
Loop While Err.Number <> 0 DoEvents
Set getBackGround = picTmp End Function '------------------------------------------------------------------ 'The following is required on win9x #If Win32 Then Public Function CreateBitmapPicture(ByVal hBmp As Long, _ ByVal hPal As Long) As Picture Dim r As Long#ElseIf Win16 Then Public Function CreateBitmapPicture(ByVal hBmp As Integer, _ ByVal hPal As Integer) As Picture Dim r As Integer
#End If 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 #If Win32 Then 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 #ElseIf Win16 Then Public Function CaptureWindow(ByVal hWndSrc As Integer, _ ByVal Client As Boolean, ByVal LeftSrc As Integer, _ ByVal TopSrc As Integer, ByVal WidthSrc As Long, _ ByVal HeightSrc As Long) As Picture Dim hDCMemory As Integer Dim hBmp As Integer Dim hBmpPrev As Integer Dim r As Integer Dim hDCSrc As Integer Dim hPal As Integer Dim hPalPrev As Integer Dim RasterCapsScrn As Integer Dim HasPaletteScrn As Integer Dim PaletteSizeScrn As Integer #End If Dim LogPal As LOGPALETTE ' Depending on the value of Client get the proper device context. If Client Then hDCSrc = GetDC(hWndSrc) ' Get device context for client area. Else hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire ' window. End If ' 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 CaptureScreen() As Picture #If Win32 Then Dim hWndScreen As Long #ElseIf Win16 Then Dim hWndScreen As Integer #End If ' Get a handle to the desktop window. hWndScreen = GetDesktopWindow() ' Call CaptureWindow to capture the entire desktop give the handle ' and return the resulting Picture object. Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, _ Screen.Width \ Screen.TwipsPerPixelX, _ Screen.Height \ Screen.TwipsPerPixelY) End Function 'Public Function CaptureScreen(Left As Long, Top As Long, Width As Long, Height As Long) As StdPicture ' Dim srcDC As Long ' Dim trgDC As Long ' Dim BMPHandle As Long ' Dim dm As DEVMODE ' Dim picTmp As StdPicture ' srcDC = CreateDC("DISPLAY", "", "", dm) ' trgDC = CreateCompatibleDC(srcDC) ' BMPHandle = CreateCompatibleBitmap(srcDC, Width, Height) ' SelectObject trgDC, BMPHandle ' BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY ' OpenClipboard Screen.ActiveForm.hWnd ' EmptyClipboard ' SetClipboardData 2, BMPHandle ' ' CloseClipboard ' DeleteDC trgDC ' ReleaseDC BMPHandle, srcDC ' Set picTmp = Clipboard.GetData(vbCFBitmap) ' Set CaptureScreen = picTmp 'End FunctionPublic Function GetWinVersion() As String Dim Ver As Long, WinVer As Long Ver = GetVersion() WinVer = Ver And &HFFFF& 'retrieve the windows version GetWinVersion = Format((WinVer Mod 256) + ((WinVer \ 256) / 100), "Fixed") End Function我的QQ是371235270,E-MAIL:[email protected],我有源文件如果需要的话.
Option ExplicitPrivate Declare Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, _
ByVal bScan As Byte, _
ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)Private Const VK_SNAPSHOT As Byte = 44Private Sub Form_Load()
Picture1.AutoRedraw = True
End SubPrivate Sub Command1_Click()
Dim x As Long
Me.WindowState = 1
DoEvents
Clipboard.Clear
x = 0 '0-全屏 1-本窗口
keybd_event VK_SNAPSHOT, x, 0, 0
DoEvents
Picture1.PaintPicture Clipboard.GetData(), 0, 0
End Sub
复杂的去网络上找现成代码吧,如果鼠标都要,则动用到更多的API函数就是.
FrmCapture文件:
VERSION 5.00
Begin VB.Form FrmCapture
Caption = "Capture Screen"
ClientHeight = 4470
ClientLeft = 60
ClientTop = 345
ClientWidth = 7605
Icon = "FrmCapture.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4470
ScaleWidth = 7605
StartUpPosition = 3 'Windows Default
Begin VB.TextBox TxtPathName
Height = 285
Left = 2820
TabIndex = 2
Top = 60
Width = 4755
End
Begin VB.CommandButton CmdSave
Caption = "Save To disk"
Height = 330
Left = 1440
TabIndex = 1
Top = 60
Width = 1320
End
Begin VB.VScrollBar VScroll1
Height = 3795
Left = 7320
TabIndex = 3
Top = 420
Width = 255
End
Begin VB.HScrollBar HScroll1
Height = 255
Left = 0
TabIndex = 4
Top = 4200
Width = 7275
End
Begin VB.PictureBox PicContainer
AutoRedraw = -1 'True
Height = 3765
Left = 0
ScaleHeight = 3705
ScaleWidth = 7245
TabIndex = 5
TabStop = 0 'False
Top = 420
Width = 7305
Begin VB.PictureBox PicCapture
AutoRedraw = -1 'True
BorderStyle = 0 'None
Height = 2070
Left = 60
ScaleHeight = 2070
ScaleWidth = 3645
TabIndex = 6
TabStop = 0 'False
Top = 60
Width = 3645
End
End
Begin VB.Timer TCapture
Enabled = 0 'False
Interval = 1000
Left = 7260
Top = 4080
End
Begin VB.CommandButton CmdCapture
Caption = "Capture screen"
Height = 330
Left = 75
TabIndex = 0
Top = 60
Width = 1320
End
End
Attribute VB_Name = "FrmCapture"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option ExplicitPrivate Type POINTAPI
x As Long
y As Long
End TypePrivate Type PCURSORINFO
cbSize As Long
flags As Long
hCursor As Long
ptScreenPos As POINTAPI
End Type
'To grab cursor shape -require at least win98 as per Microsoft documentation...
Private Declare Function GetCursorInfo Lib "user32.dll" (ByRef pci As PCURSORINFO) As Long
'To get a Handle to the cursor
Private Declare Function GetCursor Lib "USER32" () As Long
'To draw cursor shape on bitmap
Private Declare Function DrawIcon Lib "USER32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
'to get the cursor position
Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
'to end a waiting loopp
Dim GotIt As Boolean
'To use the scrollbars
Dim lngVer As Long
Dim lngHor As Long
Const iconSize As Integer = 9
Private Sub CmdCapture_Click()
'hide the form
Me.Visible = False
'start timer
TCapture.Enabled = True
'wait
Do While Not GotIt
'let windows work
DoEvents
Loop
'reset gotit
GotIt = False
'enable saving
CmdSave.Enabled = True
'show form again
Me.Visible = True
End SubPrivate Sub CmdSave_Click()
On Error GoTo errHandler
SavePicture PicCapture.Picture, TxtPathName.Text
MsgBox "Picture " & TxtPathName.Text & " saved"
Exit Sub
errHandler:
MsgBox "Error saving bmp as " & TxtPathName.Text & vbCrLf & "(" & Err.Description & ")"
End SubPrivate Sub Form_Load()
'do not let save untill somethging has been captured
CmdSave.Enabled = False
'size the internal picture to the size of the screen
With PicCapture
.Top = 0
.Left = 0
.Width = Screen.Width
.Height = Screen.Height
'permit persistent drawing
.AutoRedraw = True
End With
'default path and name of bitmap saved
TxtPathName.Text = AddSlash(App.Path) & "aaScreen.bmp"
'initialize scrollbars
Call InitScroll(VScroll1)
Call InitScroll(HScroll1)
'to move inside picture when changing scrollbars values
'lngVer = PicCapture.Height - PicContainer.Height
'lngHor = PicCapture.Width - PicContainer.Width
End SubPrivate Sub Form_Resize()
Dim TheHeight As Long
Dim TheWidth As Long
If Me.WindowState <> vbMinimized Then
TheHeight = Me.ScaleHeight - (CmdCapture.Top + CmdCapture.Height + 20 + HScroll1.Height)
TheWidth = Me.ScaleWidth - VScroll1.Width - 20
'to move inside picture when changing scrollbars values
With PicContainer
If TheHeight > 100 Then
.Height = TheHeight
HScroll1.Top = Me.ScaleHeight - HScroll1.Height
VScroll1.Height = TheHeight
lngVer = PicCapture.Height - .Height
'make pictresize
Call VScroll1_Change
End If
If TheWidth > 100 Then
.Width = TheWidth
VScroll1.Left = TheWidth + 20
HScroll1.Width = TheWidth
lngHor = PicCapture.Width - .Width
Call HScroll1_Change
End If
End With
End If
End SubPrivate Sub TCapture_Timer()
Dim Point As POINTAPI
'disable timer
TCapture.Enabled = False
'capture screen
If GetWinVersion >= 5 Then
PicCapture.PaintPicture MCapture.getBackGround, 0, 0
Else
PicCapture.PaintPicture MCapture.CaptureScreen, 0, 0
End If
'get cursor position
GetCursorPos Point
'now to get the icon of mouse and paint on form the mouse
Dim pcin As PCURSORINFO
pcin.hCursor = GetCursor
pcin.cbSize = Len(pcin)
Dim ret
ret = GetCursorInfo(pcin)
DrawIcon PicCapture.hDC, Point.x - iconSize, Point.y - iconSize, pcin.hCursor
'The following paint only mouse shape for this app
'DrawIcon PicCapture.hdc, Point.x - iconSize, Point.y - iconSize, CopyIcon(GetCursor)
'assign to picture the image
Set PicCapture.Picture = PicCapture.Image
'clear clipboard here if you can
On Error Resume Next
Clipboard.Clear
'signal you've done to exit the waiting loop
GotIt = True
End SubPrivate Function AddSlash(ByVal sPath As String) As String
'be sure a path ends correctly
sPath = Trim(sPath)
If Len(sPath) > 0 Then
If Right$(sPath, 1) <> "/" Then
If Right$(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
End If
AddSlash = sPath
End If
End FunctionPrivate Sub VScroll1_Change()
'make piccapture move on top down
PicCapture.Top = -(lngVer * VScroll1.Value \ 100)
End SubPrivate Sub HScroll1_Change()
'make inside picture mofe on left -right
PicCapture.Left = -(lngHor * HScroll1.Value \ 100)
End SubPrivate Sub InitScroll(ByVal vS As Object)
With vS
.Min = 0
.Max = 100
.SmallChange = 2
.LargeChange = 20
End With
End Sub
MCapture.bas文件:
Attribute VB_Name = "MCapture"
Option Explicit
'This is enough for win2k
'capture screen-works finer on win2k
Private Const VK_SNAPSHOT As Long = &H2C
Private Const KEYEVENTF_KEYUP = &H2
'to press and release the print screen key
Private Declare Sub keybd_event Lib "USER32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'-----------------------------------------------------------------
Private Declare Function GetVersion Lib "kernel32" () As Long
'-----------------------------------------------------------------
'if win9x, the keybd_event trick to get a printscreen may fail
'thus the following is another way to get a screenshot
'These routines come from Msdn "HowTo Capture screen, a form or any window"
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors.
End Type Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type #If Win32 Then Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104 Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC 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 GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, ByVal wStartIndex As Long, _
ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject As Long) As Long
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
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetForegroundWindow Lib "USER32" () As Long
Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette As Long, _
ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "USER32" () As Long Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long #ElseIf Win16 Then Private Const RASTERCAPS As Integer = 38
Private Const RC_PALETTE As Integer = &H100
Private Const SIZEPALETTE As Integer = 104 Private Type RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type Private Declare Function CreateCompatibleDC Lib "GDI" ( _
ByVal hDC As Integer) As Integer
Private Declare Function CreateCompatibleBitmap Lib "GDI" ( _
ByVal hDC As Integer, ByVal nWidth As Integer, _
ByVal nHeight As Integer) As Integer
Private Declare Function GetDeviceCaps Lib "GDI" ( _
ByVal hDC As Integer, ByVal iCapabilitiy As Integer) As Integer
Private Declare Function GetSystemPaletteEntries Lib "GDI" ( _
ByVal hDC As Integer, ByVal wStartIndex As Integer, _
ByVal wNumEntries As Integer, _
lpPaletteEntries As PALETTEENTRY) As Integer
Private Declare Function CreatePalette Lib "GDI" ( _
lpLogPalette As LOGPALETTE) As Integer
Private Declare Function SelectObject Lib "GDI" ( _
ByVal hDC As Integer, ByVal hObject As Integer) As Integer
Private Declare Function BitBlt Lib "GDI" ( _
ByVal hDCDest As Integer, ByVal XDest As Integer, _
ByVal YDest As Integer, ByVal nWidth As Integer, _
ByVal nHeight As Integer, ByVal hDCSrc As Integer, _
ByVal XSrc As Integer, ByVal YSrc As Integer, _
ByVal dwRop As Long) As Integer
Private Declare Function DeleteDC Lib "GDI" ( _
ByVal hDC As Integer) As Integer
Private Declare Function GetForegroundWindow Lib "USER" _
Alias "GetActiveWindow" () As Integer
Private Declare Function SelectPalette Lib "USER" ( _
ByVal hDC As Integer, ByVal hPalette As Integer, ByVal _
bForceBackground As Integer) As Integer
Private Declare Function RealizePalette Lib "USER" ( _
ByVal hDC As Integer) As Integer
Private Declare Function GetWindowDC Lib "USER" ( _
ByVal hWnd As Integer) As Integer
Private Declare Function GetDC Lib "USER" ( _
ByVal hWnd As Integer) As Integer
Private Declare Function GetWindowRect Lib "USER" ( _
ByVal hWnd As Integer, lpRect As RECT) As Integer
Private Declare Function ReleaseDC Lib "USER" ( _
ByVal hWnd As Integer, ByVal hDC As Integer) As Integer
Private Declare Function GetDesktopWindow Lib "USER" () As Integer Private Type PicBmp
Size As Integer
Type As Integer
hBmp As Integer
hPal As Integer
Reserved As Integer
End Type Private Declare Function OleCreatePictureIndirect _
Lib "oc25.dll" (PictDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Integer, IPic As IPicture) _
As Integer #End If
(后面还有)
'This is enough on win2K
Public Function getBackGround() As StdPicture 'IPictureDisp
On Error Resume Next
' press prntScr key
Dim picTmp As StdPicture
'try to clear clipboard
Do
DoEvents
Err.Clear
Clipboard.Clear
Loop While Err.Number <> 0
keybd_event VK_SNAPSHOT, 0, 0, 0
' release C key
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
Do
DoEvents
Err.Clear
Set picTmp = Clipboard.GetData(vbCFDIB)
Loop While Err.Number <> 0
DoEvents
Set getBackGround = picTmp
End Function
'------------------------------------------------------------------
'The following is required on win9x
#If Win32 Then
Public Function CreateBitmapPicture(ByVal hBmp As Long, _
ByVal hPal As Long) As Picture Dim r As Long#ElseIf Win16 Then
Public Function CreateBitmapPicture(ByVal hBmp As Integer, _
ByVal hPal As Integer) As Picture Dim r As Integer
#End If
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
#If Win32 Then
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
#ElseIf Win16 Then
Public Function CaptureWindow(ByVal hWndSrc As Integer, _
ByVal Client As Boolean, ByVal LeftSrc As Integer, _
ByVal TopSrc As Integer, ByVal WidthSrc As Long, _
ByVal HeightSrc As Long) As Picture Dim hDCMemory As Integer
Dim hBmp As Integer
Dim hBmpPrev As Integer
Dim r As Integer
Dim hDCSrc As Integer
Dim hPal As Integer
Dim hPalPrev As Integer
Dim RasterCapsScrn As Integer
Dim HasPaletteScrn As Integer
Dim PaletteSizeScrn As Integer
#End If
Dim LogPal As LOGPALETTE ' Depending on the value of Client get the proper device context.
If Client Then
hDCSrc = GetDC(hWndSrc) ' Get device context for client area.
Else
hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire
' window.
End If ' 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 CaptureScreen() As Picture
#If Win32 Then
Dim hWndScreen As Long
#ElseIf Win16 Then
Dim hWndScreen As Integer
#End If ' Get a handle to the desktop window.
hWndScreen = GetDesktopWindow() ' Call CaptureWindow to capture the entire desktop give the handle
' and return the resulting Picture object. Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, _
Screen.Width \ Screen.TwipsPerPixelX, _
Screen.Height \ Screen.TwipsPerPixelY)
End Function
'Public Function CaptureScreen(Left As Long, Top As Long, Width As Long, Height As Long) As StdPicture
' Dim srcDC As Long
' Dim trgDC As Long
' Dim BMPHandle As Long
' Dim dm As DEVMODE
' Dim picTmp As StdPicture
' srcDC = CreateDC("DISPLAY", "", "", dm)
' trgDC = CreateCompatibleDC(srcDC)
' BMPHandle = CreateCompatibleBitmap(srcDC, Width, Height)
' SelectObject trgDC, BMPHandle
' BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY
' OpenClipboard Screen.ActiveForm.hWnd
' EmptyClipboard
' SetClipboardData 2, BMPHandle
'
' CloseClipboard
' DeleteDC trgDC
' ReleaseDC BMPHandle, srcDC
' Set picTmp = Clipboard.GetData(vbCFBitmap)
' Set CaptureScreen = picTmp
'End FunctionPublic Function GetWinVersion() As String
Dim Ver As Long, WinVer As Long
Ver = GetVersion()
WinVer = Ver And &HFFFF&
'retrieve the windows version
GetWinVersion = Format((WinVer Mod 256) + ((WinVer \ 256) / 100), "Fixed")
End Function我的QQ是371235270,E-MAIL:[email protected],我有源文件如果需要的话.
可以发个给我吗?
[email protected]