getpicture.frm

功能强大的个人工作通讯录

Private Sub Form_KeyPress(KeyAscii As Integer)
        If KeyAscii = vbKeyEscape Then
            Unload Me
            MDI.Show
        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     '看是否在区域内
               '如果选区包含部分提示图片，则需要把图片先隐藏。
          Sleep 10                         '有时候没有这两句会使得shape1也显示在截取的区域里
          DoEvents
          Shape1.Visible = False
          ScrnCap Shape1.Left, Shape1.Top, Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Height
         Picture1 = Clipboard.GetData
         
         If MsgBox("图象已经保存到剪贴板中,预览图见左上角，是否保存？", vbInformation + vbYesNo, "提示") = vbYes Then
          
                 Dim ff As Form
                 
                 For Each ff In Forms
                          
                      If Right(ff.Caption, Len(ff.Caption) - InStr(1, ff.Caption, ":")) = formNo Then
                           ff.Show
                           ff.SetFocus
                           ff.Picture1.Picture = LoadPicture("")
                           ff.Picture1.AutoRedraw = True
                           ff.Picture1 = Clipboard.GetData
                           ff.Picture1.Left = ff.Picture2.Width / 2 - ff.Picture1.Width / 2
                           ff.Picture1.Top = ff.Picture2.Height / 2 - ff.Picture1.Height / 2
                           Call ff.SavePictrueNow
                       End If
                  Next
                  
                Screen.MousePointer = none
                Unload Me
         End If
     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