Готовые решения и полезные коды на Visual Basic .NET (Часть-1)

Me.Close()

Me.WindowState = FormWindowState.Minimized

      If Me.WindowState = FormWindowState.Normal Then
        Me.WindowState = FormWindowState.Maximized
      Else
        Me.WindowState = FormWindowState.Normal
      End If

    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Me.AcceptButton = Button1 'кнопка срабатывает при нажатии ENTER (OK)
        Me.CancelButton = Button2 'кнопка срабатывает при нажатии ESC (ОТМЕНА)
    End Sub

 Private Const DROPSHADOW As Integer = &H20000
    Protected Overrides ReadOnly Property CreateParams() As CreateParams
        Get
            Dim myparam As CreateParams = MyBase.CreateParams
            myparam.ClassStyle = myparam.ClassStyle Or DROPSHADOW
            Return myparam 
        End Get
    End Property

    Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean
    Const AW_HOR_POSITIVE = &H1 'Анимация окна слева направо.
    'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
    Const AW_HOR_NEGATIVE = &H2 'Анимация окна справа налево.
    'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
    Const AW_VER_POSITIVE = &H4 'Анимация окна сверху вниз.
    'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
    Const AW_VER_NEGATIVE = &H8 'Анимация окна снизу вверх.
    'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
    Const AW_CENTER = &H10 'Окно сворачивается внутрь себя если
    'установлен флаг AW_HIDE, иначе разворачивается
    Const AW_HIDE = &H10000 'Скрывает окно, по умолчанию окно появляется.
    Const AW_ACTIVATE = &H20000 'Активизирует окно.
    Const AW_SLIDE = &H40000 'Устанавливает эффект соскальзывания.
    'По умолчанию эффект развёртывания.
    Const AW_BLEND = &H80000 'Эффект постепенного появления.
    'Применяется только к окнам верхнего уровня.

'Плавный запуск формы
Imports System
Public Class Form1
 
    <Flags> _
    Enum AnimateWindowFlags
        AW_HOR_POSITIVE = &H1
        AW_HOR_NEGATIVE = &H2
        AW_VER_POSITIVE = &H4
        AW_VER_NEGATIVE = &H8
        AW_CENTER = &H10
        AW_HIDE = &H10000
        AW_ACTIVATE = &H20000
        AW_SLIDE = &H40000
        AW_BLEND = &H80000
    End Enum
    <System.Runtime.InteropServices.DllImport("user32.dll")> _
    Shared Function AnimateWindow(hWnd As IntPtr, time As Integer, flags As AnimateWindowFlags) As Boolean
    End Function
 
    Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
        AnimateWindow(Me.Handle, 1000, AnimateWindowFlags.AW_BLEND Or AnimateWindowFlags.AW_HIDE)
    End Sub
 
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        AnimateWindow(Me.Handle, 1000, AnimateWindowFlags.AW_BLEND Or AnimateWindowFlags.AW_VER_POSITIVE)
    End Sub

    Sub RunAsAdmin(FullPath As String, Optional Args As String = "", Optional WindowStyle As ProcessWindowStyle = ProcessWindowStyle.Normal, Optional UseShellExecute As Boolean = False)
        Dim pStartInfo As New ProcessStartInfo With {.FileName = FullPath, .Arguments = Args, .WindowStyle = WindowStyle, .UseShellExecute = UseShellExecute}
        If Environment.OSVersion.Version.Major >= 6 Then pStartInfo.Verb = "runas" 'Здесь проверяем, если ОС версия выше чем Vista, то применяем права администратора при запуске, до этой версии таких прав не нужно
        Process.Start(pStartInfo)
    End Sub

    Function IsAdministrator() As Boolean
        Return New Security.Principal.WindowsPrincipal(Security.Principal.WindowsIdentity.GetCurrent()).IsInRole(Security.Principal.WindowsBuiltInRole.Administrator)
    End Function

    Public Function IsInGroup(ByVal GroupName As String) As Boolean
        Dim MyIdentity As System.Security.Principal.WindowsIdentity = System.Security.Principal.WindowsIdentity.GetCurrent()
        Dim MyPrincipal As System.Security.Principal.WindowsPrincipal = New System.Security.Principal.WindowsPrincipal(MyIdentity)
        Return MyPrincipal.IsInRole(GroupName)
    End Function
 
'Получить список групп можно таким образом:
    For Each groupName As String In System.Security.Principal.WindowsIdentity.GetCurrent.Groups.Select(Function(grp) grp.Translate(GetType(System.Security.Principal.NTAccount)).Value)
        ListBox1.Items.Add(groupName)
    Next

    Protected Overrides Sub WndProc(ByRef m As System.Windows.Forms.Message)
        If m.Msg = &HA1 Then
            Select Case m.WParam
                Case 2
                    MsgBox("Form Title MouseDown")
                Case 3
                    MsgBox("Form Icon MouseDown. Called System Menu")
                Case 8
                    MsgBox("Minimize Button MouseDown")
                Case 9
                    MsgBox("Maximize Button MouseDown")
                Case 20
                    MsgBox("Form Close Button MouseDown")
            End Select
        End If
        MyBase.WndProc(m)
    End Sub

    Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
    Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As wFlag) As Integer
    
    Enum wFlag
        MinButton = 3
        MaxButton = 4
        CloseButton = 6
    End Enum
 
    Public Sub KillingMenu(hWnd As Long, wFlag As wFlag)
        RemoveMenu(GetSystemMenu(hWnd, 0), wFlag, &H400&)
    End Sub

KillingMenu(Me.Handle, wFlag.MaxButton)

'// This code helps programmer to retrive a data from *DTL files.
'// The author of this code is Yury, Komar.
'// Public Function ReadDTL retirns a DataTable.
Module DtlReader
    Enum ValueType
        Int16_BCD_Unsigned = 0
        Int16_BCD_Signed = 1
        Int16_Unsigned = 2
        Int16_Signed = 3
        Int32_Unsigned = 4
        Int32_Signed = 5
        Float32 = 6
        String_ = 7
    End Enum
    Structure DTLColumn
        Public Type As ValueType, Size As Integer, Name As String
    End Structure
    Structure DTLHeader
        Public Sign As Integer, Undef1 As Integer, Date2 As Integer, FieldsCount As Integer, Count2 As Integer
        Public Columns() As DTLColumn
    End Structure
    Structure DTLRow
        Public Date_ As DateTime, Cells() As Object
    End Structure
 
    Public Function ReadDTL(FileName As String) As DataTable
        Dim newDT As New DataTable
        Using BinReader = New IO.BinaryReader(New IO.FileStream(FileName, IO.FileMode.Open, IO.FileAccess.Read), System.Text.Encoding.Default)
            Dim Header As DTLHeader
            Dim Rows As New DTLRow()
 
            'Read Header------------------------------------------------------------------------------------------------
            Header.Sign = BinReader.ReadInt32 'Not using in this code
            Header.Undef1 = BinReader.ReadInt32 'Not using in this code
            Header.Date2 = BinReader.ReadInt32 'Not using in this code
            Header.FieldsCount = BinReader.ReadInt32 'Read Columns number (+4 bytes)
            Header.Count2 = BinReader.ReadInt32 * 2 'Not using in this code
            Header.Columns = New DTLColumn(Header.FieldsCount - 1) {} 'Create empty array of Columns
            For i = 0 To Header.Columns.Count - 1 'Read each column's Type and Size
                Header.Columns(i).Type = BinReader.ReadInt32
                Header.Columns(i).Size = BinReader.ReadInt32
            Next
            BinReader.BaseStream.Position += 4 'skip 4 bytes
            For i = 0 To Header.Columns.Count - 1
                Header.Columns(i).Name = System.Text.Encoding.UTF8.GetString(BinReader.ReadBytes(BinReader.ReadInt16))
                'MsgBox(Header.Columns(i).Name & vbCrLf & Header.Columns(i).Type) 'Check ColumnHeader Name and Type
            Next
 
            'Create DataTable Columns-------------------------------------------------------------------------------------
            newDT.Columns.Add("DateTime", GetType(System.DateTime))
            For Each f In Header.Columns
                If f.Type.ToString.Length > 0 Then newDT.Columns.Add(f.Name & StrDup(newDT.Columns.Count, vbNullChar))
            Next
 
            'ReadRowData ------------------------------------------------------------------------------------------------
            Do Until BinReader.BaseStream.Position = BinReader.BaseStream.Length
                Rows.Date_ = New DateTime(1970, 1, 1).AddSeconds(BinReader.ReadInt32).AddMilliseconds(BinReader.ReadByte)
                Rows.Cells = New Object(Header.Columns.Count - 1) {}
                For i = 0 To Header.Columns.Count - 1
                    Select Case Header.Columns(i).Type
                        Case ValueType.Int16_BCD_Unsigned
                            Rows.Cells(i) = BinReader.ReadInt16
                        Case ValueType.Int16_BCD_Signed
                            Rows.Cells(i) = BinReader.ReadInt16
                        Case ValueType.Int16_Signed
                            Rows.Cells(i) = BinReader.ReadInt16
                        Case ValueType.Int16_Unsigned
                            Rows.Cells(i) = BinReader.ReadInt16
                        Case ValueType.Int32_Signed
                            Rows.Cells(i) = BinReader.ReadInt32
                        Case ValueType.Int32_Unsigned
                            Rows.Cells(i) = BinReader.ReadInt32
                        Case ValueType.Float32
                            Rows.Cells(i) = BinReader.ReadSingle
                        Case ValueType.String_
                            Rows.Cells(i) = System.Text.Encoding.UTF8.GetString(BinReader.ReadBytes(Header.Columns(i).Size * 2))    'Read String with length * 2
                    End Select
                Next
 
                'Construct a new row and add it to the table-----------------------------------------------------------
                Dim Params As New List(Of Object)
                Params.Add(Rows.Date_)
                Params.AddRange((From r In Rows.Cells Where Not r Is Nothing).ToList)
                newDT.Rows.Add(Params.ToArray)
            Loop
        End Using
        Return newDT
        newDT.Dispose()
        GC.Collect()
    End Function
End Module

'// This code helps programmer to retrive a data from *EVT files.
'// The author of this code is Yury, Komar.
'// Public Function ReadEVT retirns a DataTable.
Module EVTreader
    Structure EVTHeader
        Public Sign, Undef1, Date2, Count As Integer
    End Structure
    Structure EVTRow
        Public Date_ As DateTime, Evnt As Byte, Catgry As Byte, Msg As String
    End Structure
 
    Public Function ReadEVT(FileName As String) As DataTable
        Dim newDT As New DataTable
        Using BinReader = New IO.BinaryReader(New IO.FileStream(FileName, IO.FileMode.Open, IO.FileAccess.Read), System.Text.Encoding.Default)
            Dim Header As EVTHeader
            Dim Rows As New EVTRow()
 
            'Read Header------------------------------------------------------------------------------------------------
            Header.Sign = BinReader.ReadInt32 'Not using in this code
            Header.Undef1 = BinReader.ReadInt32 'Not using in this code
            Header.Date2 = BinReader.ReadInt32 'Not using in this code
            Header.Count = BinReader.ReadInt32 '* 2 'Not using in this code
 
            'Create DataTable Columns-------------------------------------------------------------------------------------
            newDT.Columns.Add("DateTime", GetType(System.DateTime))
            newDT.Columns.Add("Event") ', GetType(System.DateTime))
            newDT.Columns.Add("Category") ', GetType(System.DateTime))
            newDT.Columns.Add("Message", GetType(System.String))
 
            'ReadRowData ------------------------------------------------------------------------------------------------
            Do Until BinReader.BaseStream.Position = BinReader.BaseStream.Length
                Rows.Date_ = New DateTime(1970, 1, 1).AddSeconds(BinReader.ReadInt32)
                Rows.Evnt = BinReader.ReadByte
                Rows.Catgry = BinReader.ReadByte
                Rows.Msg = System.Text.Encoding.UTF8.GetString(BinReader.ReadBytes(BinReader.ReadByte))
 
                'Construct a new row and add it to the table-----------------------------------------------------------
                Dim Params As New List(Of Object)
                Params.Add(Rows.Date_)
                Params.Add(Rows.Evnt)
                Params.Add(Rows.Catgry)
                Params.Add(Rows.Msg)
                newDT.Rows.Add(Params.ToArray)
            Loop
        End Using
        Return newDT
        newDT.Dispose()
        GC.Collect()
    End Function
End Module

Imports DocumentFormat.OpenXml.Packaging
Imports DocumentFormat.OpenXml.Wordprocessing
 
Public Class DocumentFilling
    ''' <summary>
    ''' Заполнение документа на основе шаблона с закладками
    ''' </summary>
    ''' <param name="filename">Имя конечного документа.</param>
    ''' <param name="templatePath">Путь к шаблону.</param>
    ''' <param name="data">Словарь изменяемых закладок. Key — имя закладки, Value — новое значение.</param>
    Public Shared Sub Fill(filename As String, templatePath As String, data As IDictionary(Of String, String))
        Using doc = WordprocessingDocument.CreateFromTemplate(templatePath)
            ChangeBookmarks(doc, data)
            doc.SaveAs(filename)
        End Using
    End Sub
 
    Private Shared Sub ChangeBookmarks(doc As WordprocessingDocument, data As IDictionary(Of String, String))
        'Извлечение всех закладок в словарь с ключём по имени закладки
        Dim bm = doc.MainDocumentPart.RootElement.Descendants(Of BookmarkStart) _
            .ToDictionary(Function(bms)
                              Return bms.Name.ToString()
                          End Function)
 
        For Each item In data
            'Находим у закладки текстовую часть
            Dim r = bm(item.Key).NextSibling(Of Run)()
            If r IsNot Nothing Then
                'Удаляем текст закладки
                r.RemoveAllChildren(Of Text)()
                'Добавляем новый текст
                r.AppendChild(New Text(item.Value))
            End If
        Next
    End Sub
 
End Class

Imports System
Imports System.Drawing
Imports System.Windows.Forms
Public Class ImageProjectionAsync
    Implements IDisposable
 
#Region "Declare methods"
    Private Declare Auto Function InvalidateRect Lib "User32.dll" (hWnd As IntPtr, lpRect As IntPtr, bErase As Boolean) As Boolean
    Private Declare Auto Function IsWindow Lib "User32.dll" (hWnd As IntPtr) As Boolean
#End Region
 
    Private _hWnd As IntPtr = IntPtr.Zero
    Private _rect As Rectangle
    Private _isWorking As Boolean = False
    Private _bkColor As Color
    Private _bg As BufferedGraphics
    Private _disposedValue As Boolean
    Private _syncObj As New Object()
    Private _imageHelper As ImageAnimatorHelper
    Private _timer As System.Timers.Timer
    Private _reverse As Boolean = False
    Private _infinity As Boolean = False
 
#Region "Methods"
    ''' <summary>
    ''' Инициализация
    ''' </summary>
    ''' <param name="TargetControl">Окно или компонент окна, на которое будет проецироваться изображение</param>
    ''' <param name="ClipRectangle">Область рисования</param>
    ''' <param name="BackColor">Цвет подложки</param>
    ''' <param name="Image">Объект изображения (с анимацией)</param>
    Public Sub New(TargetControl As Control, ClipRectangle As Rectangle, BackColor As Color, Image As Image)
        Me.New(TargetControl.Handle, ClipRectangle, BackColor, Image)
    End Sub
 
    ''' <summary>
    ''' Инициализация
    ''' </summary>
    ''' <param name="hWnd">Ссылка на окно или компонент окна, на которое будет проецироваться изображение</param>
    ''' <param name="ClipRectangle">Область рисования</param>
    ''' <param name="BackColor">Цвет подложки</param>
    ''' <param name="Image">Объект изображения (с анимацией)</param>
    Public Sub New(hWnd As IntPtr, ClipRectangle As Rectangle, BackColor As Color, Image As Image)
        If Not IsWindow(hWnd) Then
            Throw New Exception("hWnd не ссылается на окно или компонент окна")
        End If
 
        If Image Is Nothing Then
            Throw New NullReferenceException("Image")
        End If
 
        If ClipRectangle.Width <= 0 Or ClipRectangle.Height <= 0 Then
            Throw New Exception("Область рисования не должна иметь нулевые размеры")
        End If
 
        _hWnd = hWnd
        _rect = ClipRectangle
        _imageHelper = New ImageAnimatorHelper(Image)
        _bkColor = BackColor
 
        _timer = New System.Timers.Timer()
        AddHandler _timer.Elapsed, AddressOf OnFrameUpdate
 
        Me.CreateBufferedGraphics()
    End Sub
 
    Private Sub CreateBufferedGraphics()
        If _hWnd = IntPtr.Zero Then
            Return
        End If
 
        Dim bc As BufferedGraphicsContext = BufferedGraphicsManager.Current
        bc.MaximumBuffer = New Size(_rect.Width, _rect.Height)
        _bg = bc.Allocate(Graphics.FromHwnd(_hWnd), _rect)
    End Sub
 
    ''' <summary>
    ''' Запуск проекции
    ''' </summary>
    Public Sub StartProjection()
        If _disposedValue Then
            Throw New Exception("Disposed")
        End If
 
        If _hWnd = IntPtr.Zero Then
            Return
        End If
 
        SyncLock _syncObj
            If Not _isWorking Then
 
                _timer.Interval = 1.0R
                _timer.Start()
 
                _isWorking = True
            End If
        End SyncLock
    End Sub
 
    Private Sub OnFrameUpdate(sender As Object, e As System.Timers.ElapsedEventArgs)
        SyncLock _syncObj
 
            _imageHelper.UpdateFrame()
 
            Dim g As Graphics = _bg.Graphics
            g.Clear(_bkColor)
            g.DrawImage(_imageHelper.Image, _rect)
 
            If Not _infinity Then
                Dim delay As Double = CDbl(_imageHelper.FrameDelay(_imageHelper.Frame))
 
                If _timer.Interval <> delay Then
                    _timer.Interval = delay
                End If
            End If
 
            If _reverse Then
                _imageHelper.PreviousFrame()
            Else
                _imageHelper.NextFrame()
            End If
 
            Try
                _bg.Render()
            Catch
                Me.StopProjection()
                _hWnd = IntPtr.Zero
            End Try
        End SyncLock
    End Sub
 
    ''' <summary>
    ''' Остановка проекции
    ''' </summary>
    Public Sub StopProjection()
        SyncLock _syncObj
            If _isWorking Then
 
                _timer.Stop()
 
                InvalidateRect(_hWnd, IntPtr.Zero, True)
                _isWorking = False
            End If
        End SyncLock
    End Sub
 
    ''' <summary>
    ''' Вызов единовременного рисования на указанной поверхности вне зависимости от работы анимации. 
    ''' Так же можно вызывать между смены кадров при необходимости, если частота кадров очень низкая и указанная поверхность имеет свойства сбрасывать (перерисовывать) контентен (например, при изменении размеров элемента управления)
    ''' </summary>
    Public Sub Redraw()
        If _disposedValue Then
            Throw New Exception("Disposed")
        End If
 
        If _hWnd = IntPtr.Zero Then
            Return
        End If
 
        SyncLock _syncObj
            Dim g As Graphics = _bg.Graphics
            g.Clear(_bkColor)
            g.DrawImage(_imageHelper.Image, _rect)
            Try
                _bg.Render()
            Catch
                Me.StopProjection()
                _hWnd = IntPtr.Zero
            End Try
        End SyncLock
    End Sub
 
    ''' <summary>
    ''' Присвоение новых параметров компоненту (при работе) 
    ''' </summary>
    ''' <param name="ClipRectangle"></param>
    ''' <param name="BackColor"></param>
    ''' <param name="Image"></param>
    Public Sub SetParams(ClipRectangle As Rectangle, BackColor As Color, Image As Image)
        Me.SetParams(ClipRectangle, BackColor, Image, 0)
    End Sub
 
    ''' <summary>
    ''' Присвоение новых параметров компоненту (при работе)
    ''' </summary>
    ''' <param name="ClipRectangle">Область рисования</param>
    ''' <param name="BackColor">Цвет подложки</param>
    ''' <param name="Image">Объект изображения (с анимацией)</param>
    ''' <param name="Frame">Текущий кадр</param>
    Public Sub SetParams(ClipRectangle As Rectangle, BackColor As Color, Image As Image, Frame As Integer)
        If _disposedValue Then
            Throw New Exception("Disposed")
        End If
 
        If Image Is Nothing Then
            Throw New NullReferenceException("Image")
        End If
 
        If ClipRectangle.Width <= 0 Or ClipRectangle.Height <= 0 Then
            Throw New Exception("Область рисования не должна иметь нулевые размеры")
        End If
 
        If _hWnd = IntPtr.Zero Then
            Return
        End If
 
        SyncLock _syncObj
            If _isWorking Then
                _timer.Stop()
                InvalidateRect(_hWnd, IntPtr.Zero, True)
            End If
 
            _rect = ClipRectangle
            Me.CreateBufferedGraphics()
            _bkColor = BackColor
            _imageHelper = New ImageAnimatorHelper(Image)
            If Frame < 0 Or Frame >= _imageHelper.FrameCount Then
                Throw New Exception("Индекс Frame выходит за пределы диапазона")
            End If
            _imageHelper.Frame = Frame
 
            If _isWorking Then
                _timer.Interval = 1.0R
                _timer.Start()
            End If
        End SyncLock
    End Sub
 
    ''' <summary>
    ''' Возвращает true, если объект изображения поддерживает анимацию
    ''' </summary>
    ''' <param name="Image">Объект изображения</param>
    ''' <returns>Bool</returns>
    Public Shared Function CanAnimate(Image As Image) As Boolean
        Dim dimensions() As System.Guid = Image.FrameDimensionsList
 
        For Each guid As System.Guid In dimensions
            Dim dimension As New System.Drawing.Imaging.FrameDimension(guid)
            If dimension.Equals(System.Drawing.Imaging.FrameDimension.Time) Then
                Return Image.GetFrameCount(System.Drawing.Imaging.FrameDimension.Time) > 1
            End If
        Next
        Return False
    End Function
#End Region
 
#Region "Properties"
    ''' <summary>
    ''' Возвращает состояние работы
    ''' </summary>
    ''' <returns>Bool</returns>
    Public ReadOnly Property IsWorking As Boolean
        Get
            Return _isWorking
        End Get
    End Property
 
    ''' <summary>
    ''' Возвращает состояние ссылки на окно. Если true, то ссылка была деструктуризированна и дальнейшая работа компонента невозможна
    ''' </summary>
    ''' <returns>Bool</returns>
    Public ReadOnly Property IsHandleDestroyed As Boolean
        Get
            Return (_hWnd = IntPtr.Zero)
        End Get
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает фон подложки
    ''' </summary>
    ''' <returns>Bool</returns>
    Public Property BackColor As Color
        Get
            Return _bkColor
        End Get
        Set(value As Color)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            SyncLock _syncObj
                _bkColor = value
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает область рисования. Возможно изменение во время проецирования
    ''' </summary>
    ''' <returns>Rectangle</returns>
    Public Property ClipRectangle As Rectangle
        Get
            Return _rect
        End Get
        Set(value As Rectangle)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            If value.Width <= 0 Or value.Height <= 0 Then
                Throw New Exception("Область рисования не должна иметь нулевые размеры")
            End If
 
            SyncLock _syncObj
                If _isWorking Then
                    _timer.Stop()
                    InvalidateRect(_hWnd, IntPtr.Zero, True)
                End If
 
                _rect = value
                Me.CreateBufferedGraphics()
 
                If _isWorking Then
                    _timer.Interval = 1.0R
                    _timer.Start()
                End If
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает количество кадров
    ''' </summary>
    ''' <returns></returns>
    Public ReadOnly Property FrameCount As Integer
        Get
            Return _imageHelper.FrameCount
        End Get
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает текущий кадр
    ''' </summary>
    ''' <returns></returns>
    Public Property CurrentFrame As Integer
        Get
            Return _imageHelper.Frame
        End Get
        Set(value As Integer)
            If value < 0 Or value >= _imageHelper.FrameCount Then
                Throw New Exception("Значение выходит за диапазон")
            End If
 
            SyncLock _syncObj
                _imageHelper.Frame = value
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает true, если указанное в конструкторе изображение поддерживает анимацию
    ''' </summary>
    ''' <returns></returns>
    Public ReadOnly Property Animated As Boolean
        Get
            Return _imageHelper.Animated
        End Get
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает свойство проигрывание анимации без задержки. 
    ''' Если указано true, то анимация будет проигрываться без указанной в свойствах изображения задержки
    ''' </summary>
    ''' <returns></returns>
    Public Property InfinityAnimate As Boolean
        Get
            Return _infinity
        End Get
        Set(value As Boolean)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            SyncLock _syncObj
                If _infinity <> value Then
 
                    _infinity = value
                    If _infinity Then
                        _timer.Interval = 1.0R
                    End If
 
                End If
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает свойство порядка проигрывания анимации. Если указано true, то анимация будет проигрываться в обратном порядке
    ''' </summary>
    ''' <returns></returns>
    Public Property ReverseAnimate As Boolean
        Get
            Return _reverse
        End Get
        Set(value As Boolean)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            SyncLock _syncObj
                If _reverse <> value Then
                    _reverse = value
                End If
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает\присваеивает текущее изображение компоненту
    ''' </summary>
    ''' <returns></returns>
    Public Property Image As Image
        Get
            Return _imageHelper.Image
        End Get
        Set(value As Image)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            If value Is Nothing Then
                Throw New NullReferenceException("Value")
            End If
 
            SyncLock _syncObj
                If _isWorking Then
                    _timer.Stop()
                End If
 
                _imageHelper = New ImageAnimatorHelper(value)
 
                If _isWorking Then
                    _timer.Interval = 1.0R
                    _timer.Start()
                End If
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает объект синхронизации. Для внешнего взаимодействия из других потоков
    ''' </summary>
    ''' <returns>Object</returns>
    Public ReadOnly Property SyncObject As Object
        Get
            Return _syncObj
        End Get
    End Property
#End Region
 
#Region "IDisposable"
    Protected Overridable Sub Dispose(disposing As Boolean)
        If Not _disposedValue Then
            If disposing Then
                Me.StopProjection()
                _bg.Dispose()
                _bg = Nothing
                _imageHelper = Nothing
            End If
        End If
        _disposedValue = True
    End Sub
 
    Public Sub Dispose() Implements IDisposable.Dispose
        Dispose(True)
    End Sub
#End Region
 
#Region "ImageAnimatorHelper"
    Private Class ImageAnimatorHelper
        Private Const __propertyTagTimeDelay As Integer = &H5100 ' ID свойства времени задежки кадров
 
        Private _image As Image
        Private _frame As Integer
        Private _frameCount As Integer
        Private _frameDelay() As Integer
        Private _frameDirty As Boolean
        Private _currentFrameDelay As Integer
        Private _animated As Boolean
 
#Region "Methods"
        Public Sub New(Image As Image)
            _image = Image
 
            _animated = ImageProjectionAsync.CanAnimate(_image)
 
            If _animated Then
                _frameCount = _image.GetFrameCount(Imaging.FrameDimension.Time)
 
                _frameDelay = New Integer(_frameCount - 1) {}
 
                Dim prop As Imaging.PropertyItem = _image.GetPropertyItem(__propertyTagTimeDelay)
                Debug.Assert(prop.Len = _frameCount * 4, "Размер буфера свойства не соответствует отношению количеству кадров")
 
                Dim buf() As Byte = prop.Value
 
                For i As Integer = 0 To _frameCount - 1
                    _frameDelay(i) = BitConverter.ToInt32(buf, i * 4) * 10
                    If _frameDelay(i) = 0 Then
                        _frameDelay(i) = 1
                    End If
                Next
            Else
                _frameCount = 1
                _frameDelay = New Integer() {1}
            End If
 
            _currentFrameDelay = _frameDelay(0)
        End Sub
 
        Public Sub UpdateFrame()
            If _frameDirty Then
                _image.SelectActiveFrame(Imaging.FrameDimension.Time, _frame)
                _frameDirty = False
            End If
        End Sub
 
        Public Sub NextFrame()
            If _animated Then
                _frame += 1
                If _frame = _frameCount Then
                    _frame = 0
                End If
                _currentFrameDelay = _frameDelay(_frame)
                _frameDirty = True
            End If
        End Sub
 
        Public Sub PreviousFrame()
            If _animated Then
                _frame -= 1
                If _frame < 0 Then
                    _frame = _frameCount - 1
                End If
                _currentFrameDelay = _frameDelay(_frame)
                _frameDirty = True
            End If
        End Sub
#End Region
 
#Region "Properties"
        Public Property Frame As Integer
            Get
                Return _frame
            End Get
            Set(value As Integer)
                If _frame <> value Then
 
                    Debug.Assert(value >= 0 And value < _frameCount, "Выход за пределы диапазона")
 
                    _frame = value
                    _currentFrameDelay = _frameDelay(_frame)
                    _frameDirty = True
                End If
            End Set
        End Property
 
        Public ReadOnly Property FrameCount As Integer
            Get
                Return _frameCount
            End Get
        End Property
 
        Public ReadOnly Property FrameDelay As Integer()
            Get
                Return _frameDelay
            End Get
        End Property
 
        Public ReadOnly Property FrameDirty As Boolean
            Get
                Return _frameDirty
            End Get
        End Property
 
        Public ReadOnly Property Animated As Boolean
            Get
                Return _animated
            End Get
        End Property
 
        Public ReadOnly Property Image As Image
            Get
                Return _image
            End Get
        End Property
 
        Public ReadOnly Property FrameLast As Boolean
            Get
                Return _frame = (_frameCount - 1)
            End Get
        End Property
 
        Public ReadOnly Property CurrentFrameDelay() As Integer
            Get
                Return _currentFrameDelay
            End Get
        End Property
#End Region
 
    End Class
 
#End Region
 
End Class

        'Проецирование изображения на другое окно
        Dim proc() As Diagnostics.Process = Diagnostics.Process.GetProcessesByName("Notepad")
 
        If proc.Length > 0 Then
            Dim ipa As New ImageProjectionAsync(proc(0).MainWindowHandle, New Rectangle(0, 0, 100, 100), Color.White, [Image])
             ipa.StartProjection()
        End If

        'Проецирование анимации в момент длительной обработки
        Dim panel As New Control()
        panel.Dock = DockStyle.Fill
 
        Me.Controls.Add(panel)
 
        panel.BringToFront()
 
        Dim ipa As New ImageProjectionAsync(panel.Handle, panel.ClientRectangle, Color.White, [Image])
        ipa.StartProjection()
 
        'длительная обработка
        'Threading.Thread.Sleep(10000)
 
        ipa.StopProjection()
        Me.Controls.Remove(panel)

Imports System.Runtime.InteropServices
 
Public Class FormEx
    Inherits Form
#Region "Designer Code"
 
    'Form overrides dispose to clean up the component list.
    <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
 
    'Required by the Windows Form Designer
    Private components As System.ComponentModel.IContainer
 
    'NOTE: The following procedure is required by the Windows Form Designer
    'It can be modified using the Windows Form Designer.  
    'Do not modify it using the code editor.
    <DebuggerStepThrough()>
    Private Sub InitializeComponent()
        components = New ComponentModel.Container()
        Me.AutoScaleMode = AutoScaleMode.Font
        Me.ClientSize = New Size(800, 450)
        Me.Text = "Form1"
    End Sub
#End Region
 
    Private _hookSet As Boolean = False
 
    Public Event BlockKeysChanged As EventHandler(Of BlockKeysEventArgs)
    Protected Overridable Sub OnBlockKeyChanged(ev As BlockKeysEventArgs)
        RaiseEvent BlockKeysChanged(Me, ev)
    End Sub
 
#Region "Свойства"
 
    Private _blockAltTab As Boolean
    Public Property BlockAltTab() As Boolean
        Get
            Return _blockAltTab
        End Get
        Set(ByVal value As Boolean)
            If value = _blockAltTab Then
                Return
            End If
            _blockAltTab = value
            SetHook()
            OnBlockKeyChanged(New BlockKeysEventArgs(BlockKeys.AltTab, _blockAltTab))
        End Set
    End Property
 
    Private _blockCtrlEsc As Boolean
    Public Property BlockCtrlEsc() As Boolean
        Get
            Return _blockCtrlEsc
        End Get
        Set(ByVal value As Boolean)
            If value = _blockCtrlEsc Then
                Return
            End If
            _blockCtrlEsc = value
            SetHook()
            OnBlockKeyChanged(New BlockKeysEventArgs(BlockKeys.CtrlEsc, _blockCtrlEsc))
        End Set
    End Property
 
    Private _blockAltEsc As Boolean
    Public Property BlockAltEsc() As Boolean
        Get
            Return _blockAltEsc
        End Get
        Set(ByVal value As Boolean)
            If value = _blockAltEsc Then
                Return
            End If
            _blockAltEsc = value
            SetHook()
            OnBlockKeyChanged(New BlockKeysEventArgs(BlockKeys.AltEsc, _blockAltEsc))
        End Set
    End Property
 
    Private _blockWin As Boolean
    Public Property BlockWin() As Boolean
        Get
            Return _blockWin
        End Get
        Set(ByVal value As Boolean)
            If value = _blockWin Then
                Return
            End If
            _blockWin = value
            SetHook()
            OnBlockKeyChanged(New BlockKeysEventArgs(BlockKeys.Win, _blockWin))
        End Set
    End Property
#End Region
 
#Region "Вспомогательные типы"
 
    Public Enum BlockKeys
        None
        AltTab
        CtrlEsc
        AltEsc
        Win
    End Enum
 
    Public Class BlockKeysEventArgs
        Inherits EventArgs
        Public Property BlockedKey() As BlockKeys
        Public Property IsBlocked() As Boolean
        Public Sub New(bk As BlockKeys, blocked As Boolean)
            BlockedKey = bk
            IsBlocked = blocked
        End Sub
    End Class
#End Region
 
#Region "Windows API"
 
    <DllImport("user32.dll", EntryPoint:="SetWindowsHookExA")>
    Shared Function SetWindowsHookEx(ByVal idHook As Integer, ByVal lpfn As LowLevelKeyboardProcDelegate,
         ByVal hMod As IntPtr, ByVal dwThreadId As Integer) As Integer
    End Function
 
    <DllImport("user32.dll", EntryPoint:="UnhookWindowsHookEx")>
    Shared Function UnhookWindowsHookEx(ByVal hHook As IntPtr) As Boolean
    End Function
 
    <DllImport("user32.dll", EntryPoint:="UnhookWindowsHookEx")>
    Shared Function CallNextHookEx(ByVal hHook As IntPtr, ByVal nCode As Integer, ByVal wParam As Integer,
         ByRef lParam As KBDLLHOOKSTRUCT) As Integer
    End Function
    Delegate Function LowLevelKeyboardProcDelegate(ByVal nCode As Integer, ByVal wParam As Integer, ByRef lParam As KBDLLHOOKSTRUCT) As Integer
 
    Const WH_KEYBOARD_LL As Integer = 13 'Контроль ввода с клавиатуры
 
    'Структура для информации о нажатой кнопке
    Structure KBDLLHOOKSTRUCT
        Dim vkCode As Integer
        Dim scanCode As Integer
        Dim flags As Integer
        Dim time As Integer
        Dim dwExtraInfo As Integer
    End Structure
#End Region
    'При закрытии формы снимаем хук в любом случае
    Protected Overrides Sub OnFormClosing(e As FormClosingEventArgs)
        MyBase.OnFormClosing(e)
        UnhookWindowsHookEx(WH_KEYBOARD_LL)
    End Sub
    ''' <summary>
    ''' Установка хука на клавиатурные сочетания
    ''' </summary>
    Private Sub SetHook()
        Dim _blocked As Boolean = _blockAltEsc OrElse _blockAltTab OrElse _blockCtrlEsc OrElse _blockWin
        'Избегаем повторной установки хука
        If _blocked AndAlso Not _hookSet Then
            SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, IntPtr.Zero, 0)
            _hookSet = True
        ElseIf Not _blocked Then
            UnhookWindowsHookEx(WH_KEYBOARD_LL)
            _hookSet = False
        End If
    End Sub
    ''' <summary>
    ''' Обработка нажатия
    ''' </summary>
    Private Function LowLevelKeyboardProc(nCode As Integer, wParam As Integer, ByRef lParam As KBDLLHOOKSTRUCT) As Integer
        Dim blkKeys As BlockKeys
 
        If _blockAltTab AndAlso (lParam.vkCode = &H9) AndAlso (lParam.flags = 32) Then
            blkKeys = BlockKeys.AltTab
        ElseIf _blockAltEsc AndAlso (lParam.vkCode = &H1B) AndAlso (lParam.flags = 32) Then
            blkKeys = BlockKeys.AltEsc
        ElseIf _blockCtrlEsc AndAlso (lParam.vkCode = &H1B) AndAlso (lParam.flags = 0) Then
            blkKeys = BlockKeys.CtrlEsc
        ElseIf _blockWin AndAlso (lParam.vkCode = &H5B) AndAlso (lParam.flags = 1) _
            Or ((lParam.vkCode = &H5C) AndAlso (lParam.flags = 1)) Then
            blkKeys = BlockKeys.Win
        End If
 
        Select Case blkKeys
            Case BlockKeys.AltTab
                Return 1
            Case BlockKeys.AltEsc
                Return 1
            Case BlockKeys.CtrlEsc
                Return 1
            Case BlockKeys.Win
                Return 1
        End Select
        Return CallNextHookEx(IntPtr.Zero, nCode, wParam, lParam)
 
    End Function
End Class