Форум программистов, компьютерный форум, киберфорум
Наши страницы

Visual Basic .NET

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 8, средняя оценка - 5.00
Памирыч
Почетный модератор
20610 / 8650 / 1029
Регистрация: 11.04.2010
Сообщений: 11,008
#1

Visual Basic .NET FAQ. Готовые решения, полезные коды - Visual Basic .NET

18.08.2011, 22:44. Просмотров 245735. Ответов 194
Метки faq (Все метки)

Предлагаю в этой теме размещать ответы на часто задаваемые вопросы и просто делиться полезными кодами.
Обращаю внимание на некоторые моменты, которые являются дополнением к основным правилам
  1. Запрещается копировать материалы с других сайтов или форумов
  2. Решения должны быть написаны с использованием языка Visual Basic .NET
  3. Запрещено создавать посты с уточнениями и замечаниями. Такие вопросы задавайте на форуме
  4. Код, в котором присутствуют комментарии, читается и понимается намного легче и быстрее
  5. Длинные коды и объемные вопросы одного содержания заключайте в теги [SPОILER]Большой код[/SPОILER]
  6. При создании поста убедитесь, что этот вопрос не был освещен ранее
  7. Код должен быть написан грамотно, большие и неэффективные коды будут удаляться
  8. Список вопросов по конкретной теме нельзя "разрывать" на 2 и более поста

Просьба к постившим: не спешите постить решения "сгоряча", тщательно обдумайте список вопросов, их тематику и порядок
Если вы найдете информацию, которой можно было бы дополнить ваши предыдущие сообщения, что-то изменить или перегруппировать, пишите в л/с.


Примечание: некоторые коды приведены без учета строгой типизации (Параметр Strict), поэтому для их использования необходимо выполнить приведение типов
47
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
18.08.2011, 22:44
Здравствуйте! Я подобрал для вас темы с ответами на вопрос Visual Basic .NET FAQ. Готовые решения, полезные коды (Visual Basic .NET):

Visual Basic .Net и Visual Basic 6.0 - В чём разница - Visual Basic .NET
В общем возник вопрос: Visual Bisic.Net и Visual Basic - это два разных языка, или же .NET версия это лишь его улучшение. Я так понимаю что...

Visual Basic.Net и Visual Studio 2013 - в чем разница? - Visual Basic .NET
Visual Basic.Net и Visual Studio 2013 - в чем разница? Или это одно и тоже, просто называются по другому. Планирую перейти с VB6.0...

Visual Basic .NET vs Visual FoxPro 9.0 в рамках задач реляционной модели данных - Visual Basic .NET
Очень хочется обсудить следующую тему. Поставлена задача - написать некоторую программу обработки данных. Все данные, обрабатываемые...

Исходники на Visual Basic .NET - Visual Basic .NET
Кто-то читает книжки. Кто-то ищет информацию в Google... А кто-то набирается знаний, разбирая чужие исходники. В этой теме предлагается...

Литература и ресурсы по Visual Basic .NET - Visual Basic .NET
Литература по Visual Basic.NET 1. Виктор Зиборов "Visual Basic 2010 на примерах" Издательство: БХВ-Петербург Год издания: 2010...

Хорошие учебники по Visual Basic Net - Visual Basic .NET
Подскажите пожалуйста хорошие учебники по visual basic net,спасибо

194
bobo bobo
11 / 11 / 0
Регистрация: 09.08.2015
Сообщений: 19
27.02.2016, 21:38 #166
Быстрая замена слов в документе Word

vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
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)
http://www.cyberforum.ru/attachment....1&d=1456598215
3
Миниатюры
Visual Basic .NET FAQ. Готовые решения, полезные коды   Visual Basic .NET FAQ. Готовые решения, полезные коды  
vaniak1
4 / 4 / 1
Регистрация: 25.11.2015
Сообщений: 26
14.03.2016, 21:50 #167
Экранная клавиатура для планшета на Windows 10

Автоматическое появление экранной клавиатуры при установке курсора в текстбокс и закрытие при клике формы

vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
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
4
greg zakharov
1434 / 697 / 174
Регистрация: 07.05.2015
Сообщений: 1,346
Записей в блоге: 39
23.03.2016, 15:07 #168
Аналог Sysinternals'овской logonsessions.
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
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
3
Yury Komar
Модератор
2211 / 2016 / 321
Регистрация: 27.01.2014
Сообщений: 3,578
Завершенные тесты: 1
20.05.2016, 13:56 #169
Form Fade-In/Fade-Out (без использования таймера)

vb.net
1
2
3
4
5
6
7
8
    Sub FormFade(Form As Form, isFadeOut As Boolean)
        Try : Dim tmr As New Stopwatch : tmr.Start()
            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 : tmr.Stop()
        Catch : End Try
    End Sub
как пользоваться:
vb.net
1
2
FormFade(Me, False) 'Мягкое появление формы
FormFade(Me, True) 'Мягкое закрытие формы
9
Миниатюры
Visual Basic .NET FAQ. Готовые решения, полезные коды  
greg zakharov
1434 / 697 / 174
Регистрация: 07.05.2015
Сообщений: 1,346
Записей в блоге: 39
20.05.2016, 17:23 #170
Список развернутых MSI-пакетов
Главное отличие данного подхода от аналогичного с использованием WMI - в скорости.
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
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
3
greg zakharov
1434 / 697 / 174
Регистрация: 07.05.2015
Сообщений: 1,346
Записей в блоге: 39
31.05.2016, 23:24 #171
Командная строка указанного процесса
Во-первых, все реализуется через делегаты, так что фанатов DllImport это может огорчить, во-вторых, код писался под 32-битную систему (см. различия PROCESS_BASIC_INFORMATION и PROCESS_BASIC_INFORMATION64 на MSDN), в-третьих, в виду вариативности некоторых полей структуры PEB на различных версиях Windows, данные структуры RTL_USER_PROCESS_PARAMETERS извлекаются по смещениям (благо они от версии к версии неизменны), в-четвертых, код ниже - всего лишь концепт того, как можно читать командную строку процесса. Например, после компиляции:
Код
E:\sandbox> app.exe 2157
powershell.exe /nologo /noprofile

E:\sandbox>
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
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
4
nworain
24 / 24 / 2
Регистрация: 17.04.2016
Сообщений: 144
04.06.2016, 23:07 #172
Работа с реестром в разделе HKEY_LOCAL_MACHINE ...
Важно !
Micosoft Visual Studio должна быть запущенна от имени администратора !
И скомпилированная программа должна запускаться от имени администратора !
Иначе работать не будет ...

vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
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
5
Вложения
Тип файла: rar REGISTER.rar (57.6 Кб, 9 просмотров)
Orlangur1991
611 / 600 / 136
Регистрация: 28.11.2014
Сообщений: 1,029
05.06.2016, 02:47 #173
Все приведенные примеры без использования Microsoft.Win32.RegistryKey
Записать какой-либо ключ в какой-либо раздел
Кликните здесь для просмотра всего текста

vb.net
1
2
3
4
5
6
7
8
9
Dim regloc As String = "HKEY_CURRENT_USER\Software\Microsoft\Master\Of\Puppets" 'указываем путь к ветке
Dim regname As String = "Metallica" ' указываем имя параметра
Dim key As String = "00000000000000000000000001" 'указываем значение параметра
 
My.Computer.Registry.SetValue(regloc, regname, key, Microsoft.Win32.RegistryValueKind.DWord) 'записываем
 
' Если такого раздела реестра не существует, он будет создан 
' Если такого параметра не существует, то он будет создан
' Microsoft.Win32.RegistryValueKind.DWord - имеет различные параметры на конце - это тип создаваемого параметра, например Binary / String / DWord и так далее

Полностью удалить ключ реестра
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
My.Computer.Registry.CurrentUser.OpenSubKey("SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\Explorer", Microsoft.Win32.RegistryKeyPermissionCheck.ReadWriteSubTree).DeleteValue("NoDrives")
' My.Computer.Registry.Позволяет выбрать нужную ветку реестра, например  My.Computer.Registry.LocalMachine
' Microsoft.Win32.RegistryKeyPermissionCheck.ReadWriteSubTree - задает права на Чтение / запись выбранного подраздела
' Вместо DeleteValue так же могут выполняться другие функции, например DeleteSubKey - удаляет выбранный подраздел

Пример записи в поле "(По умолчанию)"
Кликните здесь для просмотра всего текста
vb.net
1
 My.Computer.Registry.ClassesRoot.CreateSubKey(".master").SetValue("", ".master", Microsoft.Win32.RegistryValueKind.String)

Заставить редактор реестра открыть нужную ветку
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
' так как никаких ключей для подобных вещей эта программа не имеет, можно поступить так
Dim regloc As String = "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Applets\Regedit"
Dim regname As String = "Lastkey"
Dim key As String = "Компьютер\" & "Любой путь" ' Например "HKEY_CLASSES_ROOT"
 
My.Computer.Registry.SetValue(regloc, regname, key, Microsoft.Win32.RegistryValueKind.String)
Process.Start("regedit.exe")

Чтение данных из реестра
Кликните здесь для просмотра всего текста
vb.net
1
2
Dim readValue = My.Computer.Registry.GetValue("HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Applets\Regedit", "Lastkey", Nothing) '1 - Ветка реестра 2 - Имя ключа реестра
MsgBox(readValue)

Переименовать раздел реестра с сохранением всего содержимого
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
Dim OldKey As String = "HKEY_CURRENT_USER\SOFTWARE\S-1-60"
Dim NewKey As String = "HKEY_CURRENT_USER\SOFTWARE\S-1-60.bak"
Dim startInfo As New ProcessStartInfo("REG.EXE")
startInfo.WindowStyle = ProcessWindowStyle.Hidden
startInfo.Arguments = "COPY """ & OldKey & """ """ & NewKey & """ /s"
Dim myProcess As Process = Process.Start(startInfo)
myProcess.WaitForExit()
startInfo.Arguments = "DELETE """ & OldKey & """ /f"
Process.Start(startInfo)
 
'где OldKey - раздел, который надо переименовать
'NewKey - на что его надо переименовать

Рекурсивно удалить вложенный раздел и все дочерние элементы
Кликните здесь для просмотра всего текста
vb.net
1
2
' К примеру, удалить все из SOFTWARE\Microsoft\Myapp\ и сам раздел Myapp
My.Computer.Registry.CurrentUser.OpenSubKey("SOFTWARE\Microsoft", Microsoft.Win32.RegistryKeyPermissionCheck.ReadWriteSubTree).DeleteSubKeyTree("Myapp")

Узнать существет ли раздел реестра
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
Dim regKey = My.Computer.Registry.CurrentUser.OpenSubKey("Software\TEST")
If IsNothing(regKey) = True Then
    MsgBox("Раздел не существует")
Else
    MsgBox("Раздел Существует")
End If

Проверить, существует ли ключ реестра
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
If My.Computer.Registry.GetValue("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run", "Testprog", Nothing) Is Nothing Then
    MsgBox("Значение существует")
Else
    MsgBox("Значение не существует")
End If

Получить массив имен подразделов
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
' получаем имена всех подразделов в HKEY_CURRENT_USER
Dim names As String() = My.Computer.Registry.CurrentUser.GetSubKeyNames()
' теперь у нас есть массив имен всех подразделов раздела реестра HKEY_CURRENT_USER, можем их вывести, например, в textbox1:
For Each s As String In names
    TextBox1.Text = TextBox1.Text & "HKEY_CURRENT_USER\" & s & vbNewLine
Next

Записать hex ключ
Кликните здесь для просмотра всего текста
vb.net
1
2
Dim hxKey As Byte() = {&H10, &H1F, &H0, &H0, &H40, &H1F, &H0, &H0, &H40, &H1F, &H0, &H0, &H80, &H3E, &H0, &H0, &H80, &H3E, &H0, &H0, &H0, &H7D, &H0, &H0, &H0, &HFA, &H0, &H0, &H0, &HF4, &H1, &H0} 'Для начала создадим массив, так же для каждого значения добавить префикс &H для hex-констант.
My.Computer.Registry.SetValue("HKEY_CURRENT_USER\Software\test_hex", "hexkey", hxKey, Microsoft.Win32.RegistryValueKind.Binary) 'записываем
13
nworain
24 / 24 / 2
Регистрация: 17.04.2016
Сообщений: 144
05.06.2016, 16:39 #174
Создаем Launcher который запускает любую программу от имени администратора

Запускать будем программу REGISTER.EXE она в этом разделе форума выше !

Создаем консольное приложение

Cоздаем Run.vb и пишем код:

vb.net
1
2
3
4
5
6
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
Можете скачать пример:
1
Вложения
Тип файла: rar Launcher.rar (8.0 Кб, 24 просмотров)
Devils
14 / 14 / 0
Регистрация: 05.02.2015
Сообщений: 130
20.07.2016, 12:56 #175
Определение в системе SSD диска
Нашел на просторах интернета и немного "допилил"

vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
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
1
Вложения
Тип файла: 7z CheckSSD.7z (16.8 Кб, 6 просмотров)
17Vasya17
73 / 67 / 5
Регистрация: 05.01.2016
Сообщений: 257
24.08.2016, 14:13 #176
Работа с библиотекой AForge

1- Создаём новый проект windows form.
2- Кидаем на форму TableLayoutPanel1 и в свойствах ставим Remove Last Row
3- В TableLayoutPanel1 кидаем 2 PictureBox и в свойствах PictureBox1 и PictureBox2 ставим zoom и нажимаем Открыть в родительском контейнере. Также в свойствах PictureBox1 и PictureBox2 BorderStyle = FixedSingle.
4- На форму 5 Button, и SaveFileDialog1.
5- Нажимаем в меню VS: TOLS>Library Package Manager>Manage NuGet Packages for Solution- И в поиск вобьём AForge и
установим библиотеки AForge (core library), AForge.Video и AForge.Video.DirectShow

И вот весь код:

vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
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
Visual Basic .NET FAQ. Готовые решения, полезные коды
4
greg zakharov
1434 / 697 / 174
Регистрация: 07.05.2015
Сообщений: 1,346
Записей в блоге: 39
11.09.2016, 21:04 #177
Как получить время подписи файла
Попадался как-то на форуме вопрос (правда в разделе по C#) как можно получить время подписи файла. Если кто пользуется sigcheсk.exe от Sysinternals, тот наверняка понимает о чем речь. Так вот, тогда как-то не было времени разобраться с этим вопросом, недавно немного высвободилось. В общем, такая вот преамбула. Ниже - пример того, как вытащить время подписи файла (без UTC).
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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
4
greg zakharov
1434 / 697 / 174
Регистрация: 07.05.2015
Сообщений: 1,346
Записей в блоге: 39
16.09.2016, 09:24 #178
Данные об основном видеоадаптере
Если приложение пишется с расчетом на какую-то определенную модель видеокарты, полезно знать, как можно извлечь данные о последней (без использования WMI). Собственно, пример ниже это и делает.
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
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
Пример работы:
Код
Device   : \\.\DISPLAY1
Name     : Radeon X1600 Series (Microsoft Corporation - WDDM)
DeviceID : PCI\VEN_1002&DEV_71C0&SUBSYS_0880174B&REV_00
Registry : HKLM\System\CurrentControlSet\Control\Video\{BA8EA3CC-E49E-4F7C-8ED5-427FD64E032B}\0000
6
greg zakharov
1434 / 697 / 174
Регистрация: 07.05.2015
Сообщений: 1,346
Записей в блоге: 39
04.10.2016, 13:18 #179
Как получить имя владельца процесса (без явного использования PInvoke)?
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
'.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
2
greg zakharov
1434 / 697 / 174
Регистрация: 07.05.2015
Сообщений: 1,346
Записей в блоге: 39
05.10.2016, 23:24 #180
Как узнать время создания тома (и его серийный номер)?
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
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
4
05.10.2016, 23:24
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
05.10.2016, 23:24
Привет! Вот еще темы с ответами:

Вопросы к экзамену по курсу Visual Basic .NET - Visual Basic .NET
Помогите ответить на вопросы по Visual Basic. Завтра зачет. Пропускал лекции т.к все время уезжал. Помогите. Желательно развернутый ответ....

Перевести код с VBA на Visual Basic.NET - Visual Basic .NET
Здравствуйте! Прошу помощи. Переведите, пожалуйста, код ниже с VBA (Эксель) на Visual Basic.NET. Обращаюсь вынужденно, поскольку не...

Популярные программы, написанные на Visual basic.NET - Visual Basic .NET
Сейчас есть множество популярных программ, написанных на разных языках программирования. А есть ли популярные или известные программы,...

Для чего нужен Visual Basic.Net? - Visual Basic .NET
Здравствуйте. Объясните пожалуйста для какой деятельности нужен Visual Basic и Visual Basic.Net? То есть для чего там делают программы? И...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
180
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2017, vBulletin Solutions, Inc.
Рейтинг@Mail.ru