|
|
Imports System.Drawing
Imports System.Windows.Forms
Friend Class FmScreenShot
Inherits Form
#Region "form designer"
'Form 重写 Dispose，以清理组件列表。
<System.Diagnostics.DebuggerNonUserCode()>
Protected Overrides Sub Dispose(ByVal disposing As Boolean)
Try
If disposing AndAlso components IsNot Nothing Then
components.Dispose()
End If
Finally
MyBase.Dispose(disposing)
End Try
End Sub
'Windows 窗体设计器所必需的
Private components As System.ComponentModel.IContainer
'注意: 以下过程是 Windows 窗体设计器所必需的
'可以使用 Windows 窗体设计器修改它。
'不要使用代码编辑器修改它。
<System.Diagnostics.DebuggerStepThrough()>
Private Sub InitializeComponent()
Me.lblCuttingArea = New System.Windows.Forms.Label()
Me.SuspendLayout()
'
'lblCuttingArea
'
Me.lblCuttingArea.BackColor = System.Drawing.SystemColors.ActiveCaptionText
Me.lblCuttingArea.Location = New System.Drawing.Point(278, 106)
Me.lblCuttingArea.Name = "lblCuttingArea"
Me.lblCuttingArea.Size = New System.Drawing.Size(139, 82)
Me.lblCuttingArea.TabIndex = 0
Me.lblCuttingArea.Text = "Label1"
Me.lblCuttingArea.Visible = False
'
'FmScreenShot
'
Me.AutoScaleDimensions = New System.Drawing.SizeF(6.0!, 12.0!)
Me.AutoScaleMode = System.Windows.Forms.AutoScaleMode.Font
Me.ClientSize = New System.Drawing.Size(630, 324)
Me.Controls.Add(Me.lblCuttingArea)
Me.FormBorderStyle = System.Windows.Forms.FormBorderStyle.None
Me.KeyPreview = True
Me.Name = "FmScreenShot"
Me.ShowIcon = False
Me.ShowInTaskbar = False
Me.Text = "FmScreenShot"
Me.TopMost = True
Me.WindowState = System.Windows.Forms.FormWindowState.Maximized
Me.ResumeLayout(False)
End Sub
Friend WithEvents lblCuttingArea As Label
#End Region
Public Sub New()
' 此调用是设计器所必需的。
InitializeComponent()
' 在 InitializeComponent() 调用之后添加任何初始化。
SetStyle(ControlStyles.UserPaint Or ControlStyles.ResizeRedraw Or ControlStyles.AllPaintingInWmPaint Or ControlStyles.OptimizedDoubleBuffer, True)
End Sub
Private screenImage As Image
Protected Overrides Sub OnShown(e As EventArgs)
MyBase.OnShown(e)
Dim bgImg = New Bitmap(Screen.PrimaryScreen.Bounds.Width, Screen.PrimaryScreen.Bounds.Height)
Dim g = Graphics.FromImage(bgImg)
g.CopyFromScreen(New Point(0, 0), New Point(0, 0), Screen.PrimaryScreen.Bounds.Size, CopyPixelOperation.SourceCopy)
screenImage = bgImg.Clone
g.FillRectangle(New SolidBrush(Color.FromArgb(64, Color.Gray)), Screen.PrimaryScreen.Bounds)
g.Dispose()
Me.BackgroundImage = bgImg
Me.ShowInTaskbar = False
Me.FormBorderStyle = FormBorderStyle.None
Me.Width = Screen.PrimaryScreen.Bounds.Width
Me.Height = Screen.PrimaryScreen.Bounds.Height
Me.Location = Screen.PrimaryScreen.Bounds.Location
Me.WindowState = FormWindowState.Maximized
lblCuttingArea.Visible = False
Me.TopMost = True
End Sub
Public Event Submit As SubmitCallback
Protected Function OnSubmit() As Boolean
'get the image according to point start and end
Dim rect = GetRectangle(ptStart, ptEnd)
If rect.Height = 0 OrElse rect.Width = 0 Then Return False
Dim bmp = New Bitmap(rect.Width, rect.Height)
Dim g = Graphics.FromImage(bmp)
g.DrawImage(screenImage, 0, 0, rect, GraphicsUnit.Pixel)
g.Dispose()
RaiseEvent Submit(bmp)
Return True
End Function
Protected Sub Output()
If OnSubmit() Then
Me.DialogResult = DialogResult.OK
Me.Close()
End If
End Sub
Protected Sub Abort()
Me.DialogResult = DialogResult.Cancel
Me.Close()
End Sub
Private ptStart As Point
Private ptEnd As Point
Property IsCutting As Boolean
Get
Return lblCuttingArea.Visible
End Get
Set(value As Boolean)
lblCuttingArea.Visible = value
End Set
End Property
Private Sub FmScreenShot_MouseDown(sender As Object, e As MouseEventArgs) Handles Me.MouseDown
If e.Clicks > 1 Then Return
lblCuttingArea.Size = New Size(1, 1)
IsCutting = True
ptStart = e.Location
End Sub
Private Sub FmScreenShot_MouseUp(sender As Object, e As MouseEventArgs) Handles Me.MouseUp
If IsCutting Then
IsCutting = False
ptEnd = e.Location
Me.Output()
End If
End Sub
Private Sub FmScreenShot_MouseMove(sender As Object, e As MouseEventArgs) Handles Me.MouseMove
If IsCutting = False Then Return
Dim rect = GetRectangle(ptStart, e.Location)
lblCuttingArea.SetBounds(rect.X, rect.Y, rect.Width, rect.Height)
End Sub
Private Sub FmScreenShot_PreviewKeyDown(sender As Object, e As PreviewKeyDownEventArgs) Handles Me.PreviewKeyDown
If e.KeyCode = Keys.Escape Then Me.Abort()
End Sub
Private Sub FmScreenShot_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
'MsgBox(e.CloseReason.ToString)
If e.CloseReason = CloseReason.None Then e.Cancel = True 'Else MsgBox(e.CloseReason.ToString)
End Sub
Private Function GetRectangle(pt1 As Point, pt2 As Point) As Rectangle
Dim x1 = pt1.X
Dim x2 = pt2.X
Dim y1 = pt1.Y
Dim y2 = pt2.Y
Return New Rectangle(Math.Min(x1, x2), Math.Min(y1, y2), Math.Abs(x2 - x1), Math.Abs(y2 - y1))
End Function
Private Sub Label1_Paint(sender As Object, e As PaintEventArgs) Handles lblCuttingArea.Paint
Dim imgWidth = lblCuttingArea.Width
Dim imgHeight = lblCuttingArea.Height
If imgWidth < 1 Then imgWidth = 1
If imgHeight < 1 Then imgHeight = 1
Dim bmp = New Bitmap(imgWidth, imgHeight)
Dim g = Graphics.FromImage(bmp)
Dim destRect = New Rectangle(0, 0, imgWidth, imgHeight)
Dim srcPoint = lblCuttingArea.Location
Dim srcRect = New Rectangle(srcPoint, New Size(imgWidth, imgHeight))
g.DrawImage(Me.screenImage, destRect, srcRect, GraphicsUnit.Pixel)
'draw it to label
e.Graphics.DrawImage(bmp, 0, 0)
bmp.Dispose()
g.Dispose()
End Sub
End Class
Public Class ScreenShot
''' <summary>
''' Captures the screen image by mouse positions.
''' </summary>
''' <returns></returns>
Public Shared Function Capture() As Image
Dim retImage As Image = Nothing
Dim callback As New SubmitCallback(Sub(o)
retImage = CType(o, Image)
End Sub)
Dim fm As New FmScreenShot
AddHandler fm.Submit, callback
Dim ret = DialogResult.Cancel
ret = fm.ShowDialog
RemoveHandler fm.Submit, callback
If ret = DialogResult.Cancel Then Return Nothing
Return retImage
End Function
''' <summary>
''' Captures the image of primary screen.
''' </summary>
''' <returns></returns>
Public Shared Function CaptureFullScreen() As Image
Dim bmp As New Bitmap(Screen.PrimaryScreen.Bounds.Width, Screen.PrimaryScreen.Bounds.Height)
Using g = Graphics.FromImage(bmp)
g.CopyFromScreen(0, 0, 0, 0, bmp.Size)
End Using
Return bmp
End Function
''' <summary>
''' Gets a rectangle according two points.
''' </summary>
''' <param name="pt1">The first point.</param>
''' <param name="pt2">The second point.</param>
''' <returns></returns>
Public Shared Function GetRectangle(pt1 As Point, pt2 As Point) As Rectangle
Dim x1 = pt1.X
Dim x2 = pt2.X
Dim y1 = pt1.Y
Dim y2 = pt2.Y
Return New Rectangle(Math.Min(x1, x2), Math.Min(y1, y2), Math.Abs(x2 - x1), Math.Abs(y2 - y1))
End Function
''' <summary>
''' Captures a rectangle image from screen.
''' </summary>
''' <param name="point1">The first point of rectangle.</param>
''' <param name="point2">The second point of rectangle.</param>
''' <returns></returns>
Public Shared Function Capture(point1 As Point, point2 As Point) As Image
Dim rect = GetRectangle(point1, point2)
Dim bmp As New Bitmap(rect.Width, rect.Height)
Using g = Graphics.FromImage(bmp)
'g.CopyFromScreen(0, 0, 0, 0, bmp.Size)
g.CopyFromScreen(rect.Location, New Point(0, 0), rect.Size)
End Using
Return bmp
End Function
End Class
Friend Delegate Sub SubmitCallback(state As Object)
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-9-27 12:42
楼主
