ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 1095|回复: 2

屏幕截屏-vb.net

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-9-27 12:42 来自手机 | 显示全部楼层 |阅读模式
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)

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-9-27 12:44 来自手机 | 显示全部楼层
简单的截屏功能。可截取鼠标随选区域、全屏、以及指定区域。调用ScreenShot类的Capture方法即可。

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-11-21 15:40 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 03:38 , Processed in 0.027914 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表