如何用vb实现截屏？

Question

请教如何用vb实现截屏幕中指定位置的图片，并保存到sql数据库里？

Answer 1

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 SubPrivate 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 SubPrivate 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 SubPrivate 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 IfEnd SubPublic 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

Answer 2

至于保存图片到SQL，你只要做一个临时的文件图，然后做为adostream进数据库就行了

Answer 3

虽然是我自己些的，但是还是要说明一下：
ScrnCap 函数明显有内存泄露，CreateDC要用DeleteDC。

Answer 4

laviewpbt 
写的代码还是不错的，我记得他那些还发布了一个
让图片全部变灰色的代码，试过后感觉还不错，只是现在不知道被我丢哪里去了：）