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

My.Computer.Audio.Play(My.Application.Info.DirectoryPath & "/1.wav")

Using sp As New Media.SoundPlayer(My.Resources.ResourceManager.GetStream("_1"))
    sp.Play()
End Using

Imports System.Security.Cryptography
Imports System.Text
 
Public Class Form1
    Public Function SHA_X(ByRef TEXT As String) As String
        Dim SHA As New Security.Cryptography.SHA1CryptoServiceProvider
        'Dim SHA As New Security.Cryptography.SHA512CryptoServiceProvider
        'Dim SHA As New Security.Cryptography.SHA256CryptoServiceProvider
        'Dim SHA As New Security.Cryptography.SHA384CryptoServiceProvider
 
        Dim ByteString() As Byte = System.Text.Encoding.ASCII.GetBytes(TEXT)
        ByteString = SHA.ComputeHash(ByteString)
 
        Dim FinalString As String = Nothing
        For Each bt As Byte In ByteString
            FinalString &= bt.ToString("x2")
        Next
        Return FinalString
    End Function
 
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        TextBox2.Text = SHA_X(TextBox1.Text)
    End Sub
End Class

Dim Word As Object
 
Word = CreateObject("Word.Application")
        Word.Documents.Open("D:\\VB.docx") 'открываем документ, путь к файлу меняем на свой
        Word.Visible = True
 
        Word.Selection.Find.ClearFormatting()
        Word.Selection.Find.Replacement.ClearFormatting()
        With Word.Selection.Find
            .Text = "Слово которое нужно заменить"
            .Replacement.Text = "Слово НА которое необходимо заменить"
            .Forward = True
            .Wrap = 1
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Word.Selection.Find.Execute(Replace:=2)

Imports System
Imports System.IO
Imports System.Runtime.InteropServices
 
Public Class Form1
    Dim WM_SYSCOMMAND As Int32 = 274
    Dim SC_CLOSE As UInt32 = 61536
    <DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
    Private Shared Function PostMessage(ByVal hWnd As IntPtr, ByVal Msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Boolean
    End Function
 
    <DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
    Private Shared Function FindWindow( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As IntPtr
    End Function
 
 Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
 
Private Sub TextBox1_Click(sender As Object, e As EventArgs) Handles TextBox1.Click
        Process.Start("C:\Program Files\Common Files\microsoft shared\ink\tabtip.exe")
        System.Windows.Forms.InputLanguage.CurrentInputLanguage = InputLanguage.FromCulture(System.Globalization.CultureInfo.GetCultureInfo(1049)) ' Меняем раскладку на русский язык
    End Sub
 
Private Sub Form1_Click(sender As Object, e As MouseEventArgs) Handles Me.Click
        CloseTabTip()
    End Sub
 
 Private Sub CloseTabTip()
        Dim TouchhWnd As New IntPtr(0)
        Dim hWnd As New IntPtr(0)
        TouchhWnd = FindWindow("IPTip_Main_Window", Nothing)
        PostMessage(TouchhWnd, WM_SYSCOMMAND, SC_CLOSE, 0)
    End Sub

Imports System.ComponentModel
Imports System.Security.Principal
Imports System.Runtime.InteropServices
 
Namespace LogonSessions
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    Friend Const STATUS_SUCCESS As Int32 = &H0
 
    <DllImport("advapi32.dll")> _
    Friend Shared Function LsaNtStatusToWinError( _
      ByVal Status As Int32) As UInt32
    End Function
 
    <DllImport("secur32.dll")> _
    Friend Shared Function LsaEnumerateLogonSessions( _
      ByRef LogonSessionCount As UInt32, ByRef LogonSessionList As IntPtr) As Int32
    End Function
 
    <DllImport("secur32.dll")> _
    Friend Shared Function LsaFreeReturnBuffer( _
      ByVal Buffer As IntPtr) As Int32
    End Function
 
    <DllImport("secur32.dll")> _
    Friend Shared Function LsaGetLogonSessionData( _
      ByVal LogonId As IntPtr, ByRef ppLogonSessionData As IntPtr) As Int32
    End Function
 
    <StructLayout(LayoutKind.Sequential, CharSet := CharSet.Unicode)> _
    Friend Structure LUID
      Friend LowPart As UInt32
      Friend HighPart As UInt32
    End Structure
 
    <StructLayout(LayoutKind.Sequential, CharSet := CharSet.Unicode)> _
    Friend Structure LSA_UNICODE_STRING
      Friend Length As UInt16
      Friend MaximumLength As UInt16
      <MarshalAs(UnmanagedType.LPWStr)> _
      Friend Buffer As [String]
    End Structure
 
    Friend Enum SECURITY_LOGON_TYPE As UInteger
      Interactive = 2
      Network
      Batch
      Service
      Proxy
      [Unlock]
      NetworkCleartext
      NewCredentials
      RemoteInteractive
      CachedInteractive
      CachedRemoteInteractive
      CachedUnlock
    End Enum
 
    <StructLayout(LayoutKind.Sequential, CharSet := CharSet.Unicode)> _
    Friend Structure SECURITY_LOGON_SESSION_DATA
      Friend Size As UInt32
      Friend LogonId As LUID
      Friend UserName As LSA_UNICODE_STRING
      Friend LogonDomain As LSA_UNICODE_STRING
      Friend AuthenticationPackage As LSA_UNICODE_STRING
      Friend LogonType As SECURITY_LOGON_TYPE
      Friend Session As UInt32
      Friend Sid As IntPtr
      Friend LogonTime As Int64
      Friend LogonServer As LSA_UNICODE_STRING
      Friend DnsDomainName As LSA_UNICODE_STRING
      Friend Upn As LSA_UNICODE_STRING
    End Structure
  End Class
  
  Friend NotInheritable Class Program
    Private Shared Sub PrintLsaError(ByVal nts As Int32)
      Console.WriteLine(New Win32Exception( _
        CType(NativeMethods.LsaNtStatusToWinError(nts), Int32)) _
     .Message)
    End Sub
 
    Private Shared Function PtrToStruct(Of T)(ByVal p As IntPtr) As T
      Return DirectCast(Marshal.PtrToStructure(p, GetType(T)), T)
    End Function
 
    Shared Sub Main()
      Dim nts As Int32, len As Int32
      Dim cnt As UInt32
      Dim lsl As IntPtr, itr As IntPtr
 
      If (InlineAssignHelper(nts, _
      NativeMethods.LsaEnumerateLogonSessions(cnt, lsl))) <> NativeMethods.STATUS_SUCCESS Then
        PrintLsaError(nts)
        Return
      End If
 
      len = Marshal.SizeOf(GetType(NativeMethods.LUID))
      itr = lsl
      For i As Int32 = 0 To cnt - 1
        Dim lsd As IntPtr = IntPtr.Zero
        If (InlineAssignHelper(nts, _
        NativeMethods.LsaGetLogonSessionData(itr, lsd))) <> NativeMethods.STATUS_SUCCESS Then
          PrintLsaError(nts)
          Exit For
        End If
 
        Dim slsd As NativeMethods.SECURITY_LOGON_SESSION_DATA = _
          PtrToStruct(Of NativeMethods.SECURITY_LOGON_SESSION_DATA)(lsd)
        Console.WriteLine("Logon type   : {0}", slsd.LogonType)
        Console.WriteLine("User name    : {0}\{1}", slsd.LogonDomain.Buffer, slsd.UserName.Buffer)
        Console.WriteLine("Auth package : {0}", slsd.AuthenticationPackage.Buffer)
        Console.WriteLine("Session      : {0}", slsd.Session)
        Console.WriteLine("Sid          : {0}", If(slsd.Sid <> IntPtr.Zero, _
          New SecurityIdentifier(slsd.Sid).ToString(), [String].Empty))
        Console.WriteLine("Logon time   : {0}" & vbLf, DateTime.FromFileTime(slsd.LogonTime))
        itr = CType(itr.ToInt32() + len, IntPtr)
 
        If (InlineAssignHelper(nts, _
        NativeMethods.LsaFreeReturnBuffer(lsd))) <> NativeMethods.STATUS_SUCCESS Then
          PrintLsaError(nts)
        End If
      Next
 
      If (InlineAssignHelper(nts, _
      NativeMethods.LsaFreeReturnBuffer(lsl))) <> NativeMethods.STATUS_SUCCESS Then
        PrintLsaError(nts)
      End If
    End Sub
    
    Private Shared Function InlineAssignHelper(Of T)(ByRef target As T, ByVal value As T) As T
      target = value
      Return value
    End Function
  End Class
End Namespace

    Sub FormFade(Form As Form, isFadeOut As Boolean)
        Try
            Dim mx As Integer = IIf(isFadeOut, 0, 1)
            If mx = 1 Then Form.Opacity = 0
            Form.Show()
 
            Do While Form.Opacity <> mx
                Application.DoEvents()
                If isFadeOut Then Form.Opacity -= 0.05 Else Form.Opacity += 0.05
                Threading.Thread.Sleep(50)
            Loop
 
        Catch
        End Try
    End Sub

FormFade(Me, False) 'Мягкое появление формы
FormFade(Me, True) 'Мягкое закрытие формы

Imports System.Text
Imports System.Runtime.InteropServices
 
Namespace MsiPackages
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    <DllImport("msi.dll", CharSet := CharSet.Unicode, SetLastError := True)> _
    Friend Shared Function MsiEnumProducts( _
        ByVal iProductIndex As Int32, _
        ByVal lpProductBuf As StringBuilder _
    ) As Int32
    End Function
    
    <DllImport("msi.dll", CharSet := CharSet.Unicode, SetLastError := True)> _
    Friend Shared Function MsiGetProductInfo( _
        ByVal szProduct As String, _
        ByVal szProperty As String, _
        <Out> ByVal lpValueBuf As StringBuilder, _
        ByRef pcchValueBuf As Int32 _
    ) As Int32
    End Function
  End Class
  
  Friend NotInheritable Class Program
    Private Const INSTALLPROPERTY_PRODUCTNAME As String = "ProductName"
    Private Const ERROR_SUCCESS               As Int32  = &H0
    Private Const ERROR_NO_MORE_ITEMS         As Int32  = &H103
    
    Private Shared Function InlineAssignHelper(Of T) ( _
        ByRef Target As T, _
        ByVal Value As T _
    ) As T
      Target = Value
      Return Value
    End Function
    
    <STAThread()> _
    Shared Sub Main(ByVal args As String())
      Dim guid As New StringBuilder(39)
      Dim erno As Int32 = ERROR_SUCCESS
      
      Dim i As Int32 = 0
      While erno <> ERROR_NO_MORE_ITEMS
        If (InlineAssignHelper( _
          erno, _
          NativeMethods.MsiEnumProducts(i, guid) _
        )) = ERROR_SUCCESS Then
          Dim [len] As Int32 = &H200
          Dim name As New StringBuilder([len])
          
          If (InlineAssignHelper( _
            erno, _
            NativeMethods.MsiGetProductInfo( _
              guid.ToString(), _
              INSTALLPROPERTY_PRODUCTNAME, _
              name, [len] _
            ) _
          )) = ERROR_SUCCESS Then
            Console.WriteLine("[*] {0}", name.ToString())
          Else
            Console.WriteLine("[!] could not get product name.")
          End If
        End If
        i += 1
      End While
    End Sub
  End Class
End Namespace

Imports System.Linq
Imports System.Text
Imports System.Reflection
Imports System.ComponentModel
Imports System.Runtime.InteropServices
Imports System.Text.RegularExpressions
Imports System.Diagnostics.CodeAnalysis
 
Friend NotInheritable Class Program
  Private Const ProcessBasicInformation As UInt32   = &H0
  Private Const PROCESS_QUERY_INFORMATION As UInt32 = &H400
  Private Const PROCESS_VM_READ As UInt32           = &H10
  Private Const STATUS_SUCCESS As Int32             = &H0
  
  Private Shared m_CloseHandle As _CloseHandle
  Private Shared m_OpenProcess As _OpenProcess
  Private Shared m_ReadProcessMemory As _ReadProcessMemory
  Private Shared m_NtQueryInformationProcess As _NtQueryInformationProcess
  Private Shared m_RtlNtStatusToDosError As _RtlNtStatusToDosError
  
  Private Shared Property CloseHandle As _CloseHandle
    Get
      Return m_CloseHandle
    End Get
    Set
      m_CloseHandle = Value
    End Set
  End Property
  
  Private Shared Property OpenProcess As _OpenProcess
    Get
      Return m_OpenProcess
    End Get
    Set
      m_OpenProcess = Value
    End Set
  End Property
  
  Private Shared Property ReadProcessMemory As _ReadProcessMemory
    Get
      Return m_ReadProcessMemory
    End Get
    Set
      m_ReadProcessMemory = Value
    End Set
  End Property
  
  Private Shared Property NtQueryInformationProcess As _NtQueryInformationProcess
    Get
      Return m_NtQueryInformationProcess
    End Get
    Set
      m_NtQueryInformationProcess = Value
    End Set
  End Property
  
  Private Shared Property RtlNtStatusToDosError As _RtlNtStatusToDosError
    Get
      Return m_RtlNtStatusToDosError
    End Get
    Set
      m_RtlNtStatusToDosError = Value
    End Set
  End Property
  
  Private Shared Function GetProc(Of T As Class)(ByVal dll As String, ByVal fun As String) As T
    Dim meths = GetType(Regex).Assembly.GetType( _
      "Microsoft.Win32.UnsafeNativeMethods" _
    ).GetMethods(BindingFlags.Public Or BindingFlags.Static).Where( _
      Function(m) New Regex("\AGet(ProcA|ModuleH)").IsMatch(m.Name) _
    ).ToArray
    Dim ptr As IntPtr = CType(meths(1).Invoke(Nothing, New Object() { _
      New HandleRef( _
        New IntPtr(), CType(meths(0).Invoke(Nothing, New Object() {dll}), IntPtr) _
    ), fun}), IntPtr)
    
    Return TryCast(Marshal.GetDelegateForFunctionPointer(ptr, GetType(T)), T)
  End Function
  
  Private Shared Function BytesToStruc(Of T As Structure)(ByVal bytes As Byte()) As T
    Dim gch As GCHandle = GCHandle.Alloc(bytes, GCHandleType.Pinned)
    Dim struc As T = DirectCast(Marshal.PtrToStructure( _
      gch.AddrOfPinnedObject(), GetType(T) _
    ), T)
    gch.Free()
    
    Return struc
  End Function
  
  <UnmanagedFunctionPointer(CallingConvention.Winapi)> _
  Private Delegate Function _CloseHandle( _
      ByVal hObject As IntPtr _
  ) As Boolean
  
  <UnmanagedFunctionPointer(CallingConvention.Winapi)> _
  Private Delegate Function _OpenProcess( _
      ByVal dwDesiredAccess As UInt32, _
      ByVal bInheritHandle As Boolean, _
      ByVal dwProcessId As Int32 _
  ) As IntPtr
  
  <UnmanagedFunctionPointer(CallingConvention.Winapi)> _
  Private Delegate Function _ReadProcessMemory( _
      ByVal hProcess As IntPtr, _
      ByVal lpBaseAddress As IntPtr, _
      ByVal lpBuffer As Byte(), _
      ByVal nSize As Int32, _
      ByRef lpNumberOfBytesRead As IntPtr _
  ) As Boolean
  
  <UnmanagedFunctionPointer(CallingConvention.Winapi)> _
  Private Delegate Function _NtQueryInformationProcess( _
      ByVal ProcessHandle As IntPtr, _
      ByVal ProcessInformationClass As UInt32, _
      ByRef ProcessInformation As PROCESS_BASIC_INFORMATION, _
      ByVal ProcessInformationLength As UInt32, _
      ByVal ReturnLength As IntPtr _
  ) As Int32
  
  <UnmanagedFunctionPointer(CallingConvention.Winapi)> _
  Private Delegate Function _RtlNtStatusToDosError( _
      ByVal Status As Int32 _
  ) As Int32
  
  <StructLayout(LayoutKind.Sequential)> _
  Private Structure PROCESS_BASIC_INFORMATION
    Friend ExitStatus As Int32
    Friend PebBaseAddress As IntPtr
    Friend AffinityMask As IntPtr
    Friend BasePriority As Int32
    Friend UniqueProcessId As IntPtr
    Friend InheritedFromUniqueProcessId As IntPtr
    
    <SuppressMessage("Microsoft.Performance", "CA1822:MarkMembersAsStatic")> _
    Friend ReadOnly Property Size As UInt32
      Get
        Return CType(Marshal.SizeOf(GetType(PROCESS_BASIC_INFORMATION)), UInt32)
      End Get
    End Property
  End Structure
  
  <StructLayout(LayoutKind.Sequential)> _
  Private Structure UNICODE_STRING
    Friend Length As UInt16
    Friend MaximumLength As UInt16
    Friend Buffer As IntPtr
  End Structure
  
  Private Shared Function LocateSignatures() As Boolean
    Try
      CloseHandle = GetProc(Of _CloseHandle)("kernel32.dll", "CloseHandle")
      OpenProcess = GetProc(Of _OpenProcess)("kernel32.dll", "OpenProcess")
      ReadProcessMemory = GetProc(Of _ReadProcessMemory)( _
          "kernel32.dll", "ReadProcessMemory" _
      )
      NtQueryInformationProcess = GetProc(Of _NtQueryInformationProcess)( _
          "ntdll.dll", "NtQueryInformationProcess" _
      )
      RtlNtStatusToDosError = GetProc(Of _RtlNtStatusToDosError)( _
          "ntdll.dll", "RtlNtStatusToDosError" _
      )
    Catch e As ArgumentNullException
      Return False
    End Try
    
    Return True
  End Function
  
  Private Shared Sub PrintErrMessage(ByVal nts As Int32)
    Console.WriteLine( _
      New Win32Exception( _
        If(nts <> 0, RtlNtStatusToDosError(nts), Marshal.GetLastWin32Error()) _
      ).Message _
    )
  End Sub
  
  Private Shared Function InlineHelper(Of T)(ByRef target As T, value As T) As T
    target = Value
    Return Value
  End Function
  
  Shared Sub Main(ByVal args As String())
    If Not LocateSignatures() Then
      Console.WriteLine(New Win32Exception(&H7E).Message)
      Return
    End If
    
    If args.Length <> 1 Then
      Console.WriteLine("Usage: {0} [PID]", GetType(Program).Assembly.GetName().Name)
      Return
    End If
    
    Dim pid As Int32, nts As Int32
    Dim proc As IntPtr, ret As IntPtr
    If Not Int32.TryParse(args(0), pid) Then
      Console.WriteLine("PID should be present like a number.")
      Return
    End If
    
    If (InlineHelper(proc, OpenProcess( _
      PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, False, pid _
    ))) = IntPtr.Zero Then
      PrintErrMessage(0)
      Return
    End If
    
    Dim pbi As New PROCESS_BASIC_INFORMATION
    If (InlineHelper(nts, NtQueryInformationProcess( _
      proc, ProcessBasicInformation, pbi, pbi.Size, IntPtr.Zero _
    ))) = STATUS_SUCCESS Then
      'указатель на структуру RTL_USER_PROCESS_PARAMETERS
      Dim rupp As Byte() = New Byte(IntPtr.Size - 1) {}
      If ReadProcessMemory( _
        proc, CType(pbi.PebBaseAddress.ToInt32 + &H10, IntPtr), rupp, IntPtr.Size, ret _
      ) Then
        'получаем указатель поля CommandLine структуры RTL_USER_PROCESS_PARAMETERS
        Dim ptr As IntPtr = CType(BitConverter.ToInt32(rupp, 0) + &H40, IntPtr)
        Dim sz  As Int32 = Marshal.SizeOf(GetType(UNICODE_STRING))
        Dim clf As Byte() = New Byte(sz - 1) {}
        
        If ReadProcessMemory(proc, ptr, clf, sz, ret) Then
          'извлекаем данные из указателя Buffer структуры UNICODE_STRING
          Dim cls As UNICODE_STRING = BytesToStruc(Of UNICODE_STRING)(clf)
          Dim cmd As Byte() = New Byte(cls.Length - 1) {}
          
          If ReadProcessMemory(proc, cls.Buffer, cmd, cls.Length, ret) Then
            'собственно, командная строка процесса
            Console.WriteLine(Encoding.Unicode.GetString(cmd))
          Else
            PrintErrMessage(0)
          End If
        Else
          PrintErrMessage(0)
        End If
      Else
        PrintErrMessage(0)
      End If
    Else
      PrintErrMessage(nts)
    End If
    
    If Not CloseHandle(proc) Then
      PrintErrMessage(0)
    End If
  End Sub
End Class

Imports Microsoft.Win32
Public Class Form1
 
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        Dim regKey As RegistryKey
        regKey = Registry.LocalMachine.OpenSubKey("SOFTWARE", True)
        regKey.CreateSubKey("MyApp")
        regKey.Close()
        MsgBox("Раздел в HKEY_LOCAL_MACHINE\Software\MyApp Создан.")
    End Sub
 
    Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
        Dim regKey As RegistryKey
        Dim ver As Decimal
        regKey = Registry.LocalMachine.OpenSubKey("Software\MyApp", True)
        regKey.SetValue("AppName", "MyRegApp")
        ver = regKey.GetValue("Version", 0.0)
        If ver < 1.1 Then
            regKey.SetValue("Version", 1.1)
        End If
        regKey.Close()
        MsgBox("Добовляем пораметры AppName и MyRegAppи присваеваем им значения")
    End Sub
 
    Private Sub Button3_Click(sender As Object, e As EventArgs) Handles Button3.Click
        Dim regKey As RegistryKey
        regKey = Registry.LocalMachine.OpenSubKey("Software", True)
        regKey.DeleteSubKey("MyApp", True)
        regKey.Close()
        MsgBox("Удаляем раздел MyApp")
    End Sub
 
End Class

Module Run
    Sub Main()
        Dim sDirName As String = "C:\programm\REGISTER\REGISTER\bin\Debug\REGISTER.exe"
            Process.Start(New ProcessStartInfo() With {.FileName = sDirName, .Verb = "runas"})
    End Sub
End Module

Imports Microsoft.Win32.SafeHandles
Imports System
Imports System.Runtime.InteropServices
Imports System.Text
 
Public Class CheckSSD
    Public DiskType, Diskindex, DiskName, DeviceID As String
    Private Const GENERIC_READ As UInteger = &H80000000L
    Private Const GENERIC_WRITE As UInteger = &H40000000
    Private Const FILE_SHARE_READ As UInteger = &H1
    Private Const FILE_SHARE_WRITE As UInteger = &H2
    Private Const OPEN_EXISTING As UInteger = 3
    Private Const FILE_ATTRIBUTE_NORMAL As UInteger = &H80
 
    ' CreateFile to get handle to drive
    <DllImport("kernel32.dll", SetLastError:=True)> _
    Private Shared Function CreateFileW(<MarshalAs(UnmanagedType.LPWStr)> ByVal lpFileName As String, ByVal dwDesiredAccess As UInteger, ByVal dwShareMode As UInteger, ByVal lpSecurityAttributes As IntPtr, ByVal dwCreationDisposition As UInteger, ByVal dwFlagsAndAttributes As UInteger, ByVal hTemplateFile As IntPtr) As SafeFileHandle
    End Function
 
    ' For control codes
    Private Const FILE_DEVICE_MASS_STORAGE As UInteger = &H2D
    Private Const IOCTL_STORAGE_BASE As UInteger = FILE_DEVICE_MASS_STORAGE
    Private Const FILE_DEVICE_CONTROLLER As UInteger = &H4
    Private Const IOCTL_SCSI_BASE As UInteger = FILE_DEVICE_CONTROLLER
    Private Const METHOD_BUFFERED As UInteger = 0
    Private Const FILE_ANY_ACCESS As UInteger = 0
    Private Const FILE_READ_ACCESS As UInteger = &H1
    Private Const FILE_WRITE_ACCESS As UInteger = &H2
 
    Private Shared Function CTL_CODE(ByVal DeviceType As UInteger, ByVal [Function] As UInteger, ByVal Method As UInteger, ByVal Access As UInteger) As UInteger
        Return ((DeviceType << 16) Or (Access << 14) Or ([Function] << 2) Or Method)
    End Function
 
    ' For DeviceIoControl to check no seek penalty
    Private Const StorageDeviceSeekPenaltyProperty As UInteger = 7
    Private Const PropertyStandardQuery As UInteger = 0
 
    <StructLayout(LayoutKind.Sequential)> _
    Private Structure STORAGE_PROPERTY_QUERY
        Public PropertyId As UInteger
        Public QueryType As UInteger
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=1)> _
        Public AdditionalParameters() As Byte
    End Structure
 
    <StructLayout(LayoutKind.Sequential)> _
    Private Structure DEVICE_SEEK_PENALTY_DESCRIPTOR
        Public Version As UInteger
        Public Size As UInteger
        <MarshalAs(UnmanagedType.U1)> _
        Public IncursSeekPenalty As Boolean
    End Structure
 
    ' DeviceIoControl to check no seek penalty
    <DllImport("kernel32.dll", EntryPoint:="DeviceIoControl", SetLastError:=True)> _
    Private Shared Function DeviceIoControl(ByVal hDevice As SafeFileHandle, ByVal dwIoControlCode As UInteger, ByRef lpInBuffer As STORAGE_PROPERTY_QUERY, ByVal nInBufferSize As UInteger, ByRef lpOutBuffer As DEVICE_SEEK_PENALTY_DESCRIPTOR, ByVal nOutBufferSize As UInteger, ByRef lpBytesReturned As UInteger, ByVal lpOverlapped As IntPtr) As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function
 
    ' For DeviceIoControl to check nominal media rotation rate
    Private Const ATA_FLAGS_DATA_IN As UInteger = &H2
 
    <StructLayout(LayoutKind.Sequential)> _
    Private Structure ATA_PASS_THROUGH_EX
        Public Length As UShort
        Public AtaFlags As UShort
        Public PathId As Byte
        Public TargetId As Byte
        Public Lun As Byte
        Public ReservedAsUchar As Byte
        Public DataTransferLength As UInteger
        Public TimeOutValue As UInteger
        Public ReservedAsUlong As UInteger
        Public DataBufferOffset As IntPtr
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=8)> _
        Public PreviousTaskFile() As Byte
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=8)> _
        Public CurrentTaskFile() As Byte
    End Structure
 
    <StructLayout(LayoutKind.Sequential)> _
    Private Structure ATAIdentifyDeviceQuery
        Public header As ATA_PASS_THROUGH_EX
        <MarshalAs(UnmanagedType.ByValArray, SizeConst:=256)> _
        Public data() As UShort
    End Structure
 
    ' DeviceIoControl to check nominal media rotation rate
    <DllImport("kernel32.dll", EntryPoint:="DeviceIoControl", SetLastError:=True)> _
    Private Shared Function DeviceIoControl(ByVal hDevice As SafeFileHandle, ByVal dwIoControlCode As UInteger, ByRef lpInBuffer As ATAIdentifyDeviceQuery, ByVal nInBufferSize As UInteger, ByRef lpOutBuffer As ATAIdentifyDeviceQuery, ByVal nOutBufferSize As UInteger, ByRef lpBytesReturned As UInteger, ByVal lpOverlapped As IntPtr) As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function
 
    ' For error message
    Private Const FORMAT_MESSAGE_FROM_SYSTEM As UInteger = &H1000
 
    <DllImport("kernel32.dll", SetLastError:=True)> _
    Shared Function FormatMessage(ByVal dwFlags As UInteger, ByVal lpSource As IntPtr, ByVal dwMessageId As UInteger, ByVal dwLanguageId As UInteger, ByVal lpBuffer As StringBuilder, ByVal nSize As UInteger, ByVal Arguments As IntPtr) As UInteger
    End Function
 
    ' Method for no seek penalty
    Private Sub HasNoSeekPenalty(ByVal sDrive As String)
        Dim hDrive As SafeFileHandle = CreateFileW(sDrive, 0, FILE_SHARE_READ Or FILE_SHARE_WRITE, IntPtr.Zero, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, IntPtr.Zero) ' No access to drive
 
        If hDrive Is Nothing OrElse hDrive.IsInvalid Then
            Dim message As String = GetErrorMessage(Marshal.GetLastWin32Error())
            MsgBox("Создание файла невозможно. " & message)
        End If
 
        Dim IOCTL_STORAGE_QUERY_PROPERTY As UInteger = CTL_CODE(IOCTL_STORAGE_BASE, &H500, METHOD_BUFFERED, FILE_ANY_ACCESS) ' From winioctl.h
 
        Dim query_seek_penalty As New STORAGE_PROPERTY_QUERY()
        query_seek_penalty.PropertyId = StorageDeviceSeekPenaltyProperty
        query_seek_penalty.QueryType = PropertyStandardQuery
 
        Dim query_seek_penalty_desc As New DEVICE_SEEK_PENALTY_DESCRIPTOR()
 
        Dim returned_query_seek_penalty_size As UInteger
 
        Dim query_seek_penalty_result As Boolean = DeviceIoControl(hDrive, IOCTL_STORAGE_QUERY_PROPERTY, query_seek_penalty, CUInt(Marshal.SizeOf(query_seek_penalty)), query_seek_penalty_desc, CUInt(Marshal.SizeOf(query_seek_penalty_desc)), returned_query_seek_penalty_size, IntPtr.Zero)
 
        hDrive.Close()
 
        If query_seek_penalty_result = False Then
            Dim message As String = GetErrorMessage(Marshal.GetLastWin32Error())
            MsgBox("DeviceIoControl failed. " & message)
        Else
            If query_seek_penalty_desc.IncursSeekPenalty = False Then
                MsgBox("This drive has NO SEEK penalty.")
            Else
                MsgBox("This drive has SEEK penalty.")
            End If
        End If
    End Sub
 
    'Method for nominal media rotation rate
    'Необходимы административные права
    Public Shared Function HasNominalMediaRotationRate(ByVal sDrive As String) As String
        HasNominalMediaRotationRate = ""
        Dim hDrive As SafeFileHandle = CreateFileW(sDrive, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, IntPtr.Zero, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, IntPtr.Zero) 'Необходимы административные права
 
        If hDrive Is Nothing OrElse hDrive.IsInvalid Then
            Dim message As String = GetErrorMessage(Marshal.GetLastWin32Error())
            MsgBox("Проверка не возможна! " & message)
        End If
 
        Dim IOCTL_ATA_PASS_THROUGH As UInteger = CTL_CODE(IOCTL_SCSI_BASE, &H40B, METHOD_BUFFERED, FILE_READ_ACCESS Or FILE_WRITE_ACCESS)
 
        Dim id_query As New ATAIdentifyDeviceQuery()
        id_query.data = New UShort(255) {}
 
        id_query.header.Length = CUShort(Marshal.SizeOf(id_query.header))
        id_query.header.AtaFlags = CUShort(ATA_FLAGS_DATA_IN)
        id_query.header.DataTransferLength = CUInt(id_query.data.Length * 2) 'Размер данных в байтах
        id_query.header.TimeOutValue = 3 ' Sec
        id_query.header.DataBufferOffset = CType(Marshal.OffsetOf(GetType(ATAIdentifyDeviceQuery), "data"), IntPtr)
        id_query.header.PreviousTaskFile = New Byte(7) {}
        id_query.header.CurrentTaskFile = New Byte(7) {}
        id_query.header.CurrentTaskFile(6) = &HEC ' ATA IDENTIFY DEVICE
 
        Dim retval_size As UInteger
 
        Dim result As Boolean = DeviceIoControl(hDrive, IOCTL_ATA_PASS_THROUGH, id_query, CUInt(Marshal.SizeOf(id_query)), id_query, CUInt(Marshal.SizeOf(id_query)), retval_size, IntPtr.Zero)
 
        hDrive.Close()
 
        If result = False Then
            Dim message As String = GetErrorMessage(Marshal.GetLastWin32Error())
            MsgBox("IO невозможен! Запустите программу с административными правами." & Chr(10) & message)
        Else
            'Word index of nominal media rotation rate
            '(1 означает без механического диска, т.е. SSD)
            Const kNominalMediaRotRateWordIndex As Integer = 217
 
            If id_query.data(kNominalMediaRotRateWordIndex) = 1 Then
                HasNominalMediaRotationRate = "SSD"
            Else
                HasNominalMediaRotationRate = "HDD"
            End If
        End If
        Return HasNominalMediaRotationRate
    End Function
 
    ' Method for error message
    Private Shared Function GetErrorMessage(ByVal code As Integer) As String
        Dim message As New StringBuilder(255)
 
        FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, IntPtr.Zero, CUInt(code), 0, message, CUInt(message.Capacity), IntPtr.Zero)
 
        Return message.ToString()
    End Function
 
    Private Sub CheckButton_Click(sender As System.Object, e As System.EventArgs) Handles CheckButton.Click
        If DiskIndexBox.Text <> "" Then
            Dim objDisk = New ManagementObjectSearcher("select * from Win32_DiskDrive where MediaType='Fixed hard disk media' and Index=" & DiskIndexBox.Text)
            Try
                For Each objMgmt In objDisk.Get
                    Dim model = Split(objMgmt("Model").ToString, " ")
                    DiskName = model(0) & " " & model(1)
                    Diskindex = objMgmt("Index")
                    DeviceID = objMgmt("DeviceID")
                Next
            Catch ex As Exception
            End Try
            ResultLabel.Visible = True
            If objDisk.Get.Count = 0 Then
                ResultLabel.Text = "Диска с указанным индексом не существует"
                Exit Sub
            End If
            DiskType = HasNominalMediaRotationRate(DeviceID)
            If DiskType = "SSD" Then
                ResultLabel.Text = "В системе обнаружен SSD: " & DiskName
            Else
                ResultLabel.Text = "В системе обнаружен HDD: " & DiskName
            End If
        End If
    End Sub
End Class

Imports AForge
Imports AForge.Video
Imports AForge.Video.DirectShow
Imports System.IO
Public Class Form1
    Dim CAM As VideoCaptureDevice
    Dim bmp As Bitmap
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        Dim camera As VideoCaptureDeviceForm = New VideoCaptureDeviceForm
        If camera.ShowDialog() = Windows.Forms.DialogResult.OK Then
            CAM = camera.VideoDevice
            AddHandler CAM.NewFrame, New NewFrameEventHandler(AddressOf Captured)
            CAM.Start()
        End If
    End Sub
    Private Sub Captured(sender As Object, EventArgs As NewFrameEventArgs)
        bmp = DirectCast(EventArgs.Frame.Clone(), Bitmap)
        PictureBox1.Image = DirectCast(EventArgs.Frame.Clone(), Bitmap)
    End Sub
    Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
        PictureBox2.Image = PictureBox1.Image
    End Sub
    Private Sub Button3_Click(sender As Object, e As EventArgs) Handles Button3.Click
        SaveFileDialog1.DefaultExt = ".jpg"
        SaveFileDialog1.Filter = "JPG|*.jpg|PNG|*.png"
        If SaveFileDialog1.ShowDialog = DialogResult.OK Then
            PictureBox2.Image.Save(SaveFileDialog1.FileName)
        End If
    End Sub
    Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles MyBase.FormClosing
        CAM.Stop()
    End Sub
    Private Sub Button4_Click(sender As Object, e As EventArgs) Handles Button4.Click
        CAM.Stop()
    End Sub
    Private Sub Button5_Click(sender As Object, e As EventArgs) Handles Button5.Click
        CAM.Start()
    End Sub
End Class

Imports System.IO
Imports System.Linq
Imports System.Reflection
Imports System.ComponentModel
Imports System.Security.Cryptography
Imports System.Runtime.InteropServices
Imports System.Security.Cryptography.Pkcs
Imports System.Security.Cryptography.X509Certificates
 
Namespace SigningDate
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    Friend Declare Function CertCloseStore Lib "crypt32.dll" ( _
        ByVal hCertStore As IntPtr, _
        ByVal dwFlags As Integer _
    ) As <MarshalAs(UnmanagedType.Bool)> Boolean
    
    Friend Declare Function CryptMsgClose Lib "crypt32.dll" ( _
        ByVal hCryptMsg As IntPtr _
    ) As <MarshalAs(UnmanagedType.Bool)> Boolean
    
    Friend Declare Function CryptMsgGetParam Lib "crypt32.dll" ( _
        ByVal hCryptMsg As IntPtr, _
        ByVal dwParamType As UInt32, _
        ByVal dwIndex As Int32, _
        <[In]()> <[Out]()> pvData As Byte(), _
        ByRef pcbData As Int32 _
    ) As <MarshalAs(UnmanagedType.Bool)> Boolean
    
    Friend Declare Function CryptQueryObject Lib "crypt32.dll" ( _
        ByVal dwObjectType As Int32, _
        <MarshalAs(UnmanagedTYpe.LPWstr)> ByVal pvObject As String, _
        ByVal dwExpectedContentTypeFlags As Int32, _
        ByVal dwExpectedFormatTypeFlags As Int32, _
        ByVal dwFlags As Int32, _
        ByRef pdwMsgAndCertEncodingType As Int32, _
        ByRef pdwContentType As Int32, _
        ByRef pdwFormatType As Int32, _
        ByRef phCertStore As IntPtr, _
        ByRef phMsg As IntPtr, _
        ByRef ppvContext As IntPtr _
    ) As <MarshalAs(UnmanagedType.Bool)> Boolean
    
    Friend Shared Function GetSigningDate(ByVal [path] As String) As DateTime?
      Dim a1 As Int32 = 0
      Dim a2 As Int32 = 0
      Dim a3 As Int32 = 0
      Dim pcbData As Int32 = 0
      Dim phCertStore As IntPtr = IntPtr.Zero
      Dim phMsg As IntPtr = IntPtr.Zero
      Dim ppvContext As IntPtr = IntPtr.Zero
      Dim sign As DateTime? = Nothing
      
      If Not CryptQueryObject( _
        1, [path], 16382, 14, 0, a1, a2, a3, phCertStore, phMsg, ppvContext _
      ) Then
        Return Nothing
      End If
      
      CryptMsgGetParam(phMsg, 29UI, 0, Nothing, pcbData)
      Dim buf As Byte() = New Byte(pcbData - 1) {}
      If Not CryptMsgGetParam(phMsg, 29UI, 0, buf, pcbData) Then
        CryptMsgClose(phMsg)
        CertCloseStore(phCertStore, 0)
        
        Return Nothing
      End If
      
      Dim cms As New SignedCms()
      cms.Decode(buf)
      
      Dim enm1 As SignerInfoEnumerator = cms.SignerInfos.GetEnumerator()
      While enm1.MoveNext()
        Dim si As SignerInfo = enm1.Current
        Dim enm2 As SignerInfoEnumerator = si.CounterSignerInfos.GetEnumerator()
        While enm2.MoveNext()
          Dim csi As SignerInfo = enm2.Current
          sign = New DateTime?( _
            csi.SignedAttributes _
            .Cast(Of CryptographicAttributeObject)() _
            .Where(Function(x As CryptographicAttributeObject) x.Oid.Value.Equals("1.2.840.113549.1.9.5")) _
            .First() _
            .Values _
            .Cast(Of Pkcs9SigningTime)() _
            .First() _
            .SigningTime
          )
        End While
      End While
      
      CryptMsgClose(phMsg)
      CertCloseStore(phCertStore, 0)
      
      Return sign
    End Function
  End Class
 
  Friend NotInheritable Class Program
    Shared Sub Main(ByVal args As String())
      If args.Length <> 1 Then
        Console.WriteLine("Usage: {0} file", GetType(Program).Assembly.GetName().Name)
        Return
      End If
      
      If Not File.Exists(args(0)) Then
        Console.WriteLine(New Win32Exception(2).Message)
        Return
      End If
      
      Dim cert As X509Certificate = Nothing
      Dim [path] As String = IO.Path.GetFullPath(args(0))
      
      Try
        cert = X509Certificate.CreateFromSignedFile([path])
      Catch e As CryptographicException
        Console.WriteLine("NotSigned")
      End Try
      
      If cert Is Nothing Then
        Return
      End If
      Console.WriteLine(NativeMethods.GetSigningDate([path]))
    End Sub
  End Class
End Namespace

Imports System.Runtime.InteropServices
Imports System.Text.RegularExpressions
 
Friend NotInheritable Class Program
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    Friend Declare Auto Function EnumDisplayDevices Lib "user32.dll" ( _
        ByVal lpDevice As String, _
        ByVal iDevNum As Int32, _
        ByRef lpDeviceDisplay As DISPLAY_DEVICE, _
        ByVal dwFlags As UInt32 _
    ) As <MarshalAs(UnmanagedType.Bool)> Boolean
  End Class
  
  <StructLayout(LayoutKind.Sequential, CharSet := CharSet.Auto)>
  Friend Structure DISPLAY_DEVICE
    <MarshalAs(UnmanagedType.U4)>
    Friend cb As Int32
    <MarshalAs(UnmanagedType.ByValTStr, SizeConst := 32)>
    Friend DeviceName As String
    <MarshalAs(UnmanagedType.ByValTStr, SizeConst := 128)>
    Friend DeviceString As String
    <MarshalAs(UnmanagedType.U4)>
    Friend StateFlags As STATE_FLAGS
    <MarshalAs(UnmanagedType.ByValTStr, SizeConst := 128)>
    Friend DeviceID As String
    <MarshalAs(UnmanagedTYpe.ByValTStr, SizeConst := 128)>
    Friend DeviceKey As String
  End Structure
  
  <Flags()>
  Friend Enum STATE_FLAGS
    AttachedToDesktop = 1
    MultiDriver = 2
    PrimaryDevice = 4
    MirroringDrive = 8
    VgaCompatible = 16
    Removable = 32
    UnsfaeModesOn = 524288
    DeviceTSCompatible = 2097152
    Disconnect = 33554432
    Remote = 67108864
    ModeSpruned = 134217728
  End Enum
  
  Shared Sub Main()
    Dim dd As New DISPLAY_DEVICE()
    dd.cb = Marshal.SizeOf(GetType(DISPLAY_DEVICE))
    
    Dim i As UInt32 = 0
    While NativeMethods.EnumDisplayDevices(Nothing, i, dd, 0)
      If (dd.StateFlags And STATE_FLAGS.PrimaryDevice _
      ) = STATE_FLAGS.PrimaryDevice Then
        Console.WriteLine("Device   : {0}" & vbLf & _
          "Name     : {1}" & vbLf & "DeviceID : {2}" & vbLf _
          & "Registry : {3}", New Object() { _
          dd.DeviceName, dd.DeviceString, dd.DeviceID, _
          Regex.Replace(dd.DeviceKey, "(?i)\\registry\\machine", _
        "HKLM") })
        Return
      End If
      i += 1
    End While
  End Sub
End Class

'.NET Framework 4.5.2
Imports System.Reflection
Imports System.Diagnostics
Imports System.ComponentModel
Imports System.Security.Principal
Imports Microsoft.Win32.SafeHandles
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class Program
  Shared Sub Main(ByVal args As String())
    If args.Length <> 1 Then
      Console.WriteLine("Usage: {0} [PID]", _
        GetType(Program).Assembly.GetName().Name _
      )
      Return
    End If
    
    Dim id As Int32
    Dim stah As SafeAccessTokenHandle
    Dim OpenProcessToken As MethodInfo
    Dim pars As Object()
    
    id = If(Int32.TryParse(args(0), id), id, 0)
    If id = 0 Then
      Console.WriteLine("Wrong process Id, try again.")
      Return
    End If
    
    OpenProcessToken = GetType(Object).Assembly.GetType( _
      "Microsoft.Win32.Win32Native" _
    ).GetMethod( _
      "OpenProcessToken", BindingFlags.NonPublic Or _
      BindingFlags.Static _
    )
    
    stah = New SafeAccessTokenHandle(0)
    Try
      pars = New Object() {Process.GetProcessById(id).Handle, _
        TokenAccessLevels.Query, stah _
      }
      If Not CType( _
        OpenProcessToken.Invoke(Nothing, pars), Boolean _
      ) Then
        pars(2).Dispose()
        Throw New Win32Exception(Marshal.GetLastWin32Error())
      End If
      
      Dim wi As WindowsIdentity = New WindowsIdentity( _
        DirectCast(pars(2), SafeAccessTokenHandle).DangerousGetHandle() _
      )
      Console.WriteLine("PID: {0} Owner: {1}", _
        id, wi.Name
      )
      pars(2).Dispose()
    Catch e As Exception
      Console.WriteLine(e.Message)
    Finally
      stah.Dispose()
    End Try
  End Sub
End Class

Imports System.IO
Imports System.Reflection
Imports Microsoft.Win32.SafeHandles
Imports System.Runtime.InteropServices
Imports System.Text.RegularExpressions
 
Friend NotInheritable Class Program
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    Friend Declare Function NtQueryVolumeInformationFile _
    Lib "ntdll.dll" ( _
        ByVal FileHandle As SafeFileHandle, _
        ByRef IoStatusBlock As IntPtr, _
        ByRef FsInformation As FILE_FS_VOLUME_INFORMATION, _
        ByVal Length As UInt32, _
        ByVal FsInformationClass As UInt32 _
    ) As Int32
  End Class
  
  <StructLayout(LayoutKind.Sequential)>
  Friend Structure FILE_FS_VOLUME_INFORMATION
    Friend VolumeCreationTime As Int64
    Friend VolumeSerialNumber As UInt32
    Friend VolumeLabelLength  As UInt32
    Friend SupportsObjects    As UInt16
    Friend VolumeLabel        As UInt16
  End Structure
  
  Shared Sub Main()
    Dim tmp As String = Nothing
    Dim sfh As FileStream = Nothing
    Dim fvi As FILE_FS_VOLUME_INFORMATION
    Dim nts As Int32, sz As Int32
    Dim isb As IntPtr = IntPtr.Zero
    
    Try
      tmp = Path.GetTempFileName
      sfh = File.OpenRead(tmp)
      sz = Marshal.SizeOf(GetType(FILE_FS_VOLUME_INFORMATION))
      fvi = New FILE_FS_VOLUME_INFORMATION
      
      nts = NativeMethods.NtQueryVolumeInformationFile( _
        sfh.SafeFileHandle, isb, fvi, sz, 1
      )
      
      If nts <> 0 Then
        Throw New InvalidOperationException( _
          "Could not retrieve volume information." _
        )
      End If
      
      Console.WriteLine("Volume creation time: {0}" & vbLf & _
        "Volume serial number: {1}", _
        DateTime.FromFileTime(fvi.VolumeCreationTime),
        Regex.Replace(fvi.VolumeSerialNumber.ToString("X"), _
        "(\w{4})(\w{4})", "$1-$2") _
      )
    Catch e As Exception
      Console.WriteLine(e.Message)
    Finally
      If Not sfh Is Nothing Then
        sfh.Dispose
      End If
      
      If File.Exists(tmp) Then
        File.Delete(tmp)
      End If
    End Try
  End Sub
End Class

Imports System.ComponentModel
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class Program
  Private Const INVALID_HANDLE_VALUE As Int32  = -1
  Private Const ERROR_NO_MORE_ITEMS  As Int32  = 259
  Private Const SPDRP_DEVICEDESC     As UInt32 = 0
  
  Private Shared ReadOnly BUFFER_SIZE As UInt32 = CType( _
    Math.Pow(IntPtr.Size, 5), UInt32 _
  )
  
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    <DllImport("setupapi.dll", SetLastError := True, CharSet := CharSet.Auto)> _
    Friend Shared Function SetupDiGetClassDevs( _
        ByVal ClassGuid As IntPtr, _
        <MarshalAs(UnmanagedType.LPTStr)> _
        ByVal Enumerators As String, _
        ByVal hwndParent As IntPtr, _
        ByVal Flags As SP_DEVICE_GET_FLAGS _
    ) As IntPtr
    End Function
    
    <DllImport("setupapi.dll", SetLastError := True)> _
    Friend Shared Function SetupDiEnumDeviceInfo( _
        ByVal DeviceInfoSet As IntPtr, _
        ByVal NumberIndex As UInt32, _
        ByRef DeviceInfoData As SP_DEVINFO_DATA _
    ) As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function
    
    <DllImport("setupapi.dll", SetLastError := True, CharSet := CharSet.Auto)> _
    Friend Shared Function SetupDiGetDeviceRegistryProperty( _
        ByVal DeviceInfoSet As IntPtr, _
        ByRef DeviceInfoData As SP_DEVINFO_DATA, _
        ByVal [Property] As UInt32, _
        ByRef PropertyRegDataType As UInt32, _
        ByVal PropertyBuffer As Byte(), _
        ByVal PropertyByfferSize As UInt32, _
        ByRef RequiredSize As UInt32 _
    ) As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function
    
    <DllImport("setupapi.dll", SetLastError := True)> _
    Friend Shared Function SetupDiDestroyDeviceInfoList( _
        ByVal DeviceInfoSet As IntPtr _
    ) As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function
  End Class
  
  <Flags> _
  Friend Enum SP_DEVICE_GET_FLAGS As UInteger
    DIGCF_DEFAULT         = &H1
    DIGCF_PRESENT         = &H2
    DIGCF_ALLCLASSES      = &H4
    DIGCF_PROFILE         = &H8
    DIGCF_DEVICEINTERFACE = &H10
  End Enum
  
  <StructLayout(LayoutKind.Sequential)> _
  Friend Structure SP_DEVINFO_DATA
    Friend cbSize    As UInt32
    Friend ClassGuid As Guid
    Friend DevInst   As UInt32
    Friend Reserved  As IntPtr
  End Structure
  
  Shared Sub Main()
    Dim devs  As IntPtr
    Dim [err] As Int32 = 0
    Dim i     As UInt32 = 0
    Dim ret   As Boolean = True
    
    devs = NativeMethods.SetupDiGetClassDevs( _
      IntPtr.Zero, Nothing, IntPtr.Zero, _
      SP_DEVICE_GET_FLAGS.DIGCF_PRESENT Or SP_DEVICE_GET_FLAGS.DIGCF_ALLCLASSES _
    )
    
    If devs = IntPtr.Zero Then
      Console.WriteLine( _
        New Win32Exception(Marshal.GetLastWin32Error) _
      )
      Return
    End If
    
    While [err] <> ERROR_NO_MORE_ITEMS
      Dim sdd As New SP_DEVINFO_DATA()
      sdd.cbSize = CType(Marshal.SizeOf(sdd), UInt32)
      
      ret = NativeMethods.SetupDiEnumDeviceInfo(devs, i, sdd)
      [err] = Marshal.GetLastWin32Error()
      If ret Then
        Dim buf(BUFFER_SIZE - 1) As Byte
        Dim reg As UInt32 = 0, rsz As UInt32 = 0
        
        If NativeMethods.SetupDiGetDeviceRegistryProperty( _
          devs, sdd, SPDRP_DEVICEDESC, reg, buf, BUFFER_SIZE, rsz _
        ) Then
          Dim gch As GCHandle = GCHandle.Alloc(buf, GCHandleType.Pinned)
          Console.WriteLine(Marshal.PtrToStringAuto(gch.AddrOfPinnedObject))
          gch.Free
        End If
      End If
      
      i += 1
    End While
    
    NativeMethods.SetupDiDestroyDeviceInfoList(devs)
  End Sub
End Class

  Friend Enum SHELLKEY As UInteger
    SHELLKEY_HKCU_EXPLORER    = &H1
    SHELLKEY_HKLM_EXPLORER    = &H2
    SHELLKEY_HKCU_SHELL       = &H11
    SHELLKEY_HKLM_SHELL       = &H12
    SHELLKEY_HKCU_SHELLNOROAM = &H21
    SHELLKEY_HKCULM_MUICACHE  = &H5021
    SHELLKEY_HKCU_FILEEXTS    = &H6001
    SHELLKEY_HKULS_SHELL      = &H1FFFF
  End Enum

' .NETFramework v4.X
Imports Microsoft.Win32
Imports System.ComponentModel
Imports Microsoft.Win32.SafeHandles
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class Program
  Private Shared ReadOnly SHGetShellKeyOrdinal As New IntPtr(491)
  Private Shared m_SHGetShellKey As _SHGetShellKey
  
  Private Shared Property SHGetShellKey As _SHGetShellKey
    Get
      Return m_SHGetShellKey
    End Get
    Set
      m_SHGetShellKey = Value
    End Set
  End Property
  
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    <DllImport("kernel32.dll", SetLastError := True)> _
    Friend Shared Function FreeLibrary( _
        ByVal hModule As IntPtr _
    ) As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function
    
    <DllImport("kernel32.dll", SetLastError := True)> _
    Friend Shared Function GetProcAddress( _
        ByVal hModule As IntPtr, _
        ByVal lpProcName As IntPtr _
    ) As IntPtr
    End Function
    
    <DllImport("kernel32.dll", CharSet := CharSet.Auto, _
                               SetLastError := True)> _
    Friend Shared Function LoadLibrary( _
        ByVal lpFileName As String _
    ) As IntPtr
    End Function
  End Class
  
  Friend Enum SHELLKEY As UInteger
    SHELLKEY_HKCU_EXPLORER    = &H1
    SHELLKEY_HKLM_EXPLORER    = &H2
    SHELLKEY_HKCU_SHELL       = &H11
    SHELLKEY_HKLM_SHELL       = &H12
    SHELLKEY_HKCU_SHELLNOROAM = &H21
    SHELLKEY_HKCULM_MUICACHE  = &H5021
    SHELLKEY_HKCU_FILEEXTS    = &H6001
    SHELLKEY_HKULS_SHELL      = &H1FFFF
  End Enum
  
  <UnmanagedFunctionPointer(CallingConvention.WinApi)> _
  Friend Delegate Function _SHGetShellKey( _
      ByVal nShellKey As SHELLKEY, _
      ByVal pszSubKey As String, _
      ByVal bCreate As Boolean _
  ) As SafeRegistryHandle
  
  Private Shared Sub PrintWin32Error()
    Console.WriteLine( _
      New Win32Exception( _
        Marshal.GetLastWin32Error() _
      ).Message
    )
  End Sub
  
  Shared Sub Main()
    Dim _mod As IntPtr = IntPtr.Zero
    Dim fun  As IntPtr
    Dim srh  As New SafeRegistryHandle(IntPtr.Zero, False)
    Dim vals As String()
    
    Try
      _mod = NativeMethods.LoadLibrary("shlwapi.dll")
      fun  = NativeMethods.GetProcAddress(_mod, SHGetShellKeyOrdinal)
      SHGetShellKey = Marshal.GetDelegateForFunctionPointer( _
        fun, GetType(_SHGetShellKey) _
      )
      
      ' читаемт значения HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer
      srh = SHGetShellKey(SHELLKEY.SHELLKEY_HKCU_EXPLORER, Nothing, False)
      Using rk As RegistryKey = RegistryKey.FromHandle(srh)
        vals = rk.GetValueNames()
        For Each v As String In vals
          Console.WriteLine(v)
        Next
      End Using
    Catch e As Exception
      Console.WriteLine(e.Message)
    Finally
      If Not srh.IsInvalid Then
        srh.Dispose
      End If
      
      If Not _mod = IntPtr.Zero Then
        If Not NativeMethods.FreeLibrary(_mod) Then
          PrintWin32Error
        End If
      End If
    End Try
  End Sub
End Class