getpicture.frm

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

VERSION 5.00
Begin VB.Form GetPicture 
   BorderStyle     =   0  'None
   Caption         =   "截图"
   ClientHeight    =   6825
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   14340
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   6825
   ScaleWidth      =   14340
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  '窗口缺省
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000013&
      ForeColor       =   &H80000008&
      Height          =   3176
      Left            =   270
      ScaleHeight     =   3150
      ScaleWidth      =   2235
      TabIndex        =   5
      Top             =   195
      Width           =   2269
   End
   Begin VB.Timer Timer1 
      Interval        =   20
      Left            =   13650
      Top             =   6210
   End
   Begin VB.Shape Shape1 
      BorderStyle     =   3  'Dot
      Height          =   675
      Left            =   10440
      Top             =   1245
      Visible         =   0   'False
      Width           =   1815
   End
   Begin VB.Label lblInfo 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Label1"
      Height          =   180
      Index           =   0
      Left            =   270
      TabIndex        =   4
      Top             =   6420
      Width           =   540
   End
   Begin VB.Label lblInfo 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Label2"
      Height          =   180
      Index           =   1
      Left            =   240
      TabIndex        =   3
      Top             =   4920
      Width           =   540
   End
   Begin VB.Label lblInfo 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Label3"
      Height          =   180
      Index           =   2
      Left            =   270
      TabIndex        =   2
      Top             =   4200
      Width           =   540
   End
   Begin VB.Label lblInfo 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Label4"
      Height          =   180
      Index           =   3
      Left            =   255
      TabIndex        =   1
      Top             =   5670
      Width           =   540
   End
   Begin VB.Label LblPos 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Height          =   180
      Left            =   11880
      TabIndex        =   0
      Top             =   2100
      Width           =   90
   End
End
Attribute VB_Name = "GetPicture"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
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)    -  提示编码
'**    输    出 ：    无
'**    功能描述 ：    改变提示信息
'**    日    期 ：
'**    修 改 人 ：
'**    日    期 ：
'**    版    本 ：
'*************************************************************************

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_queryunload(Cancel As Integer, unloadmode As Integer) '退出子窗体时卸载所有窗体
Screen.MousePointer = none
End Sub