用鼠标抓取图片(VB怎么解决)

[IKEA66]

用鼠标抓取图片(VB怎么解决)

松开鼠标左键时,可以调整所抓取图片的大小,类似360浏览器抓图的功能一样


请问怎么实现此功能!有没有好的思路或源码


求高手指点!

[贝隆]

http://download.csdn.net/source/1604414

[贝隆]

http://download.csdn.net/source/1785500

[aohan]

你可以查找一下“VB模仿QQ截图”，如以下的实现

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)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'------------调用保存对话框--------------------------------
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

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

Private Type POINTAPI
X As Long
Y As Long
End Type

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

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

Private Sub Form_Load()
Picture1.Top = -Picture1.Height
Picture1.Visible = False
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" '绘图状态
End Sub


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


Private Sub Image1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Status = "move" Then
ImgMove = "Start"
GetCursorPos DPoint
LeftL = Shape1.Left: TopL = Shape1.Top
x1 = Shape1.Left + Shape1.Width: y1 = Shape1.Top + Shape1.Height
Picture1.Visible = False
End If
End Sub

Private Sub Image1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Select Case Index
Case 0: Screen.MousePointer = 8
Case 1: Screen.MousePointer = 7
Case 2: Screen.MousePointer = 6
Case 3: Screen.MousePointer = 9
Case 4: Screen.MousePointer = 6
Case 5: Screen.MousePointer = 7
Case 6: Screen.MousePointer = 8
Case 7: Screen.MousePointer = 9
End Select
If ImgMove = "Start" Then
GetCursorPos MPoint '取得当前鼠标位置
Image1(Index).Move MPoint.X, MPoint.Y
Select Case Index
Case 0 '左上移动
Shape1.Move MPoint.X + Image1(Index).Width / 2, MPoint.Y + Image1(Index).Height / 2, x1 - MPoint.X, y1 - MPoint.Y
Case 1 '上移动
Shape1.Move LeftL, MPoint.Y + Image1(Index).Height / 2, x1 - LeftL, y1 - MPoint.Y
Case 2 '右上移动
Shape1.Move LeftL, MPoint.Y + Image1(Index).Height / 2, (MPoint.X - LeftL) + Image1(Index).Width / 2, y1 - MPoint.Y
Case 3 '左移动
Shape1.Move MPoint.X + Image1(Index).Width / 2, TopL, x1 - MPoint.X, y1 - TopL
Case 4 '左下移动
Shape1.Move MPoint.X + Image1(Index).Width / 2, TopL, x1 - MPoint.X, MPoint.Y - TopL
Case 5 '下移动
Shape1.Move LeftL, TopL, x1 - LeftL, MPoint.Y - TopL
Case 6 '右下移动
Shape1.Move LeftL, TopL, MPoint.X - LeftL, MPoint.Y - TopL
Case 7 '右移动
Shape1.Move LeftL, TopL, MPoint.X - LeftL, y1 - TopL
End Select
ImageMove
LblPos.Caption = Shape1.Width & "x" & Shape1.Height
LblPos.Move Shape1.Left + 2, Shape1.Top + 2
OriginalX = Shape1.Left
OriginalY = Shape1.Top
End If
End Sub

Private Sub Image1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
ImgMove = "Stop"
If (Shape1.Top + Shape1.Height + 4 + Picture1.Height) > Screen.Height / 15 Then
Picture1.Move (Shape1.Left + Shape1.Width) - Picture1.Width, (Shape1.Top + Shape1.Height) - Picture1.Height - 4
Else
Picture1.Move (Shape1.Left + Shape1.Width) - Picture1.Width, Shape1.Top + Shape1.Height + 4
End If
If Picture1.Left < 0 Then Picture1.Move 0
Picture1.Visible = True
End Sub

Private Sub Image2_Click(Index As Integer)
Dim i As Integer
Select Case Index
Case 0
Status = "draw"
Shape1.Visible = False
Picture1.Visible = False
LblPos.Visible = False
Shape1.Width = 0
Shape1.Height = 0
For i = 0 To 7
Image1(i).Visible = False
Next
Exit Sub
Case 1
Picture1.Visible = False '如果选区包含部分提示图片，则需要把图片先隐藏。
Sleep 10 '有时候没有这两句会使得shape1也显示在截取的区域里
DoEvents
Shape1.Visible = False
ScrnCap Shape1.Left, Shape1.Top, Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Height
Case 2
Picture1.Visible = False
Sleep 10
DoEvents
Shape1.Visible = False
ScrnCap Shape1.Left, Shape1.Top, Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Height
Call CutdSave
Case 3

End Select
Unload Me
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Picture1.Visible = False
If Status = "draw" Then
Shape1.Visible = True
Shape1.Width = 0
Shape1.Height = 0
OriginalX = X
OriginalY = Y
Shape1.Left = OriginalX
Shape1.Top = OriginalY
Else
Screen.MousePointer = vbCrosshair
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
Shape1.Visible = False
LblPos.Visible = False
Screen.MousePointer = 0
Status = "draw"
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
If Status = "draw" Then
Status = "move"
End If
OriginalX = Shape1.Left
OriginalY = Shape1.Top
If (Shape1.Top + Shape1.Height + 4 + Picture1.Height) > Screen.Height / 15 Then
Picture1.Move (Shape1.Left + Shape1.Width) - Picture1.Width, (Shape1.Top + Shape1.Height) - Picture1.Height - 4
Else
Picture1.Move (Shape1.Left + Shape1.Width) - Picture1.Width, Shape1.Top + Shape1.Height + 4
End If
If Picture1.Left < 0 Then Picture1.Move 0
Picture1.Visible = True
End If
End Sub

[aohan]

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim RGBColor As Long, Red As Long, Green As Long, Blue As Long
    x1 = X: y1 = Y
    RGBColor = GetPixel(Me.hdc, X, Y)
    GetRGBColors RGBColor, Red, Green, Blue
    lblInfo.Caption = "(" & Red & "," & Green & "," & Blue & ")"
    Dim Info As String
    Screen.MousePointer = vbCrosshair
    If Button = 1 Then
        Shape1.Visible = False
        LblPos.Visible = False
        If Status = "draw" Then           
            If X > OriginalX And Y > OriginalY Then          
                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 + 2, Shape1.Top + 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 + 2, Shape1.Top + 2
        End If
        Call ImageMove
        Shape1.Visible = True
        LblPos.Visible = True
    End If
End Sub

Private Sub Form_DblClick()
    If PtInRect(rc, NewX, NewY) Then    
        Picture1.Visible = False        
        Sleep 10                        
        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

Public Sub ScrnCap(Left As Long, Top As Long, Right As Long, Bottom As Long)
    Dim i As Integer
    Shape1.Visible = False              
    LblPos.Visible = False
    For i = 0 To 7
        Image1(i).Visible = False
    Next
    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

Public Sub MDown(X As Single, Y As Single)

End Sub


Public Function CutdSave()
    Dim sFile As String
    Dim SaveOpen As OPENFILENAME
    SaveOpen.lStructSize = Len(SaveOpen)
    SaveOpen.hwndOwner = 0&
    SaveOpen.lpstrFile = String$(255, 0)
    SaveOpen.nMaxFile = 255
    SaveOpen.lpstrInitialDir = App.Path
    SaveOpen.lpstrFilter = "位图文件(*.bmp)" + Chr$(0) + "*.bmp" + Chr$(0) + "JPEG文件(*.jpg)" + Chr$(0) + "*.jpg" + Chr$(0) + "所有文件(*.*)" + Chr$(0) + "*.*" + Chr$(0)
    SaveOpen.lpstrTitle = "保存为"
    SaveOpen.nFilterIndex = 2
    SaveOpen.lpstrDefExt = "bmp"   '初始化扩展名
    If GetSaveFileName(SaveOpen) <> 0 Then
        sFile = Left(SaveOpen.lpstrFile, InStr(SaveOpen.lpstrFile, Chr$(0)) - 1)
    Else
        Exit Function
    End If
    SavePicture Clipboard.GetData(), sFile
    Clipboard.Clear   ' 清除剪贴板
End Function

Private Sub Image2_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
For i = 0 To 3
Shape3(i).Visible = False
Next
Shape3(Index).Visible = True
End Sub

Private Sub Label1_Click(Index As Integer)

End Sub

Private Sub Label1_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)

End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Screen.MousePointer = 1
For i = 0 To 3
Shape3(i).Visible = False
Next
End Sub

Public Function ImageMove()
    Dim i As Integer
    Image1(0).Move Shape1.Left - (Image1(0).Width / 2), Shape1.Top - (Image1(0).Height / 2)
    Image1(1).Move (Shape1.Left + (Shape1.Width / 2)) - (Image1(0).Width / 2), Shape1.Top - (Image1(0).Height / 2)
    Image1(2).Move (Shape1.Left + (Shape1.Width)) - (Image1(2).Width / 1.5), Shape1.Top - (Image1(2).Height / 2)
    Image1(3).Move Shape1.Left - (Image1(3).Width / 2), Shape1.Top + (Shape1.Height / 2) - (Image1(3).Height / 2)
    Image1(4).Move Shape1.Left - (Image1(4).Width / 2), Shape1.Top + (Shape1.Height) - (Image1(4).Height / 2)
    Image1(5).Move (Shape1.Left + (Shape1.Width / 2)) - (Image1(5).Width / 2), Shape1.Top + (Shape1.Height) - (Image1(5).Height / 2)
    Image1(6).Move (Shape1.Left + (Shape1.Width)) - (Image1(6).Width / 2), Shape1.Top + (Shape1.Height) - (Image1(6).Height / 2)
    Image1(7).Move (Shape1.Left + (Shape1.Width)) - (Image1(7).Width / 2), Shape1.Top + (Shape1.Height / 2) - (Image1(7).Height / 2)
    For i = 0 To 7
        Image1(i).Visible = True
    Next
End Function

[IKEA66]

分有点少,谢谢各位了