（转）模拟QQ截屏

QQ确实太占资源了， 物理内存和虚拟内存加起来大概有40多M，不过他提供的屏幕截图功能却是不错，能方便的选取能所感兴趣的区域图片，本文试图用VB模拟这一功能，当然功能还是要比QQ截屏少一点，但基本的功能以完备。

       截屏原理：QQ截屏应该时先把当前屏幕的内容拷贝到一个窗体，并且这个窗体和屏幕一样大，然后再对这个窗体上的图片进行处理，因此在使用QQ截屏的时候你会发现托盘区那个网络链接的图标不会有变换，把鼠标放在时间上也不会有日期提示了。

      知道了原理，用VB来实现也不时一件难事了。

     窗体及倥件设置：一个picturebox，picture属性设置为你自己想要的图片（既然模仿QQ，就用他截屏时出现再屏幕顶部那个图片吧），其上有几个label倥件数组(lblInfo(0~4))，用来显示提示信息的。一个Timer倥件，interal设置为20，用来模拟QQ截屏时提示图片的下拉效果。一个shape倥件,形状为矩形，边框样式为虚线点装。设置窗体的borderstyle为无边框的，showintaskbar属性为true(一定要为True).，keypreview属性为true.

  下面是代码：

'程序实现功能：模拟QQ截屏
'作    者： laviewpbt
'联系方式： laviewpbt@sina.com
'QQ:33184777
'版本：Version 1.0.0
'说明：复制请保留源作者信息，转载请说明，欢迎大家提出意见和建议

Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData 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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private 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 Long
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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim OriginalX As Single   '区域起点X坐标
Dim OriginalY As Single   '区域起点的Y坐标
Dim NewX As Single
Dim NewY As Single
Dim Status As String      '当前状态（正在选择区域或者拖动区域）
Dim rc As RECT            '区域的范围
Dim ptInPic As Boolean     '鼠标是否位于pic上

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

'*************************************************************************
'**    作    者 ：    未知
'**    函 数 名 ：    GetRGBColors
'**    输    入 ：    省
'**    输    出 ：    无
'**    功能描述 ：    得到RGB值
'**    日    期 ：    2005-10-24 20.10.56
'**    修 改 人 ：    laviewpbt
'**    日    期 ：    2005-10-24 20.11.23
'**    版    本 ：    Version 1.2.1
'*************************************************************************
Private Sub GetRGBColors(ByVal RGBColor As Long, ByRef RedColor As Long, ByRef GreenColor As Long, ByRef BlueColor As Long)
    RedColor = RGBColor Mod 256
    GreenColor = (RGBColor / &H100) Mod 256
    BlueColor = (RGBColor / &H10000) Mod 256
End Sub

'*************************************************************************
'**    作    者 ：    laviewpbt
'**    函 数 名 ：    EDcode
'**    输    入 ：    index(Integer)    -  提示编码
'**    输    出 ：    无
'**    功能描述 ：    改变提示信息
'**    日    期 ：    2005-10-26 17.49.54
'**    修 改 人 ：
'**    日    期 ：
'**    版    本 ：    Version 1.2.1
'*************************************************************************

Public Sub SetTitle(Index As Integer)
    Select Case Index
      Case 1
        lblInfo(0).Caption = "* 按住鼠标左键不放选择" & vbCrLf & "   截图的范围."
        lblInfo(1).Caption = "* 按ESC键退出."
        lblInfo(2).Caption = ""
      Case 2
        lblInfo(0).Caption = "* 松开鼠标左键确定截图" & vbCrLf & "   的范围."
        lblInfo(1).Caption = "* 按ESC键退出."
        lblInfo(2).Caption = ""
      Case 3
        lblInfo(0).Caption = "* 用鼠标左键调整截图的" & vbCrLf & "   位置."
        lblInfo(1).Caption = "* 双击选取区域保存图片."
        lblInfo(2).Caption = "* 按ESC键退出."
    End Select
End Sub

Private Sub Form_Load()
        Picture1.Top = -Picture1.Height
        Picture1.Visible = True
        Dim SourceDC As Long
        Me.AutoRedraw = True
        Me.ScaleMode = 3
        Screen.MousePointer = vbCrosshair      ' 将光标改为十字型
        SourceDC = CreateDC("DISPLAY", 0, 0, 0)
        BitBlt Me.hdc, 0, 0, Screen.Width / 15, Screen.Height / 15, SourceDC, 0, 0, &HCC0020  '拷贝当前屏幕到窗体
        DeleteDC SourceDC
        Me.WindowState = 2
        Status = "draw"        '绘图状态
        SetTitle 1             '设置提示的内容
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
        If KeyAscii = vbKeyEscape Then
            Unload Me
        End If
End Sub

Private Sub Timer1_Timer()
   Picture1.Top = Picture1.Top + 4  '模拟QQ截屏时的左上角的提示图片的效果
   If Picture1.Top > 0 Then
        Timer1.Enabled = False
   End If
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Status = "draw" Then          '如果是抓取状态
            Shape1.Visible = True
            Shape1.Width = 0
            Shape1.Height = 0
            OriginalX = X
            OriginalY = Y                '起点坐标
            Shape1.Left = OriginalX
            Shape1.Top = OriginalY
            Call SetTitle(1)
        Else                             '如果鼠标点在画好的选区内，则移动画好的选区
            rc.Left = Shape1.Left
            rc.Right = Shape1.Left + Shape1.Width
            rc.Top = Shape1.Top
            rc.Bottom = Shape1.Top + Shape1.Height
            If PtInRect(rc, X, Y) Then     '如果按下的点位于区域内
                NewX = X
                NewY = Y                   '则移动区域
            Else                           '否则重新画一个区域
                Shape1.Width = 0
                Shape1.Height = 0
                OriginalX = X
                OriginalY = Y
                Shape1.Left = OriginalX
                Shape1.Top = OriginalY
                Status = "draw"            '状态恢复到抓取
                Call SetTitle(2)
            End If
        End If

End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Button = 1 Then
            Call SetTitle(3)
            If Status = "draw" Then
                Status = "move"
            End If
            OriginalX = Shape1.Left   '更新OriginalX，因为选择区域时可能会出现shape的right点大于left点
            OriginalY = Shape1.Top
        End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    lblInfo(3).Visible = False
    Dim RGBColor As Long, Red As Long, Green As Long, Blue As Long
    RGBColor = GetPixel(Me.hdc, X, Y)
    GetRGBColors RGBColor, Red, Green, Blue
    lblInfo(3).Caption = "(" & Red & "," & Green & "," & Blue & ")"
    Dim Info As String
    If Button = 1 Then
        Shape1.Visible = False
        LblPos.Visible = False
        If Status = "draw" Then            '如果是绘图状态
            If X > OriginalX And Y > OriginalY Then           '根据鼠标位置调整shape1的大小和位置
                Shape1.Move OriginalX, OriginalY, X - OriginalX, Y - OriginalY
            ElseIf X < OriginalX And Y > OriginalY Then
               Shape1.Move X, OriginalY, OriginalX - X, Y - OriginalY
            ElseIf X > OriginalX And Y < OriginalY Then
                Shape1.Move OriginalX, Y, X - OriginalX, OriginalY - Y
            ElseIf X < OriginalX And Y < OriginalY Then
                Shape1.Move X, Y, OriginalX - X, OriginalY - Y
            End If
            Info = Shape1.Width & "x" & Shape1.Height             '显示当前区域的大小
            LblPos.Move Shape1.Left + Shape1.Width / 2 - TextWidth(Info) / 2, Shape1.Top + Shape1.Height / 2 - TextHeight(Info) / 2
            LblPos.Caption = Info
            Screen.MousePointer = vbCrosshair
        Else                               '如果是移动状态
            Screen.MousePointer = 5
            Shape1.Left = OriginalX - (NewX - X)
            Shape1.Top = OriginalY - (NewY - Y)
            If Shape1.Left < 0 Then Shape1.Left = 0   '使区域不超过屏幕
            If Shape1.Top < 0 Then Shape1.Top = 0
            If Shape1.Left + Shape1.Width > Screen.Width / 15 Then Shape1.Left = Screen.Width / 15 - Shape1.Width
            If Shape1.Top + Shape1.Height > Screen.Height / 15 Then Shape1.Top = Screen.Height / 15 - Shape1.Height
            LblPos.Move Shape1.Left + Shape1.Width / 2 - TextWidth(LblPos.Caption) / 2, Shape1.Top + Shape1.Height / 2 - TextHeight(LblPos.Caption) / 2
        End If
        Shape1.Visible = True
        LblPos.Visible = True
    End If
    lblInfo(3).Visible = True
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If ptInPic = 1 Or Picture1.Left = Me.ScaleLeft Then         '改变提示框的位置
        With Picture1
            .Move Me.ScaleWidth - .Width, .Top, .Width, .Height
        End With
        ptInPic = 2
    Else
        ptInPic = 1
        With Picture1
            .Move Me.ScaleLeft, .Top, .Width, .Height
        End With
    End If
End Sub

Private Sub Form_DblClick()
      If PtInRect(rc, NewX, NewY) Then     '看是否在区域内
          Picture1.Visible = False         '如果选区包含部分提示图片，则需要把图片先隐藏。
          Sleep 10                         '有时候没有这两句会使得shape1也显示在截取的区域里
          DoEvents
          Shape1.Visible = False
          ScrnCap Shape1.Left, Shape1.Top, Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Height
          MsgBox "图象已经保存到剪贴板中", vbInformation, "提示"
          Unload Me
      End If
End Sub

'*************************************************************************
'**    作    者 ：    laviewpbt
'**    函 数 名 ：    EDcode
'**    输    入 ：    Left(Long)    -  左起点
'**    输    入 ：    Top(Long)     -  顶点
'**    输    入 ：    Right(Long)   -  右边界
'**    输    入 ：    Bottom(Long)  -  下边界
'**    输    出 ：    无
'**    功能描述 ：    拷贝选定方框区域的屏幕图像到剪贴板
'**    日    期 ：    2005-10-26 17.49.23
'**    修 改 人 ：
'**    日    期 ：
'**    版    本 ：    Version 1.2.1
'*************************************************************************

Public Sub ScrnCap(Left As Long, Top As Long, Right As Long, Bottom As Long)
    Shape1.Visible = False               '不需要拷贝shape
    LblPos.Visible = False
    DoEvents
    Dim rWidth As Long
    Dim rHeight As Long
    Dim SourceDC As Long
    Dim DestDC As Long
    Dim BHandle As Long
    Dim Wnd As Long
    Dim DHandle As Long
    rWidth = Right - Left
    rHeight = Bottom - Top
    SourceDC = CreateDC("DISPLAY", 0, 0, 0)
    DestDC = CreateCompatibleDC(SourceDC)
    BHandle = CreateCompatibleBitmap(SourceDC, rWidth, rHeight)
    SelectObject DestDC, BHandle
    BitBlt DestDC, 0, 0, rWidth, rHeight, SourceDC, Left, Top, &HCC0020
    Wnd = GetDesktopWindow
    OpenClipboard Wnd
    EmptyClipboard
    SetClipboardData 2, BHandle
    CloseClipboard
    DeleteDC DestDC
    ReleaseDC DHandle, SourceDC
End Sub

 效果图：

如果在你的程序中，你想在某种情况下调用截屏功能，稍微改下就可以了，我想对大家没有什么难度的。

当然代码没有QQ的那个八个角度拖动选择区域的功能。

希望大家多提建议和意见!!!