回 帖 发 新 帖 刷新版面

主题:如何实现活动窗口抓图

Private Sub Command2_Click()
Dim hActiveWindow As Long
   Dim RectActive As RECT
   Dim hDC2 As Long
  Form2.Picture = LoadPicture("")
   
   Form2.Cls
   Form1.Picture1.Cls
   Form1.WindowState = 1
   Form2.AutoRedraw = True
   Form1.Picture1.AutoRedraw = True
   DoEvents
   hActiveWindow = GetForegroundWindow()
   GetWindowRect hActiveWindow, RectActive
   Form2.Cls
   If Form2.WindowState = 2 Then
   Form2.Hide
   Else
   Form2.Picture = LoadPicture("")
   Form2.Width = (RectActive.Right - RectActive.Left) * Screen.TwipsPerPixelX + BorderWidth
   Form2.Height = (RectActive.Bottom - RectActive.Top) * Screen.TwipsPerPixelY + BorderWidth
   End If
   
   hDC2 = GetWindowDC(hActiveWindow)
   BitBlt Form2.hdc, 0, 0, Form2.Width, Form2.Height, hDC2, 0, 0, vbSrcCopy
   ReleaseDC hActiveWindow, hDC2
   Form2.Picture = Form2.Image
  
   If Form2.Width = 0 Then
   Dim fx As Integer
   Dim fy As Integer
   Dim hdc As Long
   Form1.Picture1.Cls
   Form2.Cls
   
   Form1.WindowState = 1
   DoEvents
   Form1.Picture1.AutoRedraw = True
   Form2.Width = Screen.Width
   Form2.Height = Screen.Height
   
   hdc = GetDC(0)
   fx = Screen.Width / Screen.TwipsPerPixelX
   fy = Screen.Height / Screen.TwipsPerPixelY
   BitBlt Form2.hdc, 0, 0, fx, fy, hdc, 0, 0, vbSrcCopy
   ReleaseDC 0, hdc
   Form2.Picture = Form2.Image
   Form1.Picture1.PaintPicture Form2.Picture, 80, 80, Form1.Picture1.Width - 200, Form1.Picture1.Height - 200, 0, 0, Form2.Width, Form2.Height
   Form1.WindowState = 0
   
   Else
    Form1.Picture1.PaintPicture Form2.Picture, 80, 80, Form1.Picture1.Width - 200, Form1.Picture1.Height - 200, 0, 0, Form2.Width, Form2.Height
 End If
   Form1.Show
   Form1.WindowState = 0   
End Sub

为了简化编写,没用两个Picture控件,采用两个form,但在运行时,出现图像重叠,加doevents也无多大效果,这是怎么回事?怎么样才能消除?

回复列表 (共5个回复)

沙发

我没有过细看你这段代码,因为我自己写的抓取屏幕图形的代码我觉得效果还不错,发上来供你参考。
在Form1窗体上添加一个图片框,用于显示抓取到的图形。
在Form2窗体上添加一个Shape控件,DrawMode属性设置为1,在运行中用它来套取屏幕图形。

Form1的抓取按纽代码如下:

Private Sub Command1_Click() '抓取按纽
Picture1.AutoRedraw = True
Picture1.ScaleMode = 3
Picture1.Cls
Me.Hide
DoEvents
Form2.Show 1
Me.Show
End Sub


Form2的代码如下:

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 Long

Dim hDtDc As Long
Dim ImageSize As Long

Private Sub Form_Load()
Me.ScaleMode = 3
Me.AutoRedraw = True
Shape1.DrawMode = 1
Move 0, 0, Screen.Width, Screen.Height
ImageSize = Form1.Picture1.ScaleWidth 'ImageSize的值在屏幕范围内可以任意设置,单位是像素
Shape1.Width = ImageSize: Shape1.Height = ImageSize
hDtDc = GetDC(0) '获取屏幕句柄
BitBlt Me.hDc, 0, 0, Screen.Width \ 15, Screen.Height \ 15, hDtDc, 0, 0, vbSrcCopy '复制屏幕
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Shape1.Move X - ImageSize, Y - ImageSize
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
BitBlt Form1.Picture1.hDc, 0, 0, ImageSize, ImageSize, Me.hDc, X - ImageSize, Y - ImageSize, vbSrcCopy
ReleaseDC 0, hDtDc
Unload Me
End Sub

板凳

谢谢,我已经解决了,为了便于保存又增加了个窗口和picture控件,上面也可以,出现的原因是底层图片没有清除,中间的if else句是为了解决如果没有窗口时按桌面抓取图像,还有个问题GetForegroundWindow()它有没有返回值,我没法知道当没有窗口时它的返回值,只好用if else解决,想问下这个API函数,没有窗口时,怎么用这个函数怎么处理?
Private Sub Command2_Click()
   Dim hActiveWindow As Long
   Dim RectActive As RECT
   Dim hDC2 As Long
   Form1.Picture1.Cls
   Form2.Cls
   Form2.Picture = LoadPicture("")
   Form1.Picture1 = LoadPicture("")
   Form3.Picture1.Cls
   Form3.Picture1 = LoadPicture("")
   Form1.Picture1.AutoRedraw = True
   Form3.Picture1.AutoRedraw = True
   Form1.WindowState = 1
   DoEvents
   hActiveWindow = GetForegroundWindow()
   GetWindowRect hActiveWindow, RectActive
   DoEvents
   Form3.Picture1.Width = (RectActive.Right - RectActive.Left) * Screen.TwipsPerPixelX + BorderWidth
   Form3.Picture1.Height = (RectActive.Bottom - RectActive.Top) * Screen.TwipsPerPixelY + BorderWidth
   hDC2 = GetWindowDC(hActiveWindow)
   DoEvents
   BitBlt Form3.Picture1.hdc, 0, 0, Form3.Picture1.Width, Form3.Picture1.Height, hDC2, 0, 0, vbSrcCopy
   ReleaseDC hActiveWindow, hDC2
   Form3.Picture1.Picture = Form3.Picture1.Image
   If Form3.Picture1.Width = 75 Then
   Dim fx As Integer
   Dim fy As Integer
   Dim hdc As Long
   Form1.Picture1.Cls
   Form2.Cls
   Form2.Picture = LoadPicture("")
   Form1.WindowState = 1
   DoEvents
   Form1.Picture1.AutoRedraw = True
   If Form2.WindowState = 2 Then
   Else
   Form2.Width = Screen.Width
   Form2.Height = Screen.Height
   End If
   hdc = GetDC(0)
   fx = Screen.Width / Screen.TwipsPerPixelX
   fy = Screen.Height / Screen.TwipsPerPixelY
   BitBlt Form2.hdc, 0, 0, fx, fy, hdc, 0, 0, vbSrcCopy
   ReleaseDC 0, hdc
   Form2.Picture = Form2.Image
   Form1.Picture1.PaintPicture Form2.Picture, 80, 80, Form1.Picture1.Width - 200, Form1.Picture1.Height - 200, 0, 0, Form2.Width, Form2.Height
   Form1.WindowState = 0
   Else
   DoEvents
   Form1.Picture1.PaintPicture Form3.Picture1.Picture, 80, 80, Form1.Picture1.Width - 200, Form1.Picture1.Height - 200, 0, 0, Form3.Picture1.Width, Form3.Picture1.Height
   Form1.Show
   Form1.WindowState = 0
   End If
   End Sub

Private Sub Command3_Click()
Dim fx As Integer
Dim fy As Integer
Dim hdc As Long
DoEvents
DoEvents
Form2.Picture = LoadPicture("")
Form2.Cls
Form1.Picture1.Cls
Form1.WindowState = 1
DoEvents
Form1.Picture1.AutoRedraw = True
If Form2.WindowState = 2 Then
Form2.Hide
DoEvents
Else
Form2.Width = Screen.Width
Form2.Height = Screen.Height
End If
hdc = GetDC(0)
fx = Screen.Width / Screen.TwipsPerPixelX
fy = Screen.Height / Screen.TwipsPerPixelY
BitBlt Form2.hdc, 0, 0, fx, fy, hdc, 0, 0, vbSrcCopy
ReleaseDC 0, hdc
Form2.Picture = Form2.Image
Form2.Show
Form2.WindowState = 2
End Sub

3 楼

这是一个API函数,怎会没有返回值?它的返回值是前台窗口的句柄

4 楼

顶啊,我就是不知道场景用来干什么的

5 楼


是没有返回值,无法得到,请高手指教

我来回复

您尚未登录,请登录后再回复。点此登录或注册