VB截图程序

自定义截图为command1全屏command4清除截图command5抓取活动窗口command7保存截图command2打印结果command6退出command3Form1 CommonDialog控件Timer无边框的form2 Label Shape左上角右上角左下角右下角代码如下：form1全部代码Private Sub Form_Load()Timer1.Interval = 55 设定时间, 如果太小的话,程序来回晃了End Sub 使得窗口隐藏如果需要按键组合:则If GetAsyncKeyState(vbKeyF12) And GetAsyncKeyState(vbKeyControl) And GetAsyncKeyState(vbKeyMenu) Then其中的(vbkey)就是按键码,(vbkeycontrol)代表Ctrl键(vbKeyMenu)代表Alt键Private Sub Timer1_Timer()If GetAsyncKeyState(vbKeyMenu) And GetAsyncKeyState(vbKeyS) Then 检查是否按下Alt+S键If Form1.Visible = True ThenForm1.Visible = False 或 form1.hideElseIf Form1.Visible = False ThenForm1.Visible = True 或 form1.showEnd IfEnd IfEnd Sub 抓取整屏Private Sub Command4_Click() Dim EndTime As Date EndTime = DateAdd(s, 0.001, Now) Do Until Now EndTime DoEvents Loop Set Picture1.Picture = CaptureScreen()End SubPrivate Sub Command4_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = 1 Then MsgBox 请使用键盘快捷键Alt+S End If Button参数说明: 1:鼠标左键 2:鼠标右键 4:鼠标中键End Sub 清除PictureBox中的结果.Private Sub Command5_Click() Set Picture1.Picture = LoadPicture(E:图片花.jpg) nothingEnd Sub 打印PictureBox中现在显示的结果.Private Sub Command6_Click() PrintPictureToFitPage Printer, Picture1.Picture Printer.EndDocEnd Sub 两秒后抓取活动窗口。Private Sub Command7_Click() MsgBox 关闭此对话框2秒后将抓取活动窗口。 提示对话框 Dim EndTime As Date EndTime = DateAdd(s, 2, Now) Do Until Now EndTime DoEvents Loop Set Picture1.Picture = CaptureActiveWindow() 设立焦点到窗口。 Me.SetFocusEnd Sub 抓取窗口任意部分的函数 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 抓取整个屏幕的函数Public Function CaptureScreen() As Picture Dim hWndScreen As Long 设置桌面窗体对象 hWndScreen = GetDesktopWindow() Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width Screen.TwipsPerPixelX, Screen.Height Screen.TwipsPerPixelY)End Function 抓取活动窗口的函数Public Function CaptureActiveWindow() As Picture Dim hWndActive As Long Dim r As Long Dim RectActive As RECT hWndActive = GetForegroundWindow() r = GetWindowRect(hWndActive, RectActive) Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)End Function 实现打印的函数Public Sub PrintPictureToFitPage(Prn As Printer, Pic As Picture) Const vbHiMetric As Integer = 8 Dim PicRatio As Double Dim PrnWidth As Double Dim PrnHeight As Double Dim PrnRatio As Double Dim PrnPicWidth As Double Dim PrnPicHeight As Double If Pic.Height = Pic.Width Then Prn.Orientation = vbPRORPortrait Else Prn.Orientation = vbPRORLandscape End If PicRatio = Pic.Width / Pic.Height PrnWidth = Prn.ScaleX(Prn.ScaleWidth, Prn.ScaleMode, vbHiMetric) PrnHeight = Prn.ScaleY(Prn.ScaleHeight, Prn.ScaleMode, vbHiMetric) PrnRatio = PrnWidth / PrnHeight If PicRatio = PrnRatio Then PrnPicWidth = Prn.ScaleX(PrnWidth, vbHiMetric, Prn.ScaleMode) PrnPicHeight = Prn.ScaleY(PrnWidth / PicRatio, vbHiMetric, Prn.ScaleMode) Else PrnPicHeight = Prn.ScaleY(PrnHeight, vbHiMetric, Prn.ScaleMode) PrnPicWidth = Prn.ScaleX(PrnHeight * PicRatio, vbHiMetric, Prn.ScaleMode) End If Prn.PaintPicture Pic, 0, 0, PrnPicWidth, PrnPicHeightEnd SubForm2全部代码Private Sub Form_DblClick() Set Form1.Picture1.Picture = CaptureWindow(Form2.hWnd, Shape1.Left Screen.TwipsPerPixelX, Shape1.Top Screen.TwipsPerPixelY, Shape1.Width Screen.TwipsPerPixelX, Shape1.Height Screen.TwipsPerPixelY) DoEvents Unload MeEnd SubPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = 27 Then 27为esc Unload Me End IfEnd SubPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) oldX = x - Shape1.Left oldY = y - Shape1.TopEnd SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = 1 Then Shape1.Left = x - oldX Shape1.Top = y - oldY Label1(0).Left = x - oldX - Label1(0).Width Label1(0).Top = y - oldY - Label1(0).Height Label1(1).Left = Shape1.Left + Shape1.Width Label1(1).Top = Shape1.Top - Label1(1).Height Label1(2).Left = x - oldX - Label1(2).Width Label1(2).Top = y - oldY + Shape1.Height Label1(3).Left = Shape1.Left + Shape1.Width Label1(3).Top = Shape1.Top + Shape1.Height End IfEnd SubPrivate Sub Form_Unload(Cancel As Integer) Form1.ShowEnd SubPrivate Sub Label1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) oldX = x oldY = y Print oldX, oldYEnd SubPrivate Sub Label1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) On Error Resume Next If Button = 1 Then Label1(Index).Move Label1(Index).Left + x - oldX, Label1(Index).Top + y - oldY Select Case Index Case 0 Label1(2).Left = Label1(0).Left Label1(1).Top = Label1(0).Top Case 1 Label1(0).Top = Label1(1).Top Label1(3).Left = Label1(1).Left Case 2 Label1(0).Left = Label1(2).Left Label1(3).Top = Label1(2).Top Case 3 Label1(1).Left = Label1(3).Left Label1(2).Top = Label1(3).Top End Select Shape1.Move Label1(0).Left + Label1(0).Width, _ Label1(0).Top + Label1(0).Height, _ Label1(1).Left - Label1(0).Left - Label1(0).Width, _ Label1(3).Top - Label1(1).Top - Label1(1).Height End IfEnd SubModule1模块代码Option ExplicitOption Base 0Public 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 LongPublic Const HWND_TOPMOST = -1Public Const SWP_SHOWWINDOW = &H40Public Type PALETTEENTRY peRed As Byte peGreen As Byte peBlue As Byte peFlags As ByteEnd Type自己添加的Public Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypePublic Type LOGPALETTE palVersion As Integer palNumEntries As Integer palPalEntry(255) As PALETTEENTRY Enough for 256 colors.End TypePublic Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As ByteEnd TypePublic Const RASTERCAPS As Long = 38Public Const RC_PALETTE As Long = &H100Public Const SIZEPALETTE As Long = 104 声明API函数Public Declare Function CreateCompatibleDC Lib GDI32 (ByVal hDC As Long) As LongPublic Declare Function CreateCompatibleBitmap Lib GDI32 (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As LongPublic Declare Function GetDeviceCaps Lib GDI32 (ByVal hDC As Long, ByVal iCapabilitiy As Long) As LongPublic Declare Function GetSystemPaletteEntries Lib GDI32 (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As LongPublic Declare Function CreatePalette Lib GDI32 (lpLogPalette As LOGPALETTE) As LongPublic Declare Function SelectObject Lib GDI32 (ByVal hDC As Long, ByVal hObject As Long) As LongPublic 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 LongPublic Declare Function DeleteDC Lib GDI32 (ByVal hDC As Long) As LongPublic Declare Function SelectPalette Lib GDI32 (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As LongPublic Declare Function RealizePalette Lib GDI32 (ByVal hDC As Long) As LongPublic Declare Function GetWindowDC Lib user32 (ByVal hWnd As Long) As LongPublic Declare Function GetDC Lib user32 (ByVal hWnd As Long) As LongPublic Declare Function ReleaseDC Lib user32 (ByVal hWnd As Long, ByVal hDC As Long) As LongPublic Declare Function GetDesktopWindow Lib user32 () As LongPublic Declare Function GetWindowRect Lib user32 (ByVal hWnd As Long, lpRect As RECT) As LongPublic Declare Function GetForegroundWindow Lib user32 () As LongPublic Declare Function GetAsyncKeyState Lib user32 (ByVal vKey As Long) As Integer 全局热键声明Public Type PicBmp Size As LongType As Long hBmp As Long hPal As Long Reserved As LongEnd TypePublic Declare Function OleCreatePictureIndirect Lib olepro32.dll (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As LongPublic Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture Dim r As Long 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 = IPicEnd FunctionPublic Function CaptureWindow(ByVal hWndSrc As Long, 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 hDCSrc = GetWindowDC(hWndSrc) Get device context for entire 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(hDCS