Option Strict Off

Imports System

Imports System.Collections.Generic

Imports System.Diagnostics

Imports System.Text

Imports System.IO

Imports System.Collections

Imports System.Collections.Specialized

Imports System.Drawing

Imports System.Drawing.Imaging

Imports System.Drawing.Drawing2D

Imports System.Drawing.Image

Imports System.Threading

Imports System.Runtime.Serialization

Imports System.Windows.Forms

Imports System.Windows

Imports System.Runtime.InteropServices

 

Module CreateAnimatedGif

    Dim environ As String = Environment.UserName

    Dim userPath As String = "C:\Users\" & environ & "\Desktop\Animated Gifs\"

    Dim Bitmaps As List(Of Bitmap) = New List(Of Bitmap)

    Dim width As Integer

    Dim height As Integer

    Dim windowRect As New NativeMethods.RECT

    Sub Main()

        'Use WindowCoord subroutine if you want to capture a specific application

        'window, or child window within application.

        'otherwise, leave commented.

        'WindowCoord()

        'Screenshots subroutine will need to be looped based on

        'the amount of time you want to record on-screen actions

        'otherwise it will only take one screenshot.

        'If you are carrying out a specific task, maybe you 

        'can write code to loop the subroutine until the task is completed.

        Screenshots()

        'assemble screenshots into animated GIF

        'Sets certain properties, such as Frame delay and number of times the animation

        'will loop

        AssembleGIF()

 

    End Sub

    Sub WindowCoord()

        Dim MainWindow As IntPtr

        Dim WindowName As String

        Dim count As Integer

        Dim Lstring As Integer

        Dim Rstring As Integer

        'Create a buffer of 256 characters

        Dim Caption As New System.Text.StringBuilder(256)

        For Each p As Process In Process.GetProcesses()

            If p.MainWindowTitle.Contains("Add Window Title Here, or a unique part of it") Then

                WindowName = p.MainWindowTitle

                MainWindow = p.MainWindowHandle

            End If

        Next

        'The following commented code can be used to parse WindowName

        'if you need to get a substring out of the

        'window title

        'it will loop through and look at each character 

        'in the string

        'For Each c As Char In WindowName

        '    count += 1

        '    If c = "[" Then

        '        Lstring = count

        '    ElseIf c = "]" Then

        '        Rstring = count

        '    End If

        'Next

        'WindowName = WindowName.Substring(Lstring, WindowName.Length - Lstring - 1)

        'Enumerate child windows

        For Each child As IntPtr In NativeMethods.GetChildWindows(MainWindow)

            NativeMethods.GetWindowText(child, Caption, Caption.Capacity)

            If Caption.ToString = WindowName Then

                'Get window width, height which will  be used in 

                'Screenshot subroutine

                NativeMethods.GetWindowRect(child, windowRect)

                width = windowRect.right - windowRect.left

                height = windowRect.bottom - windowRect.top

            End If

        Next

    End Sub

    Sub Screenshots()

        Static count As Integer

        'declare variables

        Dim bounds As Rectangle

        Dim screenshot As System.Drawing.Bitmap

        Dim graph As Graphics

        'Use  the following two lines to get screenshot coordinates, used for full screen (screenshot width and height in ratio to screen)

        bounds = Screen.PrimaryScreen.Bounds

        screenshot = New System.Drawing.Bitmap(bounds.Width, bounds.Height, System.Drawing.Imaging.PixelFormat.Format32bppRgb)

        'If you only want to capture a specific application window, or child window you can use the following line of code

        'But you will need to call the WindoCoord Subroutine and enter the specific window title you are looking for

        'screenshot = New System.Drawing.Bitmap(width, height, System.Drawing.Imaging.PixelFormat.Format32bppRgb)

        'screen shot quality

        screenshot.SetResolution(300, 300) 'dpi

        graph = Graphics.FromImage(screenshot)

        graph.Clear(Color.White)

        graph.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic

        graph.SmoothingMode = Drawing2D.SmoothingMode.AntiAlias

        graph.SmoothingMode = Drawing2D.SmoothingMode.HighQuality

        graph.CopyFromScreen(windowRect.left, windowRect.top, 0, 0, New Size(width, height), CopyPixelOperation.SourceCopy)

        graph.TextRenderingHint = Drawing.Text.TextRenderingHint.AntiAlias

        'Print text on screenshot

        Using F As New Font("Arial", 10)

            'Create a brush

            Using B As New SolidBrush(Color.Black)

                'Draw some text

                graph.DrawString(Now.ToString("yyyy-MM-dd HH:mm:ss fff"), F, B, 20, 20)

            End Using

        End Using

        'Add screenshot to Bitmaps List for later

        'Assembly and animation

        Dim Bmp As New Bitmap(screenshot)

        Bitmaps.Add(Bmp)

        count += 1

        If count < 5 Then Screenshots()

    End Sub

    Sub AssembleGIF()

#Region "Exsample"

        'Bitmaps.Clear()

        'Bitmaps.Add(New Bitmap("C:\Users\Administrator\OneDrive\문서\카카오톡 받은 파일\요미_0013m.jpg"))

        'Bitmaps.Add(New Bitmap("C:\Users\Administrator\OneDrive\문서\카카오톡 받은 파일\요미_0018m.jpg"))

#End Region

        'GDI+ constants absent from system.drawing

        Const PropertyTagFrameDelay As Integer = &H5100

        Const PropertyTagLoopCount As Integer = &H5101

        Const PropertyTagTypeLong As Short = 4

        Const PropertyTagTypeShort As Short = 3

        Const UIntBytes As Integer = 4

        Dim gifEncoder As ImageCodecInfo = GetEncoder(ImageFormat.Gif)

        Dim myEncoder As System.Drawing.Imaging.Encoder = System.Drawing.Imaging.Encoder.Quality

        'Parameters of the first frame

        Dim myEncoderParameters1 As New EncoderParameters(1)

        myEncoderParameters1.Param(0) = New EncoderParameter(System.Drawing.Imaging.Encoder.SaveFlag, CLng(EncoderValue.MultiFrame))

        'Parameters of other frames

        Dim myEncoderParametersN = New EncoderParameters(1)

        myEncoderParametersN.Param(0) = New EncoderParameter(System.Drawing.Imaging.Encoder.SaveFlag, CLng(EncoderValue.FrameDimensionTime))

        Dim myEncoderParametersFlush As New EncoderParameters(1)

        myEncoderParametersFlush.Param(0) = New EncoderParameter(System.Drawing.Imaging.Encoder.SaveFlag, CLng(EncoderValue.Flush))

        'Property for the frame delay (apparently no other way to create a fresh instance)

        Dim frameDelay As PropertyItem = DirectCast(FormatterServices.GetUninitializedObject(GetType(PropertyItem)), PropertyItem)

        frameDelay.Id = PropertyTagFrameDelay

        frameDelay.Type = PropertyTagTypeLong

        'Length of the value in bytes

        frameDelay.Len = Bitmaps.Count * UIntBytes

        'The value is an array of 4-byte entries: one per frame.

        'Every entry is the frame delay in 1/100-s of a second, in little endian.

        Dim desiredLength = Bitmaps.Count * UIntBytes

        'E.g., here, we're setting the delay of every frame to 1 second.

        frameDelay.Len = desiredLength

        frameDelay.Value = New Byte(desiredLength - 1) {}

        Dim argument As UInteger = 70   '// 딜레이

        Dim frameDelayBytes = BitConverter.GetBytes(argument)

        Dim J As Integer = 0

        For J = LBound(Bitmaps.ToArray) To Bitmaps.Count

            If J < Bitmaps.Count Then

                Array.Copy(frameDelayBytes, 0, frameDelay.Value, J * UIntBytes, UIntBytes)

            Else

                Exit For

            End If

        Next

        'Property Item for the number of animation loops

        Dim loopPropertyItem As PropertyItem = DirectCast(FormatterServices.GetUninitializedObject(GetType(PropertyItem)), PropertyItem)

        loopPropertyItem.Id = PropertyTagLoopCount

        loopPropertyItem.Type = PropertyTagTypeShort

        loopPropertyItem.Len = 1

        'Ensure that the user has a working directory set-up

        'to store the Gif

        If (Not System.IO.Directory.Exists(userPath)) Then

            System.IO.Directory.CreateDirectory(userPath)

        End If

        '0 means to animate forever

        Dim loopArgument As UShort = 0

        loopPropertyItem.Value = BitConverter.GetBytes(loopArgument)

        'Enter name of Gif in FileStream() below. Maybe user Window Title?

        Dim Fstream As FileStream = New FileStream(userPath & "\" & "Enter Name of Gif here" & ".Gif", FileMode.Create)

        Using Fstream

            Dim first As Boolean = True

            Dim firstBitmap As Bitmap = Nothing

            'Bitmaps is a collection of Bitmap instances that'll become gif frames

            For Each bitmap As Bitmap In Bitmaps

                bitmap = ResizeImage(bitmap, New Size(500, 500))

                If first = True Then

                    firstBitmap = bitmap

                    firstBitmap.SetPropertyItem(frameDelay)

                    firstBitmap.SetPropertyItem(loopPropertyItem)

                    firstBitmap.Save(Fstream, gifEncoder, myEncoderParameters1)

                    first = False

                Else

                    firstBitmap.SaveAdd(bitmap, myEncoderParametersN)

                End If

            Next

            firstBitmap.SaveAdd(myEncoderParametersFlush)

        End Using

    End Sub

 

    Public Function ResizeImage(ByVal bm_source As Image, ByVal s As Size) As Image

        Dim ratioX = CDbl(s.Width) / bm_source.Width

        Dim ratioY = CDbl(s.Height) / bm_source.Height

        Dim ratio = Math.Min(ratioX, ratioY)

        Dim newWidth = CInt((bm_source.Width * ratio))

        Dim newHeight = CInt((bm_source.Height * ratio))

        Dim newImage = New Bitmap(s.Width, s.Height)

 

        Using g = Graphics.FromImage(newImage)

            Dim y As Integer = (s.Height / 2) - newHeight / 2

            Dim x As Integer = (s.Width / 2) - newWidth / 2

            g.DrawImage(bm_source, x, y, newWidth, newHeight)

        End Using

        Return newImage

    End Function

 

    Private Function GetEncoder(ByVal format As ImageFormat) As ImageCodecInfo

        Dim codecs As ImageCodecInfo() = ImageCodecInfo.GetImageDecoders()

        Dim codec As ImageCodecInfo

        For Each codec In codecs

            If codec.FormatID = format.Guid Then

                Return codec

            End If

        Next codec

        Return Nothing

    End Function

End Module

Public Class NativeMethods

    <DllImport("User32.dll")>

    Private Shared Function EnumChildWindows _

      (ByVal WindowHandle As IntPtr, ByVal Callback As EnumWindowProcess,

      ByVal lParam As IntPtr) As Boolean

    End Function

    <StructLayout(LayoutKind.Sequential)>

    Public Structure RECT

        Public left As Integer

        Public top As Integer

        Public right As Integer

        Public bottom As Integer

    End Structure 'RECT

    Public Delegate Function EnumWindowProcess(ByVal Handle As IntPtr, ByVal Parameter As IntPtr) As Boolean

    Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Integer, ByRef lpRect As RECT) As Integer

    Public Declare Auto Function GetWindowText Lib "user32" _

             (ByVal hWnd As System.IntPtr,

             ByVal lpString As System.Text.StringBuilder,

             ByVal cch As Integer) As Integer

    Public Shared Function GetChildWindows(ByVal ParentHandle As IntPtr) As IntPtr()

        Dim ChildrenList As New List(Of IntPtr)

        Dim ListHandle As GCHandle = GCHandle.Alloc(ChildrenList)

        Try

            EnumChildWindows(ParentHandle, AddressOf EnumWindow, GCHandle.ToIntPtr(ListHandle))

        Finally

            If ListHandle.IsAllocated Then ListHandle.Free()

        End Try

        Return ChildrenList.ToArray

    End Function

    Private Shared Function EnumWindow(ByVal Handle As IntPtr, ByVal Parameter As IntPtr) As Boolean

        Dim ChildrenList As List(Of IntPtr) = GCHandle.FromIntPtr(Parameter).Target

        If ChildrenList Is Nothing Then Throw New Exception("GCHandle Target could not be cast as List(Of IntPtr)")

        ChildrenList.Add(Handle)

        Return True

    End Function

End Class