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

Imports NETWORKLIST
Public Class InternetConnectionChecker_UsingCOM
    Private ReadOnly Networ_kList_Manager As INetworkListManager
 
    Public Sub New()
        Networ_kList_Manager = New NetworkListManager()
    End Sub
 
    Public Function IsConnected() As Boolean
        Return Networ_kList_Manager.IsConnectedToInternet
    End Function
End Class

    Public Function IsInternetAvailable_UsingCOM() As Boolean
        Try
            Dim networkListManager As Object = Activator.CreateInstance(Type.GetTypeFromCLSID(New Guid("{DCB00C01-570F-4A9B-8D69-199FDBA5723B}")))
            Dim InternectConnectuinStatus As Boolean = CBool(networkListManager.IsConnectedToInternet)
            networkListManager = Nothing
            GC.Collect()
            Return InternectConnectuinStatus
        Catch ex As Exception
            Return False
        End Try
    End Function

    Private Function IsInternetAvailable_UsingPING() As Boolean
        Try
            Using myPing As Ping = New Ping()
                Dim host As String = "sea-soft.ru"
                'Dim host As String = "google.com"
                Dim buffer As Byte() = New Byte(31) {}
                Dim timeout As Integer = 1000
                Dim pingOptions As PingOptions = New PingOptions()
                Dim reply As PingReply = myPing.Send(host, timeout, buffer, pingOptions)
                Return (reply.Status = IPStatus.Success)
            End Using
        Catch ex As Exception
            Return False
        End Try
    End Function

'Check if the response of http://www.msftncsi.com/ncsi.txt is Microsoft NCSI.
'If not, check if the IP of dns.msftncsi.com is 131.107.255.255.
Public Shared Function IsInternetAvailable() As Boolean
    Try
        Dim ncsi As String = New WebClient().DownloadString("http://www.msftncsi.com/ncsi.txt")
        If ncsi = "Microsoft NCSI" Then Return True
    Catch : End Try
 
    Try
        Dim iphost As IPHostEntry = Dns.GetHostEntry("dns.msftncsi.com")
        If iphost IsNot Nothing Then
            For Each item In iphost.AddressList
                If item.ToString() = "131.107.255.255" Then Return True
            Next
        End If
    Catch : End Try
 
    Return False
End Function

Public Shared Function CheckForInternetConnection() As Boolean
    Try
        Using client = New WebClient()
            Using stream = client.OpenRead("www.google.com")
                Return True
            End Using
        End Using
    Catch
        Return False
    End Try
End Function

    <DllImport("wininet.dll")> _
    Private Shared Function InternetGetConnectedState(ByRef Description As Integer, ByVal ReservedValue As Integer) As Boolean
    End Function
 
    Private Shared Function IsInternetAvailable() As Boolean
        Try
            Dim ConnDesc As Integer
            Dim conn As Boolean = InternetGetConnectedState(ConnDesc, 0)
            Return conn
        Catch
            Return False
        End Try
    End Function

    Private Shared Function IsInternetAvailableByDns() As Boolean
        Try
            Dim iheObj As IPHostEntry = Dns.GetHostEntry("www.google.com")
            Return True
        Catch
            Return False
        End Try
    End Function

If My.Computer.Network.IsAvailable = True Then
    'Do Something
End If

Imports System.IO
Imports System.Text
 
Public Class CreatePDF
    Private out As System.IO.FileStream
    Private Sub WriStr(s As String)
        out.Write(System.Text.Encoding.ASCII.GetBytes(s), 0, s.Length)
    End Sub
    
    Public Function CreatePdf(bmp As Bitmap)
        On Error Resume Next
        Dim strPath As String = FileSystem.CurDir
        Dim sDir As String = FileSystem.Dir(FileSystem.CurDir & "\Pdf", FileAttribute.Directory)
        If sDir = "" Then
            FileSystem.MkDir(FileSystem.CurDir & "\Pdf")
        End If
        sDir = FileSystem.CurDir & "\Pdf"
        Dim OutPdf As String = sDir + "\OutFile" & CStr(Date.Now.Hour) & CStr(Date.Now.Minute) & CStr(Date.Now.Second) & ".pdf"
        Dim strFileName As String = sDir + "\OutIma" & CStr(Date.Now.Hour) & CStr(Date.Now.Minute) & CStr(Date.Now.Second) & ".jpeg"
        Dim w As Integer = bmp.Width
        Dim h As Integer = bmp.Height
        Dim wf As String = CStr(w * 72) / bmp.HorizontalResolution
        Dim hf As String = CStr(h * 72) / bmp.VerticalResolution
        For Each deleteFile In Directory.GetFiles(sDir, "*.jpeg", SearchOption.TopDirectoryOnly)
            File.Delete(deleteFile)
        Next
        For Each deleteFile In Directory.GetFiles(sDir, "*.pdf", SearchOption.TopDirectoryOnly)
            File.Delete(deleteFile)
        Next
        File.Delete(OutPdf)
        bmp.Save(strFileName, System.Drawing.Imaging.ImageFormat.Jpeg)
        wf = wf.Replace(",", ".")
        hf = hf.Replace(",", ".")
        out = File.Create(OutPdf)
        Dim lens As New ArrayList()
        WriStr("%PDF-1.5" + vbCrLf)
        lens.Add(out.Position)
        WriStr(CStr(lens.Count) + " 0 obj " + "<</Type /Catalog" + vbCrLf + "/Pages 2 0 R>>" + vbCrLf + "endobj" + vbCrLf)
        lens.Add(out.Position)
        WriStr(CStr(lens.Count) + " 0 obj " + "<</Count 1/Kids [ <<" + vbCrLf + "" +
                     "/Type /Page" + vbCrLf + "" +
                     "/Parent 2 0 R" + vbCrLf + "" +
                     "/MediaBox [0 0 " + wf + " " + hf + "]" + vbCrLf + "" +
                     "/Resources<<  /ProcSet [/PDF /ImageC]" + vbCrLf + " /XObject <</Im1 4 0 R >>  >>" + vbCrLf + "" +
                     "/Contents 3 0 R" + vbCrLf + "" +
                     ">>" + vbCrLf + " ]" + vbCrLf + "" +
                     ">>" + vbCrLf + "endobj" + vbCrLf + "")
 
        Dim X As String = "" + vbCrLf + "" +
                "q" + vbCrLf + "" +
                "" + wf + " 0 0 " + hf + " 0 0 cm" + vbCrLf + "" +
                "/Im1 Do" + vbCrLf + "" +
                "Q" + vbCrLf + ""
        lens.Add(out.Position)
 
        WriStr(CStr(lens.Count) + " 0 obj " + "<</Length " + CStr(X.Length) + ">>" +
                        "stream" + X + "endstream" + vbCrLf + "" +
                        "endobj" + vbCrLf + "")
        lens.Add(out.Position)
 
        WriStr(CStr(lens.Count) + " 0 obj " + "<</Name /Im1" +
                        "/Type /XObject" + vbCrLf + "" +
                        "/Subtype /Image" + vbCrLf + "" +
                        "/Width " + w.ToString() +
                        "/Height " + h.ToString() +
                        "/Length 5 0 R" + vbCrLf + "" +
                        "/Filter /DCTDecode" + vbCrLf + "" +
                        "/ColorSpace /DeviceRGB" + vbCrLf + "" +
                        "/BitsPerComponent 8" + vbCrLf + "" +
                        ">> stream" + vbCrLf + "")
 
 
        Dim Siz As Long = out.Position
        Dim bufferSize As Integer = 1024
        Dim inputFile = IO.File.Open(strFileName, IO.FileMode.Open)
        Dim bytes = New Byte(bufferSize - 1) {}
 
        While inputFile.Read(bytes, 0, bufferSize) > 0
            out.Write(bytes, 0, bufferSize)
        End While
        Siz = out.Position - Siz
 
        WriStr("" + vbCrLf + "endstream" + vbCrLf + "" + "endobj" + vbCrLf + "")
        lens.Add(out.Position)
        WriStr(CStr(lens.Count) + " 0 obj " + Siz.ToString() + " endobj" + vbCrLf + "")
        Dim startxref As Long = out.Position
        WriStr("xref" + vbCrLf + "" + "0 " + (lens.Count + 1).ToString() + "" + vbCrLf + "" + "0000000000 65535 f" + vbCrLf + "")
        For Each L In lens
            WriStr((10000000000 + L).ToString().Substring(1) + " 00000 n" + vbCrLf + "")
        Next
 
        WriStr("trailer" + vbCrLf + "" + "<<" + vbCrLf + "" +
                    "  /Size " + (lens.Count + 1).ToString() + "" + vbCrLf + "" +
                    "  /Root 1 0 R" + vbCrLf + "" +
                    ">>" + vbCrLf + "" + "startxref" + vbCrLf + "" + startxref.ToString() + "" + vbCrLf + "%%EOF")
        out.Close()
 
        Return OutPdf
    End Function
 
End Class

Public Class Form1
    Const WM_GETTEXT = &HD
    Const WM_USER = &H400
    Const SB_GETTEXTW = WM_USER + 13
    Const SB_GETTEXTLENGTHW = WM_USER + 12
    Const PROCESS_ALL_ACCESS = 2035711
    Const SB_GETPARTS = WM_USER + 6
    Const MEM_COMMIT = &H1000
    Const MEM_RELEASE = &H8000
    Const PAGE_READWRITE = &H4
 
    Declare Unicode Function SendMessage Lib "user32.dll" Alias "SendMessageW" (ByVal hwnd As IntPtr, ByVal msg As Integer, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
    Declare Unicode Function GetWindowThreadProcessId Lib "user32.dll" Alias "GetWindowThreadProcessId" (ByVal hwnd As IntPtr, ByRef ProcessId As UInt32) As UInt32
 
    Declare Unicode Function CloseHandle Lib "kernel32.dll" Alias "CloseHandle" (ByVal hProcess As IntPtr) As Integer
    Declare Unicode Function OpenProcess Lib "kernel32.dll" Alias "OpenProcess" (ByVal dwDesiredAccess As UInt32, ByVal bInheritHandle As UInt32, ByVal dwProcessId As UInt32) As IntPtr
    Declare Unicode Function VirtualAllocEx Lib "kernel32.dll" Alias "VirtualAllocEx" (ByVal hProcess As IntPtr, ByVal lpAddress As IntPtr, ByVal dwSize As IntPtr, ByVal flAllocationType As UInt32, ByVal flProtect As UInt32) As IntPtr
    Declare Unicode Function VirtualFreeEx Lib "kernel32.dll" Alias "VirtualFreeEx" (ByVal hProcess As IntPtr, ByVal lpAddress As IntPtr, ByVal dwSize As IntPtr, ByVal flProtect As UInt32) As IntPtr
    Declare Unicode Function ReadProcessMemory Lib "kernel32.dll" Alias "ReadProcessMemory" (ByVal hProcess As IntPtr, ByVal lpBaseAddress As IntPtr, ByVal lpBuffer As System.Text.StringBuilder, ByVal nSize As IntPtr, ByRef lpNumberOfBytesRead As IntPtr) As Integer
 
    Function getStatusLabelText(Hwnd_StatusBar As IntPtr, LabelIndex As IntPtr) As String
        ' Заменить на hwnd своей строки состояния
        Dim ProcessId As UInt32
        Dim ThreadId As UInt32 = GetWindowThreadProcessId(Hwnd_StatusBar, ProcessId)
        Dim ProcessHandle As IntPtr = OpenProcess(PROCESS_ALL_ACCESS, 0, ProcessId)
 
        If ProcessHandle <> 0 Then
 
            'Dim StatusBarParts As Integer = SendMessage(hwndStatus, SB_GETPARTS, 0, 0)
            Dim textLength As Integer = SendMessage(Hwnd_StatusBar, SB_GETTEXTLENGTHW, LabelIndex, 0)
 
            If textLength Then
 
                Dim cbBytes As Integer = 2 * (textLength + 1)
                Dim lpRemoteBuff As IntPtr = VirtualAllocEx(ProcessHandle, 0, cbBytes, MEM_COMMIT, PAGE_READWRITE)
 
                If lpRemoteBuff <> 0 Then
 
                    SendMessage(Hwnd_StatusBar, SB_GETTEXTW, LabelIndex, lpRemoteBuff)
 
                    Dim lpLocalBuf As New System.Text.StringBuilder(textLength + 1)
                    Dim Readed As IntPtr
                    Dim resRead As Integer = ReadProcessMemory(ProcessHandle, lpRemoteBuff, lpLocalBuf, cbBytes, Readed)
 
                    VirtualFreeEx(ProcessHandle, lpRemoteBuff, 0, MEM_RELEASE)
                    CloseHandle(ProcessHandle)
 
                    If resRead Then Return lpLocalBuf.ToString
                End If
            End If
        End If
 
        Return String.Empty
    End Function
 
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        MsgBox(getStatusLabelText(TextBox1.Text, NumericUpDown1.Value))
    End Sub
End Class

Imports Accessibility
 
Public Class Form1
    Structure Pointapi
        Public x As Int32
        Public y As Int32
    End Structure
 
    Public Structure RECT
        Dim Left As Integer
        Dim Top As Integer
        Dim Right As Integer
        Dim Bottom As Integer
    End Structure
 
    Declare Unicode Function AccessibleObjectFromPoint Lib "oleacc.dll" Alias "AccessibleObjectFromPoint" (ByVal ptScreen As Pointapi, ByRef ppvObject As IAccessible, ByRef pvarChild As Object) As Integer
    Public Declare Function GetWindowRect Lib "user32.DLL" (ByVal hwnd As IntPtr, ByRef lpRect As RECT) As Integer
 
    Function getStatusLabelText(Hwnd_Status As IntPtr, Offset_X As Integer, Offset_Y As Integer) As String
        Dim sRECT As RECT
        GetWindowRect(Hwnd_Status, sRECT)
 
        Dim pt As Pointapi
        pt.x = sRECT.Left + CInt(Offset_X)
        pt.y = sRECT.Top + CInt(Offset_Y)
 
        Dim obj As Object = Nothing
        Dim acc As IAccessible = Nothing
        Dim res As Integer = AccessibleObjectFromPoint(pt, acc, obj)
 
        If res = 0 Then
            Return acc.accName(obj)
        End If
 
        Return String.Empty
    End Function
 
 
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        ReturnText.Text = getStatusLabelText(HwndText.Text, offset_X.Text, offset_Y.Text)
    End Sub
End Class

Imports System.IO
Imports System.Runtime.InteropServices
 
Public Class ResManager_Win32
#Region "    WinAPIs"
    Private Declare Unicode Function LoadLibrary Lib "kernel32.DLL" Alias "LoadLibraryW" (ByVal lpLibFileName As String) As IntPtr
    Private Declare Unicode Function FindResource Lib "kernel32.DLL" Alias "FindResourceW" (ByVal hInstance As IntPtr, ByVal lpName As String, ByVal lpType As String) As IntPtr
    Private Declare Function LoadResource Lib "kernel32.DLL" (ByVal hInstance As IntPtr, ByVal hResInfo As IntPtr) As IntPtr
    Private Declare Function LockResource Lib "kernel32.DLL" (ByVal hResData As IntPtr) As IntPtr
    Private Declare Function SizeofResource Lib "kernel32.DLL" (ByVal hInstance As IntPtr, ByVal hResInfo As IntPtr) As Integer
    Private Declare Function FreeLibrary Lib "kernel32.DLL" (ByVal hLibModule As IntPtr) As IntPtr
 
    Private Declare Unicode Function BeginUpdateResource Lib "kernel32.DLL" Alias "BeginUpdateResourceW" (ByVal pFileName As String, ByVal bDeleteExistingResources As Integer) As IntPtr
    Private Declare Unicode Function UpdateResource Lib "kernel32.DLL" Alias "UpdateResourceW" (ByVal hUpdate As IntPtr, ByVal lpType As String, ByVal lpName As String, ByVal wLanguage As Integer, <System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.AsAny)> ByVal lpData As Object, ByVal cbData As Integer) As IntPtr
    Private Declare Unicode Function EndUpdateResource Lib "kernel32.DLL" Alias "EndUpdateResourceW" (ByVal hUpdate As IntPtr, ByVal fDiscard As Integer) As IntPtr
 
    Private Declare Unicode Function EnumResourceNames Lib "kernel32.dll" Alias "EnumResourceNamesW" (ByVal hModule As IntPtr, ByVal dwID As Integer, ByVal lpEnumFunc As EnumResNameProcDelegate, ByVal lParam As IntPtr) As Boolean
    Private Declare Unicode Function EnumResourceTypes Lib "kernel32.dll" Alias "EnumResourceTypesW" (ByVal hModule As IntPtr, ByVal lpEnumFunc As EnumResTypeProc, ByVal lParam As IntPtr) As Boolean
 
    Private Delegate Function EnumResNameProcDelegate(ByVal hModule As IntPtr, ByVal lpszType As IntPtr, ByVal lpszName As IntPtr, ByVal lParam As IntPtr) As Boolean
    Private Delegate Function EnumResTypeProc(hModule As IntPtr, lpszType As IntPtr, lParam As IntPtr) As Boolean
#End Region
 
#Region "    Variables"
    Public ReadOnly FileName As String
    Private ResNamesCollection As Dictionary(Of String, List(Of String))
 
    Private Enum ResourceType
        SYSTEM_CURSOR = 1
        SYSTEM_BITMAP = 2
        SYSTEM_ICON = 3
        SYSTEM_MENU = 4
        SYSTEM_DIALOG = 5
        SYSTEM_STRING = 6
        SYSTEM_FONTDIR = 7
        SYSTEM_FONT = 8
        SYSTEM_ACCELERATOR = 9
        SYSTEM_RCDATA = 10
        SYSTEM_MESSAGETABLE = 11
        SYSTEM_GROUP_CURSOR = 12
        SYSTEM_GROUP_ICON = 14
        SYSTEM_VERSION = 16
        SYSTEM_DLGINCLUDE = 17
        SYSTEM_PLUGPLAY = 19
        SYSTEM_VXD = 20
        SYSTEM_ANICURSOR = 21
        SYSTEM_ANIICON = 22
        SYSTEM_HTML = 23
        SYSTEM_MANIFEST = 24
    End Enum
#End Region
 
#Region "    Private Methods"
    Private Sub Read_Names()
        Dim hLibrary = LoadLibrary(FileName)
 
        If hLibrary <> IntPtr.Zero Then
            ResNamesCollection = New Dictionary(Of String, List(Of String))
 
            EnumResourceTypes(hLibrary,
                              Function(hModule As IntPtr, lpszType As IntPtr, lParam As IntPtr) As Boolean
                                  EnumResourceNames(hModule, lpszType, AddressOf EnumResTypesProc, IntPtr.Zero)
                                  Return True
                              End Function, IntPtr.Zero)
        End If
 
        FreeLibrary(hLibrary)
    End Sub
 
    Private Function EnumResTypesProc(hModule As IntPtr, lpszType As IntPtr, ByVal lpszName As IntPtr, ByVal lParam As IntPtr) As Boolean
        Dim TypeName As String
        Dim ResName As String
 
        'Convert Resource Type Name
        Select Case True
            Case [Enum].GetValues(GetType(ResourceType)).Cast(Of Integer).Contains(lpszType.ToInt32())
                TypeName = [Enum].GetName(GetType(ResourceType), lpszType.ToInt32())
 
            Case lpszType.ToInt32() > &HFFFF
                TypeName = Marshal.PtrToStringUni(lpszType)
 
            Case Else
                TypeName = lpszType.ToInt32().ToString()
        End Select
 
        If TypeName.Trim <> String.Empty Then
            If Not ResNamesCollection.ContainsKey(TypeName) Then
                ResNamesCollection.Add(TypeName, New List(Of String))
            End If
        End If
 
        'Convert Resource Item Name
        Select Case True
            Case lpszName.ToInt32() > &HFFFF
                ResName = Marshal.PtrToStringUni(lpszName)
            Case Else
                ResName = lpszName.ToInt32().ToString()
        End Select
 
        If ResName.Trim <> String.Empty Then
            ResNamesCollection.Item(TypeName).Add(ResName)
        End If
 
        Return True
    End Function
#End Region
 
#Region "    Class Constructor"
    Sub New(FileName As String)
        If Not IO.File.Exists(FileName) Then
            Throw New FileNotFoundException("File not found:" & vbNewLine & FileName)
        End If
 
        Me.FileName = FileName
        Read_Names()
    End Sub
#End Region
 
#Region "    Public Functions"
    Public Function GetAllResourceTypes() As String()
        Return ResNamesCollection.Keys.ToArray
    End Function
 
    Public Function GetUserResourceTypes() As String()
        Return ResNamesCollection.Keys.Where(Function(x) Not x.StartsWith("SYSTEM_")).ToArray
    End Function
 
    Public Function GetUserResourceNames(ResType As String) As String()
        If Not ResNamesCollection.ContainsKey(ResType) Then
            Throw New Exception($"Resource type '{ResType}' does not exist.")
        End If
 
        Return ResNamesCollection.Item(ResType).ToArray
    End Function
 
    Public Function GetUserResource_Image(ResType As String, ResName As String) As Bitmap
        Dim b = GetUserResource_Bytes(ResType, ResName)
        If Not b Is Nothing Then
            Using M = New MemoryStream(b)
                Return New Bitmap(M)
            End Using
        End If
 
        Return Nothing
    End Function
 
    Public Function GetUserResource_Bytes(ResType As String, ResName As String) As Byte()
        If Not ResNamesCollection.ContainsKey(ResType) Then
            Throw New Exception($"Resource type '{ResType}' does not exist.")
        End If
 
        If Not ResNamesCollection.Item(ResType).Contains(ResName) Then
            Throw New Exception($"Resource name '{ResName}' does not exist.")
        End If
 
        Dim hLibrary = LoadLibrary(FileName)
        Dim hRes = FindResource(hLibrary, ResName, ResType)
        Dim hResLoad = LoadResource(hLibrary, hRes)
        Dim hResLock = LockResource(hResLoad)
        Dim intResSize = SizeofResource(hLibrary, hRes)
 
        Dim isSuccessfull As Boolean = (hLibrary <> IntPtr.Zero And hRes <> IntPtr.Zero And hResLoad <> IntPtr.Zero And hResLock <> IntPtr.Zero And intResSize <> 0)
 
        If Not isSuccessfull Then
            FreeLibrary(hLibrary)
            Return Nothing
        End If
 
        Dim ResBuffer(intResSize - 1) As Byte
        Marshal.Copy(hResLock, ResBuffer, 0, ResBuffer.Length)
 
        FreeLibrary(hLibrary)
        Return ResBuffer
    End Function
 
    Public Function SaveUserResource_Bytes(ByteArray() As Byte, ResType As String, ResName As String) As Boolean
        Dim hUpdate = BeginUpdateResource(FileName, False)
        Dim RetUpdate = UpdateResource(hUpdate, ResType, ResName, 0, ByteArray, ByteArray.Length)
        Dim EndRetUpdate = EndUpdateResource(hUpdate, False)
 
        If EndRetUpdate = IntPtr.Zero Then
            Throw New IOException("Can not write to the file, access denied:" & vbNewLine & FileName)
        End If
 
        Dim isSuccessfull As Boolean = (hUpdate <> IntPtr.Zero And RetUpdate <> IntPtr.Zero And EndRetUpdate <> IntPtr.Zero)
 
        'Update names collection
        If isSuccessfull Then Read_Names()
 
        Return isSuccessfull
    End Function
#End Region
End Class

Public NotInheritable Class NaturalStringComparer
    Implements IComparer(Of String)
 
    Public Shared ReadOnly Property Instance As NaturalStringComparer = New NaturalStringComparer()
 
    Private Sub New()
    End Sub
 
    Public Function Compare(x As String, y As String) As Integer Implements IComparer(Of String).Compare
 
        If x Is Nothing OrElse y Is Nothing Then
            Return 0
        End If
 
        Dim len1 As Integer = x.Length
        Dim len2 As Integer = y.Length
        Dim marker1 As Integer = 0
        Dim marker2 As Integer = 0
 
        Do While marker1 < len1 AndAlso marker2 < len2
 
            Dim isDigit1 As Boolean = Char.IsDigit(x(marker1))
            Dim isDigit2 As Boolean = Char.IsDigit(y(marker2))
 
            Dim loc1 As Integer = 0
            Dim loc2 As Integer = 0
 
            ' Find next block of numbers or non-numbers inside each string
            Do
                loc1 += 1
                marker1 += 1
            Loop While (marker1 < len1 AndAlso Char.IsDigit(x(marker1)) = isDigit1)
 
            Do
                loc2 += 1
                marker2 += 1
            Loop While (marker2 < len2 AndAlso Char.IsDigit(y(marker2)) = isDigit2)
 
            Dim result As Integer
 
            If isDigit1 AndAlso isDigit2 Then
                Dim thisNumericChunk As Long = ToLong(x, marker1 - loc1, loc1)
                Dim thatNumericChunk As Long = ToLong(y, marker2 - loc2, loc2)
                result = thisNumericChunk.CompareTo(thatNumericChunk)
            Else
                result = String.Compare(x, marker1 - loc1, y, marker2 - loc2, Math.Min(loc1, loc2))
            End If
 
            If result <> 0 Then
                Return result
            End If
 
        Loop
 
        Return len1 - len2
 
    End Function
 
    Private Shared Function ToLong(s As String, index As Integer, len As Integer) As Long
 
        Dim result As Long = 0
        Dim pow10 As Long = 1
 
        Do While len > 1
            len -= 1
            result += pow10 * (Asc(s(index + len)) - 48)
            pow10 *= 10
        Loop
        result += pow10 * (Asc(s(index)) - 48)
 
        Return result
 
    End Function
 
End Class

Public NotInheritable Class NaturalStringComparer
    Implements IComparer(Of String)
 
    Public Shared ReadOnly Property Instance As NaturalStringComparer = New NaturalStringComparer()
 
    Private Sub New()
    End Sub
 
    Public Function Compare(x As String, y As String) As Integer Implements IComparer(Of String).Compare
 
        If x Is Nothing OrElse y Is Nothing Then
            Return 0
        End If
 
        Dim len1 As Integer = x.Length
        Dim len2 As Integer = y.Length
        Dim marker1 As Integer = 0
        Dim marker2 As Integer = 0
 
        Do While marker1 < len1 AndAlso marker2 < len2
 
            Dim isDigit1 As Boolean = Char.IsDigit(x(marker1))
            Dim isDigit2 As Boolean = Char.IsDigit(y(marker2))
 
            Dim loc1 As Integer = 0
            Dim loc2 As Integer = 0
 
            ' Find next block of numbers or non-numbers inside each string
            Do
                loc1 += 1
                marker1 += 1
            Loop While (marker1 < len1 AndAlso Char.IsDigit(x(marker1)) = isDigit1)
 
            Do
                loc2 += 1
                marker2 += 1
            Loop While (marker2 < len2 AndAlso Char.IsDigit(y(marker2)) = isDigit2)
 
            Dim result As Integer
 
            If isDigit1 AndAlso isDigit2 Then
                Dim thisNumericChunk As Long = Long.Parse(x.AsSpan(marker1 - loc1, loc1))
                Dim thatNumericChunk As Long = Long.Parse(y.AsSpan(marker2 - loc2, loc2))
                result = thisNumericChunk.CompareTo(thatNumericChunk)
            Else
                result = String.Compare(x, marker1 - loc1, y, marker2 - loc2, Math.Max(loc1, loc2))
            End If
 
            If result <> 0 Then
                Return result
            End If
 
        Loop
 
        Return len1 - len2
 
    End Function
 
End Class