您可以去www.applevb.com
www.vbgood.com
www.21code.com上查找关于放大的程序,和您的要求差不多
www.vbgood.com
www.21code.com上查找关于放大的程序,和您的要求差不多
解决方案 »
- 怎么用VB获得另一程序中进度条的进度
- 怎么用vb.net实现单击网页中的按钮的功能?
- VB下如何实现网络的流量监视
- 哪位高手有好办法做到!
- 如何读取表中的字段名
- 怎样才能在Combobox下来列表中选中一项时触发一个事件?onchange怎么不能响应这个动作?
- 高分请教:用vb如何做试用版的软件?(就是好像用几天就不能用了之类的效果)?
- 怎么把针对vb的帮助调出来
- (重分酬谢)这个程序好象存在死循环,自己找不出问题,希望您能指教一下(高分酬谢)
- VB怎样多线程编程?
- 向VB爱好者们请教!如何在VB代码中引用CREATE TABLE,CREATE VIEW等语句呢?
- “好久没进城了,变化真大啊”前两年我用VB5、6编程,现在突然有人和我说VB.NET,谁能给我介绍一下VB.NET是什么啊?
' CaptureClient - Captures the client area of a form.
' CaptureScreen - Captures the entire screen.
' PrintPictureToFitPage - prints any picture as big as possible on
' the page.
'
' NOTES
' - No error trapping is included in these routines.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
Option Explicit
Option Base 0Public CTLMode As Integer
Public CTLSize As Single
Public CTLZoom As Single
Public Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End 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 Byte
End TypePublic Const RASTERCAPS As Long = 38
Public Const RC_PALETTE As Long = &H100
Public Const SIZEPALETTE As Long = 104Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End TypePublic Type POINTAPI
x As Long
y As Long
End TypeDim Bx As Single, By As SinglePublic Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Public Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Public Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Public 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
Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Public Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPublic Declare Function CreateEllipticRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Public Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Public Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, ByVal x3 As Long, ByVal y3 As Long) As Long
Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Public Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End TypePublic Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Dim P As Picture
Refresh
DoEvents
Set P = CaptureWindow(Pic.hWnd, False, 0, 0, Pic.Width, Pic.Height)
Set Pic.Picture = P
SavePicture Pic.Picture, FileName
Set P = Nothing
End SubPublic Function CaptureScreen() As Picture
Dim hWndScreen As Long ' 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 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 ' 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 FunctionPublic Function CaptureActiveWindow() As Picture Dim hWndActive As Long
Dim r As Long
Dim RectActive As RECT
' Get a handle to the active/foreground window.
hWndActive = GetForegroundWindow()
' Get the dimensions of the window.
r = GetWindowRect(hWndActive, RectActive)
' Call CaptureWindow to capture the active window given its
' handle and return the Resulting Picture object.
Set CaptureActiveWindow = CaptureWindow(hWndActive, False, 0, 0, RectActive.Right - RectActive.Left, RectActive.Bottom - RectActive.Top)
End FunctionPublic 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 = IPic
End Function
Public Function CaptureArea(xmin!, ymin!, xmax!, ymax!) As Picture
Dim hWndScreen As Long ' 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 CaptureArea = CaptureWindow(hWndScreen, False, xmin, ymin, xmax, ymax)
End Function
CommonDialog
PictureBox
VScroll1
HScroll1
mCopyScreen (Command)
mSaveFile (Command)
Option Explicit
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 GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As LongSub SetPicture()
picCopy.Visible = True
If picCopy.Width <= Picture1.ScaleWidth Then
picCopy.Left = (Picture1.ScaleWidth - picCopy.Width) / 2
Else
picCopy.Left = 0
HScroll1.Min = 0
HScroll1.Value = 0
HScroll1.Max = picCopy.Width - Picture1.ScaleWidth
HScroll1.SmallChange = HScroll1.Max / 100
HScroll1.LargeChange = HScroll1.Max / 10
End If If picCopy.Height <= Picture1.ScaleHeight Then
picCopy.Top = (Picture1.ScaleHeight - picCopy.Height) / 2
Else
picCopy.Top = 0
VScroll1.Min = 0
VScroll1.Value = 0
VScroll1.Max = picCopy.Height - Picture1.ScaleHeight
VScroll1.SmallChange = VScroll1.Max / 100
VScroll1.LargeChange = VScroll1.Max / 10
End If
End SubPrivate Sub Form_Resize()
On Error Resume Next
Picture1.Width = Me.ScaleWidth - VScroll1.Width
Picture1.Height = Me.ScaleHeight - HScroll1.Height
VScroll1.Left = Picture1.Width
HScroll1.Top = Picture1.Height
VScroll1.Height = Picture1.Height
HScroll1.Width = Picture1.Width
SetPicture
End SubPrivate Sub HScroll1_Change()
picCopy.Left = -HScroll1.Value
End Sub
Private Sub mCopyScreen_Click()
Dim hDC As Long, sx As Integer, sy As Integer
Me.Hide
DoEvents
picCopy.Width = Screen.Width
picCopy.Height = Screen.Height
picCopy.AutoRedraw = True
hDC = GetDC(0)
sx = Screen.Width \ Screen.TwipsPerPixelX
sy = Screen.Height \ Screen.TwipsPerPixelY
BitBlt picCopy.hDC, 0, 0, sx, sy, hDC, 0, 0, vbSrcCopy
ReleaseDC 0, hDC
picCopy.AutoRedraw = False
SetPicture
Me.Show
End SubPrivate Sub mSaveFile_Click()
On Error Resume Next
With CommonDialog1
.DialogTitle = "存储文件"
.Filter = "位图文件(*.bmp)|*.bmp"
.CancelError = True
.ShowOpen
If Err.Number <> cdlCancel Then
SavePicture picCopy.Picture, .FileName
End If
End With
End SubPrivate Sub VScroll1_Change()
picCopy.Top = -VScroll1.Value
End Sub
就是发送 PRTSC 或者 ALT+PRTSC 键。用几个API就可以了,程序只有几行。
实现抓取任意屏幕,任意大小的图像。
可现在仅能抓VB本窗体的图像,若先最小化窗体后,则立刻出现像死机一样的情况,是不是当前窗体的句柄与捕获的鼠标的位置发生了冲突。反正现在就是不能抓取其它屏幕的图像。
请您帮帮我,修改一下,以达到以上的效果。谢谢了。
我的Email: [email protected]
VB爱好者:一平