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

Памирыч · Регистрация: 11.04.2010

Студворк — интернет-сервис помощи студентам

Предлагаю в этой теме размещать ответы на часто задаваемые вопросы и просто делиться полезными кодами.
Обращаю внимание на некоторые моменты, которые являются дополнением к основным правилам

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

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

Комментарий модератора

Данные правила обязательны к исполнению в рамках темы

Примечание: некоторые коды приведены без учета строгой типизации (Параметр Strict), поэтому для их использования необходимо выполнить приведение типов

@Yury Komar · 15.02.2019, 05:22

Применить эффект негатива к изображению
_{Функция, принимающая параметром изображение и возвращающая его же, но с эффектом негатива.}

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
    Public Function GetNegativeImage(ByVal source As Bitmap) As Bitmap
        Dim newBitmap As Bitmap = New Bitmap(source.Width, source.Height)
        Dim g As Graphics = Graphics.FromImage(newBitmap)
 
        Dim colorMatrix As ColorMatrix = New ColorMatrix(New Single()() { _
            New Single() {-1, 0, 0, 0, 0}, _
            New Single() {0, -1, 0, 0, 0}, _
            New Single() {0, 0, -1, 0, 0}, _
            New Single() {0, 0, 0, 1, 0}, _
            New Single() {1, 1, 1, 0, 1}})
 
        Dim attributes As ImageAttributes = New ImageAttributes()
        attributes.SetColorMatrix(colorMatrix)
        g.DrawImage(source, New Rectangle(0, 0, source.Width, source.Height), 0, 0, source.Width, source.Height, GraphicsUnit.Pixel, attributes)
        g.Dispose()
        Return newBitmap
    End Function

@Yury Komar · 26.03.2019, 15:30

Drag&Drop файлов из проводника на форму и обратно с формы в проводник (или на рабочий стол)

Часто встречались вопросы на данную тему, решил выложить здесь, чтобы не потерять, думаю многих это так же интересует.

Drag & Drop файлов на форму

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Public Class Form1
    Private Sub Form1_DragDrop(ByVal sender As Object, ByVal e As System.Windows.Forms.DragEventArgs) Handles Me.DragDrop
        Dim file() As String = CType(e.Data.GetData(DataFormats.FileDrop), String())
        For I As Integer = 0 To file.Length - 1
            MsgBox(file(I))
        Next
    End Sub
 
    Private Sub Form1_DragEnter(ByVal sender As Object, ByVal e As System.Windows.Forms.DragEventArgs) Handles Me.DragEnter
        If e.Data.GetDataPresent(DataFormats.FileDrop) Then
            e.Effect = DragDropEffects.Copy
        Else
            e.Effect = DragDropEffects.None
        End If
    End Sub
 
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Me.AllowDrop = True
    End Sub
End Class

Drag & Drop файла с формы на рабочий стол или проводник

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
    Private Sub ListView1_MouseDown(ByVal sender As Object, ByVal e As  _
System.Windows.Forms.MouseEventArgs) Handles ListView1.MouseDown
 
 
        Dim filea(0) As String
        filea(0) = "C:\Users\Stas\Desktop\МО07ВРМакет00001.doc"
        Dim _data As DataObject = New DataObject(DataFormats.FileDrop, filea)
        ListView1.DoDragDrop(_data, DragDropEffects.Copy)
 
 
        ' Set a flag to show that the mouse is down.
        
    End Sub

@Yury Komar · 11.05.2019, 04:59

Круговой ProgressBar (Circle ProgressBar)

На просторах нашел код отрисовки кругового прогресс бара.
С ним можно сделать отображение прогресса более современным.

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
Private Sub DrawProgress(g As Graphics, rect As Rectangle, percentage As Single)
    'work out the angles for each arc
    Dim progressAngle = CSng(360 / 100 * percentage)
    Dim remainderAngle = 360 - progressAngle
 
    'create pens to use for the arcs
    Using progressPen As New Pen(Color.LightSeaGreen, 2), remainderPen As New Pen(Color.LightGray, 2)
        'set the smoothing to high quality for better output
        g.SmoothingMode = Drawing2D.SmoothingMode.AntiAlias
        'draw the blue and white arcs
        g.DrawArc(progressPen, rect, -90, progressAngle)
        g.DrawArc(remainderPen, rect, progressAngle - 90, remainderAngle)
    End Using
 
    'draw the text in the centre by working out how big it is and adjusting the co-ordinates accordingly
    Using fnt As New Font(Me.Font.FontFamily, 14)
        Dim text As String = percentage.ToString + "%"
        Dim textSize = g.MeasureString(text, fnt)
        Dim textPoint As New Point(CInt(rect.Left + (rect.Width / 2) - (textSize.Width / 2)), CInt(rect.Top + (rect.Height / 2) - (textSize.Height / 2)))
        'now we have all the values draw the text
        g.DrawString(text, fnt, Brushes.Black, textPoint)
    End Using
End Sub

Использование

VB.NET
1
2
3
4
5
Private Sub Form1_Paint(sender As Object, e As PaintEventArgs) Handles Me.Paint
    DrawProgress(e.Graphics, New Rectangle(5, 5, 60, 60), 40)
    DrawProgress(e.Graphics, New Rectangle(80, 5, 60, 60), 80)
    DrawProgress(e.Graphics, New Rectangle(155, 5, 60, 60), 57)
End Sub

@Yury Komar · 22.05.2019, 15:36

Получить интервал времени между двумя датами в формате Дней\Месяцев\Лет

Нестандартный способ получения интервала времени между двумя датами в формате Д\М\Г.
(стандартными методами можно получить только общее число дней, месяцев или лет)

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
    Public Function GetDateSpanText(fromDate As DateTime, Optional toDate As DateTime = Nothing) As String
        Try
            Dim years As Integer = 0, months As Integer = 0, days As Integer = 0
            If toDate = Nothing Then toDate = DateTime.Now
 
            Do Until toDate.AddYears(-1) < fromDate
                years += 1
                toDate = toDate.AddYears(-1)
            Loop
 
            Do Until toDate.AddMonths(-1) < fromDate
                months += 1
                toDate = toDate.AddMonths(-1)
            Loop
 
            Do Until toDate.AddDays(-1) < fromDate
                days += 1
                toDate = toDate.AddDays(-1)
            Loop
 
            Return String.Format("{0} дн. {1} мес. {2} г.", days, months, years)
        Catch ex As Exception
            Return "Error"
        End Try
    End Function

@Yury Komar · 22.05.2019, 16:58

Изменить размеры изображения сохраняя оригинальное соотношение сторон
(Resize Image keeping aspect ratio)

Особенности: Задавая только лишь одну величину (Ширину или Высоту) функция вернет изображение с новыми размерами, сохраняя оригинальное соотношение сторон. Задав оба значения (ширину И высоту) - вернется изображение с заданными размерами.

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
    Public Function ResizeKeepAspectRatio(OriginalImage As Bitmap, NewWidth As Integer, NewHeight As Integer) As Bitmap
        If NewWidth = Nothing And NewHeight = Nothing Then
            MsgBox("Either Width or Height must be greater than zero.")
            Return OriginalImage
        End If
 
        Dim tWidth As Integer = NewWidth
        Dim tHeight As Integer = NewHeight
 
        If tWidth > 0 Then
            If tHeight <= 0 Then tHeight = tWidth * (OriginalImage.Height / OriginalImage.Width)
        Else
            If tHeight > 0 Then tWidth = tHeight * (OriginalImage.Width / OriginalImage.Height)
        End If
 
        Dim bmp As New Bitmap(tWidth, tHeight)
        Using g = Graphics.FromImage(bmp)
            g.DrawImage(OriginalImage, 0, 0, tWidth, tHeight)
        End Using
        Return bmp
    End Function

Примеры использования:

VB.NET
1
2
3
4
5
6
'Задать только ширину, высота высчитается сама
Dim NewImage As Bitmap = ResizeKeepAspectRatio(OriginalImg, 1024, 0)
'Задать только высоту, ширина высчитается сама
Dim NewImage As Bitmap = ResizeKeepAspectRatio(OriginalImg, 0, 768)
'Явно задать новую ширину И высоту
Dim NewImage As Bitmap = ResizeKeepAspectRatio(OriginalImg, 1024, 768)

greg zakharov · 24.05.2019, 20:47

Еще один альтернативный способ узнать является ли система 64-х битной

VB.NET
1
2
3
4
5
6
7
Imports System.Runtime.InteropServices
 
Module OSBitness
  Sub Main
    Console.WriteLine(If (9 = Marshal.ReadInt16(CType(&H7FFE026A, IntPtr)), "64-bit", "32-bit"))
  End Sub
End Module

greg zakharov · 05.06.2019, 09:49

Время последнего входя в систему текущего пользователя

Каждый раз при входе в систему в реестре для текущего пользователя пере(записывается|создается) ключ "Volatile Environment"; считывая метку LastWriteTime этого ключа, можем узнать время последнего входа в систему с погрешностью от трех до десяти секунд.

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
Imports Microsoft.Win32
Imports System.Reflection
 
Module LogonTime
  Sub Main
    Using rk As RegistryKey = Registry.CurrentUser.OpenSubKey("Volatile Environment")
      If rk Is Nothing Then
        Console.WriteLine("Переменные окружение пользователя не обнаружены.")
        Return
      End If
      Dim ft(1) As Int32 ' поля структуры FILETIME
      If Not GetType(Object).Assembly.GetType("Microsoft.Win32.Win32Native") _
        .GetMethod("RegQueryInfoKey", BindingFlags.NonPublic Or BindingFlags.Static) _
        .Invoke(Nothing, { _
          rk.Handle, Nothing, Nothing, Nothing, Nothing, Nothing, _
          Nothing, Nothing, Nothing, Nothing, Nothing, ft}) Then
        Console.WriteLine( _
          DateTime.FromFileTime((CType(ft(1), Int64) << 32) Or CType(ft(0), UInt32)) _
        )
      End If
    End Using
  End Sub
End Module

@Yury Komar · 17.06.2019, 10:25

Поместить Панель или GroupBox, да что угодно, в ContextMenuStrip
оставлю здесь, чтоб не потерять

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
        'Создадим GroupBox
        Dim p As New GroupBox
        p.Size = New Size(500, 500)
        p.Dock = DockStyle.Fill
        p.Text = "GroupBox внутри менюшки"
 
        'Создадим кнопку
        Dim b As New Button
        b.Text = "Кнопочка"
        b.Location = New Point(250, 250)
 
        'Добавим кнопку в бокс
        p.Controls.Add(b) 'Добавим в групбокс
 
        'Создадим Хост, добавив ГРупБокс в него
        Dim hst As New ToolStripControlHost(p, "pan")
        hst.AutoSize = False
 
        'Размещаем наш бокс внутри менюшки и радуемся
        ContextMenuStrip1.Items.Add(hst)

@Yury Komar · 19.06.2019, 06:43

Таблица цветов в .NET
Полезно визуально видеть цвет, его имя и HEX-значение цвета.

@vova_king · 19.08.2019, 17:18

Диалоговое окно выбора папок

Код класса

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
Public Class FolderSelectDialog
 
        Public Class DialogResult
            Public ReturnCode As Integer
            Public FileName As String
        End Class
 
        Public Shared Function Show(ownerHandle As IntPtr, initialDirectory As String, title As String) As DialogResult
            Dim c_flags As BindingFlags = BindingFlags.Instance Or BindingFlags.[Public] Or BindingFlags.NonPublic
            Dim s_windowsFormsAssembly As Assembly = GetType(FileDialog).Assembly
            Dim s_iFileDialogType As Type = s_windowsFormsAssembly.[GetType]("System.Windows.Forms.FileDialogNative+IFileDialog")
            Dim s_createVistaDialogMethodInfo As MethodInfo = GetType(OpenFileDialog).GetMethod("CreateVistaDialog", c_flags)
            Dim s_onBeforeVistaDialogMethodInfo As MethodInfo = GetType(OpenFileDialog).GetMethod("OnBeforeVistaDialog", c_flags)
            Dim s_getOptionsMethodInfo As MethodInfo = GetType(FileDialog).GetMethod("GetOptions", c_flags)
            Dim s_setOptionsMethodInfo As MethodInfo = s_iFileDialogType.GetMethod("SetOptions", c_flags)
            Dim s_fosPickFoldersBitFlag As UInteger = CUInt(s_windowsFormsAssembly.[GetType]("System.Windows.Forms.FileDialogNative+FOS").GetField("FOS_PICKFOLDERS").GetValue(Nothing))
            Dim s_vistaDialogEventsConstructorInfo As ConstructorInfo = s_windowsFormsAssembly.[GetType]("System.Windows.Forms.FileDialog+VistaDialogEvents").GetConstructor(c_flags, Nothing, New Type() {GetType(FileDialog)}, Nothing)
            Dim s_adviseMethodInfo As MethodInfo = s_iFileDialogType.GetMethod("Advise")
            Dim s_unAdviseMethodInfo As MethodInfo = s_iFileDialogType.GetMethod("Unadvise")
            Dim s_showMethodInfo As MethodInfo = s_iFileDialogType.GetMethod("Show")
 
            Dim openFileDialog = New OpenFileDialog() With {
                        .AddExtension = False,
                        .CheckFileExists = False,
                        .DereferenceLinks = True,
                        .Filter = "Folders|",
                        .InitialDirectory = initialDirectory,
                        .Multiselect = False,
                        .Title = title
                    }
 
            Dim iFileDialog = s_createVistaDialogMethodInfo.Invoke(openFileDialog, New Object() {})
            s_onBeforeVistaDialogMethodInfo.Invoke(openFileDialog, New Object() {iFileDialog})
            s_setOptionsMethodInfo.Invoke(iFileDialog, New Object() {CUInt(s_getOptionsMethodInfo.Invoke(openFileDialog, New Object() {})) Or s_fosPickFoldersBitFlag})
 
            Dim adviseParametersWithOutputConnectionToken = New Object() {s_vistaDialogEventsConstructorInfo.Invoke(New Object() {openFileDialog}), 0UI}
            s_adviseMethodInfo.Invoke(iFileDialog, adviseParametersWithOutputConnectionToken)
            Dim prest As String
            Try
                Dim retVal As Integer = CInt(s_showMethodInfo.Invoke(iFileDialog, New Object() {ownerHandle}))
 
                Return New DialogResult() With {.ReturnCode = retVal, .FileName = openFileDialog.FileName}
                prest = System.IO.Path.GetFileName(openFileDialog.FileName)
            Finally
                s_unAdviseMethodInfo.Invoke(iFileDialog, New Object() {adviseParametersWithOutputConnectionToken(1)})
            End Try
        End Function
 
    End Class

VB.NET
1
2
3
dim apppath  as string ' переменная хранящая путь выбранной папки
dim pathFolders as string = "C:" ' начальная папка 
apppath = FolderSelectDialog.Show(Me.Handle, pathFolders, "Выберите папку").FileName ' присваиваем переменной полученный результат

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

PS. При нажатии "Отмена" пока не знаю как обрабатывать :-(

@ovva · 15.12.2019, 16:13

Пример, переведенного на vb.net, диалогового окна выбора папок из
https://stackoverflow.com/ques... 2#15386992
PS. Хотя можно было бы и не переводить, а использовать как есть.

Кликните здесь для просмотра всего текста

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
Imports System.Reflection
Imports System.Windows.Forms
Namespace FSD
    Public Class FolderSelectDialog
        Private _initialDirectory As String
        Private _title As String
        Private _fileName As String = ""
        Public Property InitialDirectory As String
            Get
                Return If(String.IsNullOrEmpty(_initialDirectory), Environment.CurrentDirectory, _initialDirectory)
            End Get
            Set(ByVal value As String)
                _initialDirectory = value
            End Set
        End Property
 
        Public Property Title As String
            Get
                Return If(_title, "Select a folder")
            End Get
            Set(ByVal value As String)
                _title = value
            End Set
        End Property
 
        Public ReadOnly Property FileName As String
            Get
                Return _fileName
            End Get
        End Property
 
        Public Function Show() As Boolean
            Return Show(IntPtr.Zero)
        End Function
 
        Public Function Show(ByVal hWndOwner As IntPtr) As Boolean
            Dim result = If(Environment.OSVersion.Version.Major >= 6, VistaDialog.Show(hWndOwner, InitialDirectory, Title), ShowXpDialog(hWndOwner, InitialDirectory, Title))
            _fileName = result.FileName
            Return result.Result
        End Function
 
        Private Structure ShowDialogResult
            Public Property Result As Boolean
            Public Property FileName As String
        End Structure
 
        Private Shared Function ShowXpDialog(ByVal ownerHandle As IntPtr, ByVal initialDirectory As String, ByVal title As String) As ShowDialogResult
            Dim folderBrowserDialog = New FolderBrowserDialog With {
                .Description = title,
                .SelectedPath = initialDirectory,
                .ShowNewFolderButton = False
            }
            Dim dialogResult = New ShowDialogResult()
            If folderBrowserDialog.ShowDialog(New WindowWrapper(ownerHandle)) = Windows.Forms.DialogResult.OK Then
                dialogResult.Result = True
                dialogResult.FileName = folderBrowserDialog.SelectedPath
            End If
            Return dialogResult
        End Function
 
        Private Class VistaDialog
            Private Const c_foldersFilter As String = "Folders|" & vbLf
            Private Const c_flags As BindingFlags = BindingFlags.Instance Or BindingFlags.[Public] Or BindingFlags.NonPublic
            Private Shared ReadOnly s_windowsFormsAssembly As Assembly = GetType(FileDialog).Assembly
            Private Shared ReadOnly s_iFileDialogType As Type = s_windowsFormsAssembly.[GetType]("System.Windows.Forms.FileDialogNative+IFileDialog")
            Private Shared ReadOnly s_createVistaDialogMethodInfo As MethodInfo = GetType(OpenFileDialog).GetMethod("CreateVistaDialog", c_flags)
            Private Shared ReadOnly s_onBeforeVistaDialogMethodInfo As MethodInfo = GetType(OpenFileDialog).GetMethod("OnBeforeVistaDialog", c_flags)
            Private Shared ReadOnly s_getOptionsMethodInfo As MethodInfo = GetType(FileDialog).GetMethod("GetOptions", c_flags)
            Private Shared ReadOnly s_setOptionsMethodInfo As MethodInfo = s_iFileDialogType.GetMethod("SetOptions", c_flags)
            Private Shared ReadOnly s_fosPickFoldersBitFlag As UInteger = CUInt(s_windowsFormsAssembly.[GetType]("System.Windows.Forms.FileDialogNative+FOS").GetField("FOS_PICKFOLDERS").GetValue(Nothing))
            Private Shared ReadOnly s_vistaDialogEventsConstructorInfo As ConstructorInfo = s_windowsFormsAssembly.[GetType]("System.Windows.Forms.FileDialog+VistaDialogEvents").GetConstructor(c_flags, Nothing, {GetType(FileDialog)}, Nothing)
            Private Shared ReadOnly s_adviseMethodInfo As MethodInfo = s_iFileDialogType.GetMethod("Advise")
            Private Shared ReadOnly s_unAdviseMethodInfo As MethodInfo = s_iFileDialogType.GetMethod("Unadvise")
            Private Shared ReadOnly s_showMethodInfo As MethodInfo = s_iFileDialogType.GetMethod("Show")
 
            Shared Function Show(ByVal ownerHandle As IntPtr, ByVal initialDirectory As String, ByVal title As String) As ShowDialogResult
                Dim openFileDialog = New OpenFileDialog With {
                    .AddExtension = False,
                    .CheckFileExists = False,
                    .DereferenceLinks = True,
                    .Filter = c_foldersFilter,
                    .InitialDirectory = initialDirectory,
                    .Multiselect = False,
                    .Title = title
                }
                Dim iFileDialog = s_createVistaDialogMethodInfo.Invoke(openFileDialog, New Object() {})
                s_onBeforeVistaDialogMethodInfo.Invoke(openFileDialog, {iFileDialog})
                s_setOptionsMethodInfo.Invoke(iFileDialog, New Object() {CUInt(s_getOptionsMethodInfo.Invoke(openFileDialog, New Object() {})) Or s_fosPickFoldersBitFlag})
                Dim adviseParametersWithOutputConnectionToken = {s_vistaDialogEventsConstructorInfo.Invoke(New Object() {openFileDialog}), 0UI}
                s_adviseMethodInfo.Invoke(iFileDialog, adviseParametersWithOutputConnectionToken)
                Try
                    Dim retVal As Integer = CInt(s_showMethodInfo.Invoke(iFileDialog, New Object() {ownerHandle}))
                    Return New ShowDialogResult With {
                        .Result = retVal = 0,
                        .FileName = openFileDialog.FileName
                    }
                Finally
                    s_unAdviseMethodInfo.Invoke(iFileDialog, {adviseParametersWithOutputConnectionToken(1)})
                End Try
            End Function
        End Class
 
        Private Class WindowWrapper
            Implements IWin32Window
            Private ReadOnly _handle As IntPtr
 
            Public Sub New(ByVal handle As IntPtr)
                _handle = handle
            End Sub
 
            Public ReadOnly Property Handle As IntPtr Implements IWin32Window.Handle
                Get
                    Return _handle
                End Get
            End Property
        End Class
    End Class
End Namespace

Применение

VB.NET
1
2
3
4
5
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
    Dim dialog = New FolderSelectDialog With {.InitialDirectory = "C:\", .Title = "Выбор папки"}
    dialog.Show(Handle)
    Label1.Text = dialog.FileName
End Sub

@Zhivoder · 18.12.2019, 13:49

Вроде не нашел такого, если было, то не убивайте =)
Прозрачный PictureBox, код не мой, но очень полезный:

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Public Class TransparentPictureBox
    Inherits PictureBox
    Protected Overrides Sub OnPaintBackground(ByVal e As System.Windows.Forms.PaintEventArgs)
        MyBase.OnPaintBackground(e)
 
        If Parent IsNot Nothing Then
            Dim index As Integer = Parent.Controls.GetChildIndex(Me)
 
            For i As Integer = Parent.Controls.Count - 1 To index + 1 Step -1
                Dim c As Control = Parent.Controls(i)
                If c.Bounds.IntersectsWith(Bounds) AndAlso c.Visible = True Then
                    Dim bmp As New Bitmap(c.Width, c.Height, e.Graphics)
                    c.DrawToBitmap(bmp, c.ClientRectangle)
                    e.Graphics.TranslateTransform(c.Left - Left, c.Top - Top)
                    e.Graphics.DrawImageUnscaled(bmp, Point.Empty)
                    e.Graphics.TranslateTransform(Left - c.Left, Top - c.Top)
                    bmp.Dispose()
                End If
            Next
        End If
    End Sub
End Class

@January29 · 05.01.2020, 17:56

Проверка EXCEL на ПК
Проверял на XP-SP2 и Windows 7 SP1 работает
курил форум и нашел многие спрашивают

вот код
Копируем вставляем изменяем

Кликните здесь для просмотра всего текста

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Public Class Form1
    ' ПРОВЕРКА УСТАНОВКИ EXCEL НА ПК
    ' НА ФОРМУ КИДАЕМ КНОПКУ Button1 и Label1
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
 
        Dim excelApp As Object
        Try
            excelApp = CreateObject("Excel.Application")
            If excelApp.Name = "Microsoft Excel" Then 'сверка имени
                Label1.Text = "Установлен " & excelApp.Name & " " & excelApp.version ' пишет имя и версию
                excelApp.Quit() 'закрытие процесса
            End If
        Catch ex As System.Exception
            Label1.Text = "У ВАС НЕ УСТАНОВЛЕН ЕХСЕL" ' ЕСЛИ НЕТ - EXCEL
        End Try
 
    End Sub
End Class

@Zhivoder · 07.02.2020, 10:56

Бегущая строка, вдруг кому-то пригодится:

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
Public Class Form1
    Private timer1 As Timer = New Timer
 
    Private string_ As String = "...Место для Вашей рекламы..."
    Private temp_txt As String = Microsoft.VisualBasic.Space(70) & string_
    Private how_many_sign As Integer = (Microsoft.VisualBasic.Space(70) & string_).Length
    Private var_2 As Boolean = False
    Private var_2_signs As Integer = 1
 
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        TextBox1.Text = temp_txt
        timer1.Interval = 50
        AddHandler timer1.Tick, AddressOf timer2_tick
        timer1.Start()
    End Sub
 
    'Вариант 1
    Private Sub Timer1_Tick()
        If Microsoft.VisualBasic.Len(TextBox1.Text) = 0 Then TextBox1.Text = temp_txt
        TextBox1.Text = Microsoft.VisualBasic.Right(TextBox1.Text, Microsoft.VisualBasic.Len(TextBox1.Text) - 1)
    End Sub
 
    'Вариант 2
    Private Sub timer2_tick()
        If var_2_signs >= how_many_sign Then
            var_2 = False
            var_2_signs = 1
        End If
 
        If Microsoft.VisualBasic.Len(TextBox1.Text) = 0 Then
            var_2 = True
                how_many_sign = (Microsoft.VisualBasic.Space(70) & string_).Length
            End If
 
        If var_2 = False Then
            TextBox1.Text = Microsoft.VisualBasic.Right(TextBox1.Text, Microsoft.VisualBasic.Len(TextBox1.Text) - 1)
        Else
            var_2_signs += 1
            TextBox1.Text = Microsoft.VisualBasic.Right(temp_txt, var_2_signs)
        End If
 
    End Sub
 
End Class

На форме textbox
- размеры - 520; 44
- шрифт - Microsoft Sans Serif; 24pt

В первом варианте просто проходит до конца и начинается сначала, во втором варианте возвращается обратным ходом )

@Proidoha · 04.03.2020, 00:21

Передача (эмуляция) нажатия клавиши в любое активное окно, используя экранную клавиатуру.

Работает с играми на DirectX, в которых отказали иные, более простые методы, а так же своеобразный костыль, если не получилось разобраться с DirectX SDK.

Важно! Работает только от имени администратора.

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
Imports System.Runtime.InteropServices
Imports System.Threading
 
Public Class Form1
 
    Declare Auto Function FindWindow Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As IntPtr
    Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As IntPtr, ByRef lpRect As RECT) As Integer
    Declare Function MoveWindow Lib "user32.dll" (ByVal hwnd As IntPtr, ByVal x As IntPtr, ByVal y As IntPtr, ByVal nWidth As IntPtr, ByVal nHeight As IntPtr, ByVal bRepaint As IntPtr) As Boolean
 
    Public Structure RECT 'координаты угловых точек экранной клавиатуры
        Public Left As Integer
        Public Top As Integer
        Public Right As Integer
        Public Bottom As Integer
    End Structure
 
    Public one As RECT
    Public handleOSK As IntPtr 'переменная для хэндла окна экранной клавиатуры
 
    'При загрузке формы
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
 
        'запускаем экранную клавиатуру через коммандную строку. Не всегда запускается другими методами
        Dim psi = New ProcessStartInfo()
        psi.FileName = "c:\\windows\\sysnative\\cmd.exe"
        psi.Arguments = "/k start osk && exit"
        psi.CreateNoWindow = True
        psi.WindowStyle = ProcessWindowStyle.Hidden
        Process.Start(psi)
 
        Thread.Sleep(300) 'пауза 300 мс, необязательно, нужна если уж совсем слабый компютер
 
        handleOSK = FindWindow(vbNullString, "Экранная клавиатура") 'получаем хэндл окна экранной клавиатуры в переменную
        GetWindowRect(handleOSK, one) 'определяем координаты углов экранной клавиатуры
        MoveWindow(handleOSK, 1920, 400, 600, 200, 0) 'делаем ее размером 600 х 200 пикселей, и сдвигаем за правую границу экрана (для разрешения 1920х1080)
    End Sub
 
    ' при закрытии формы убиваем процесс экранной клавиатуры (osk.exe) так же через командную строку
    Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As FormClosingEventArgs) Handles MyBase.FormClosing
        Dim psi = New ProcessStartInfo()
        psi.FileName = "c:\\windows\\sysnative\\cmd.exe"
        psi.Arguments = "/k taskkill /im osk.exe && exit"
        psi.Verb = "runas" 'запуск CMD от имени администратора ОБЯЗАТЕЛЬНО
        psi.CreateNoWindow = True
        psi.WindowStyle = ProcessWindowStyle.Hidden
        Process.Start(psi)
    End Sub
 
    'в данном примере при нажатии кнопки Button1 через 3 секунды нажимается кнопка W
    'резонно использовать вместо кнопки либо таймер, либо горячие клавиши
    'окно, в которое необходимо передать нажатие, должно быть активным.
 
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Thread.Sleep(3000) 'чтобы успеть переключиться в то окно, в котором требуется нажатие. 
        Keyboard.SendKey(Keyboard.DirectXKeyStrokes.DIK_W, False, Keyboard.InputType.Keyboard) 'используем класс keyboard, приведенный ниже
        Keyboard.SendKey(Keyboard.DirectXKeyStrokes.DIK_W, True, Keyboard.InputType.Keyboard)
    End Sub
End Class

За нижеприведенный класс отдельное спасибо Orlangur. OSK простые способы нажатия клавиш игнорирует.

Класс keyboard, использующийся для эмуляции нажатия клавиши:

Кликните здесь для просмотра всего текста

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
247
248
249
250
251
252
253
254
Public Class Keyboard
    <Flags()>
    Public Enum InputType
        Mouse = 0
        Keyboard = 1
        Hardware = 2
    End Enum
 
    <Flags()>
    Public Enum KeyEventF
        KeyDown = &H0
        ExtendedKey = &H1
        KeyUp = &H2
        Unicode = &H4
        Scancode = &H8
    End Enum
 
    <DllImport("user32.dll", SetLastError:=True)>
    Private Shared Function SendInput(ByVal nInputs As UInteger, ByVal pInputs() As Input, ByVal cbSize As Integer) As UInteger
    End Function
 
    <DllImport("user32.dll")>
    Private Shared Function GetMessageExtraInfo() As IntPtr
    End Function
 
 
    ''' DirectX key list collected out from the gamespp.com list by me.
 
    Public Enum DirectXKeyStrokes
        DIK_ESCAPE = &H1
        DIK_1 = &H2
        DIK_2 = &H3
        DIK_3 = &H4
        DIK_4 = &H5
        DIK_5 = &H6
        DIK_6 = &H7
        DIK_7 = &H8
        DIK_8 = &H9
        DIK_9 = &HA
        DIK_0 = &HB
        DIK_MINUS = &HC
        DIK_EQUALS = &HD
        DIK_BACK = &HE
        DIK_TAB = &HF
        DIK_Q = &H10
        DIK_W = &H11
        DIK_E = &H12
        DIK_R = &H13
        DIK_T = &H14
        DIK_Y = &H15
        DIK_U = &H16
        DIK_I = &H17
        DIK_O = &H18
        DIK_P = &H19
        DIK_LBRACKET = &H1A
        DIK_RBRACKET = &H1B
        DIK_RETURN = &H1C
        DIK_LCONTROL = &H1D
        DIK_A = &H1E
        DIK_S = &H1F
        DIK_D = &H20
        DIK_F = &H21
        DIK_G = &H22
        DIK_H = &H23
        DIK_J = &H24
        DIK_K = &H25
        DIK_L = &H26
        DIK_SEMICOLON = &H27
        DIK_APOSTROPHE = &H28
        DIK_GRAVE = &H29
        DIK_LSHIFT = &H2A
        DIK_BACKSLASH = &H2B
        DIK_Z = &H2C
        DIK_X = &H2D
        DIK_C = &H2E
        DIK_V = &H2F
        DIK_B = &H30
        DIK_N = &H31
        DIK_M = &H32
        DIK_COMMA = &H33
        DIK_PERIOD = &H34
        DIK_SLASH = &H35
        DIK_RSHIFT = &H36
        DIK_MULTIPLY = &H37
        DIK_LMENU = &H38
        DIK_SPACE = &H39
        DIK_CAPITAL = &H3A
        DIK_F1 = &H3B
        DIK_F2 = &H3C
        DIK_F3 = &H3D
        DIK_F4 = &H3E
        DIK_F5 = &H3F
        DIK_F6 = &H40
        DIK_F7 = &H41
        DIK_F8 = &H42
        DIK_F9 = &H43
        DIK_F10 = &H44
        DIK_NUMLOCK = &H45
        DIK_SCROLL = &H46
        DIK_NUMPAD7 = &H47
        DIK_NUMPAD8 = &H48
        DIK_NUMPAD9 = &H49
        DIK_SUBTRACT = &H4A
        DIK_NUMPAD4 = &H4B
        DIK_NUMPAD5 = &H4C
        DIK_NUMPAD6 = &H4D
        DIK_ADD = &H4E
        DIK_NUMPAD1 = &H4F
        DIK_NUMPAD2 = &H50
        DIK_NUMPAD3 = &H51
        DIK_NUMPAD0 = &H52
        DIK_DECIMAL = &H53
        DIK_F11 = &H57
        DIK_F12 = &H58
        DIK_F13 = &H64
        DIK_F14 = &H65
        DIK_F15 = &H66
        DIK_KANA = &H70
        DIK_CONVERT = &H79
        DIK_NOCONVERT = &H7B
        DIK_YEN = &H7D
        DIK_NUMPADEQUALS = &H8D
        DIK_CIRCUMFLEX = &H90
        DIK_AT = &H91
        DIK_COLON = &H92
        DIK_UNDERLINE = &H93
        DIK_KANJI = &H94
        DIK_STOP = &H95
        DIK_AX = &H96
        DIK_UNLABELED = &H97
        DIK_NUMPADENTER = &H9C
        DIK_RCONTROL = &H9D
        DIK_NUMPADCOMMA = &HB3
        DIK_DIVIDE = &HB5
        DIK_SYSRQ = &HB7
        DIK_RMENU = &HB8
        DIK_HOME = &HC7
        DIK_UP = &HC8
        DIK_PRIOR = &HC9
        DIK_LEFT = &HCB
        DIK_RIGHT = &HCD
        DIK_END = &HCF
        DIK_DOWN = &HD0
        DIK_NEXT = &HD1
        DIK_INSERT = &HD2
        DIK_DELETE = &HD3
        DIK_LWIN = &HDB
        DIK_RWIN = &HDC
        DIK_APPS = &HDD
        DIK_BACKSPACE = DIK_BACK
        DIK_NUMPADSTAR = DIK_MULTIPLY
        DIK_LALT = DIK_LMENU
        DIK_CAPSLOCK = DIK_CAPITAL
        DIK_NUMPADMINUS = DIK_SUBTRACT
        DIK_NUMPADPLUS = DIK_ADD
        DIK_NUMPADPERIOD = DIK_DECIMAL
        DIK_NUMPADSLASH = DIK_DIVIDE
        DIK_RALT = DIK_RMENU
        DIK_UPARROW = DIK_UP
        DIK_PGUP = DIK_PRIOR
        DIK_LEFTARROW = DIK_LEFT
        DIK_RIGHTARROW = DIK_RIGHT
        DIK_DOWNARROW = DIK_DOWN
        DIK_PGDN = DIK_NEXT
 
        ' Mined these out of nowhere.
        DIK_LEFTMOUSEBUTTON = &H100
        DIK_RIGHTMOUSEBUTTON = &H101
        DIK_MIDDLEWHEELBUTTON = &H102
        DIK_MOUSEBUTTON3 = &H103
        DIK_MOUSEBUTTON4 = &H104
        DIK_MOUSEBUTTON5 = &H105
        DIK_MOUSEBUTTON6 = &H106
        DIK_MOUSEBUTTON7 = &H107
        DIK_MOUSEWHEELUP = &H108
        DIK_MOUSEWHEELDOWN = &H109
    End Enum
 
 
    ''' Sends a directx key.
    ''' <param name="key"></param>
    ''' <param name="KeyUp"></param>
    ''' <param name="inputType"></param>
    Public Shared Sub SendKey(ByVal key As DirectXKeyStrokes, ByVal KeyUp As Boolean, ByVal inputType As InputType)
        Dim flagtosend As UInteger
        If KeyUp Then
            flagtosend = CUInt(KeyEventF.KeyUp Or KeyEventF.Scancode)
        Else
            flagtosend = CUInt(KeyEventF.KeyDown Or KeyEventF.Scancode)
        End If
 
        Dim inputs() As Input = {New Input With {.type = CInt(inputType), .u = New InputUnion With {.ki = New KeyboardInput With {.wVk = 0, .wScan = CUShort(key), .dwFlags = flagtosend, .dwExtraInfo = GetMessageExtraInfo()}}}}
 
        SendInput(CUInt(inputs.Length), inputs, Marshal.SizeOf(GetType(Input)))
    End Sub
 
    ''' Sends a directx key.
    ''' <param name="key"></param>
    ''' <param name="KeyUp"></param>
    ''' <param name="inputType"></param>
    Public Shared Sub SendKey(ByVal key As UShort, ByVal KeyUp As Boolean, ByVal inputType As InputType)
        Dim flagtosend As UInteger
        If KeyUp Then
            flagtosend = CUInt(KeyEventF.KeyUp Or KeyEventF.Scancode)
        Else
            flagtosend = CUInt(KeyEventF.KeyDown Or KeyEventF.Scancode)
        End If
 
        Dim inputs() As Input = {New Input With {.type = CInt(inputType), .u = New InputUnion With {.ki = New KeyboardInput With {.wVk = 0, .wScan = key, .dwFlags = flagtosend, .dwExtraInfo = GetMessageExtraInfo()}}}}
 
        SendInput(CUInt(inputs.Length), inputs, Marshal.SizeOf(GetType(Input)))
    End Sub
 
    Public Structure Input
        Public type As Integer
        Public u As InputUnion
    End Structure
 
    <StructLayout(LayoutKind.Explicit)>
    Public Structure InputUnion
        <FieldOffset(0)>
        Public ReadOnly mi As MouseInput
        <FieldOffset(0)>
        Public ki As KeyboardInput
        <FieldOffset(0)>
        Public ReadOnly hi As HardwareInput
    End Structure
 
    <StructLayout(LayoutKind.Sequential)>
    Public Structure MouseInput
        Public ReadOnly dx As Integer
        Public ReadOnly dy As Integer
        Public ReadOnly mouseData As UInteger
        Public ReadOnly dwFlags As UInteger
        Public ReadOnly time As UInteger
        Public ReadOnly dwExtraInfo As IntPtr
    End Structure
 
    <StructLayout(LayoutKind.Sequential)>
    Public Structure KeyboardInput
        Public wVk As UShort
        Public wScan As UShort
        Public dwFlags As UInteger
        Public ReadOnly time As UInteger
        Public dwExtraInfo As IntPtr
    End Structure
 
    <StructLayout(LayoutKind.Sequential)>
    Public Structure HardwareInput
        Public ReadOnly uMsg As UInteger
        Public ReadOnly wParamL As UShort
        Public ReadOnly wParamH As UShort
    End Structure
End Class

@Yury Komar · 21.03.2020, 22:01

Возможность загрузки DLL библиотек из другой папки (не хранить рядом с EXE)

Название: Screenshot_1.png
Просмотров: 1706

Размер: 2.1 Кб

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
Imports System.Reflection
Imports MyDll
 
Public Class Form1
 
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Dim Domain As AppDomain = AppDomain.CurrentDomain
        AddHandler Domain.AssemblyResolve, AddressOf MyResolveEventHandler
        F()
    End Sub
    
    Private Sub F()
        Dim MyFunc As MyDll.GetData
        Dim result As String = MyFunc(Param)
    End Sub
    
    Function MyResolveEventHandler(ByVal sender As Object, ByVal args As ResolveEventArgs) As [Assembly]
        'Данная процедура(обработчик) вызывается только тогда, когда CLR не может подключить библиотеку(DLL).        
 
        'Получаем список всех библиотек в массив AssemblyName.
        Dim objExecutingAssemblies As [Assembly] : objExecutingAssemblies = [Assembly].GetExecutingAssembly()
        Dim arrReferencedAssmbNames() As AssemblyName : arrReferencedAssmbNames = objExecutingAssemblies.GetReferencedAssemblies()
 
        'Пробегаем по массиву подключенных библиотек.
        For Each strAssmbName As AssemblyName In arrReferencedAssmbNames
 
            'Ищем имя библиотеки, которое вызвало событие "AssemblyResolve".
            If strAssmbName.FullName.Split(",")(0) = args.Name.Split(",")(0) Then
 
                'Строим полный путь к библиотеке, откуда она должна быть загружена, в случае если она не зарегистрирована в системе.
                Dim strTempAssmbPath As String = String.Format("C:\assemblies\{0}.dll", args.Name.Split(",")(0))
                
                'Загружаем библиотеку по указанному выше пути.
                Dim MyAssembly As [Assembly] : MyAssembly = [Assembly].LoadFrom(strTempAssmbPath)
 
                'Возвращаем загруженную библиотку.
                Return MyAssembly
            End If
        Next
        Return Nothing
    End Function
End Class

@Yury Komar · 31.03.2020, 00:14

Убрать остаточный процесс WORD или EXCEL после отработки кода
(многие сталкиваются с такой проблемой, поэтому решил вынести в готовые решения)
Результат проверен многими, работает в 100% случаев:

1) Вынести функцию создания объекта, открытия и работы с Word или Excel в отдельный метод
2) На кнопке или в месте, где нужно его открыть и запустить обработку чего-то, ссылаться на метод-обертку, созданную в п.1
3) После отработки кода с офисным приложением и закрытии его программным способом в методе, созданном в п.1, в коде кнопки, самой последней строкой указать GC.Collect()
4) После чего, все переменные, которые отработали в том методе (п.1) будут = Nothing и при сборе мусора GC красиво и благополучно его закрывает, без всяких убийств процессов и тому подобного...

Пример вышеизложенного покажу кодом:

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
Sub Нажатие_Кнопки()
   Работа_с_Word_or_Excel()
   GC.Collect() ' и вот тут сборщик мусора уже выполняет работу по уничтожению всего, что лишнее.
End Sub
 
Sub Работа_с_Word_or_Excel()
  ' Открыли
  '  Поработали
  '   Закрыли
  ' (!) Обязательно все объекты App, Book, Sheet и т.п.   =  Nothing
  ' таким образом дав понять сборщику мусора, что объекты более нам ненужны
End Sub

greg zakharov · 07.04.2020, 22:58

Получение системной локали через NTAPI

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
Imports System.ComponentModel
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class Program
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    Friend Declare Function NtQueryDefaultLocale _
    Lib "ntdll.dll" ( _
      <MarshalAs(UnmanagedType.Bool)>ByVal ThreadOrSystem As Boolean, _
      ByRef Lcid As Int32 _
    ) As Int32 'NTSTATUS
    
    Friend Declare Function RtlLcidToLocaleName _
    Lib "ntdll.dll" ( _
      ByVal Locale As Int32, _
      ByRef LocaleName As UNICODE_STRING, _
      ByVal Flags As UInt32, _
      <MarshalAs(UnmanagedType.Bool)>ByVal AllocateDestinationString As Boolean _
    ) As Int32 'NTSTATUS
    
    Friend Declare Function RtlNtStatusToDosError _
    Lib "ntdll.dll" ( _
      ByVal Status As Int32 _
    ) As Int32
    
    Friend Declare Sub RtlFreeUnicodeString _
    Lib "ntdll.dll" ( _
      ByRef UnicodeString As UNICODE_STRING _
    )
  End Class
  
  <StructLayout(LayoutKind.Sequential, CharSet := CharSet.Unicode)>
  Friend Structure UNICODE_STRING
    Friend Length As UInt16
    Friend MaximumLength As UInt16
    <MarshalAs(UnmanagedType.LPWstr)> _
    Friend Buffer As String
  End Structure
  
  Shared Sub Main
    Dim lcid As Int32 = 0
    Dim nts As Int32 = NativeMethods.NtQueryDefaultLocale(False, lcid)
    
    If 0 <> nts Then
      Console.WriteLine(New Win32Exception(NativeMethods.RtlNtStatusToDosError(nts)).Message)
      Return
    End If
    
    Dim uni As New UNICODE_STRING()
    nts = NativeMethods.RtlLcidToLocaleName(lcid, uni, 0, True)
    
    If 0 <> nts Then
      Console.WriteLine(New Win32Exception(NativeMethods.RtlNtStatusToDosError(nts)).Message)
      Return
    End If
    
    Console.WriteLine("{0} : 0x{1:X}", uni.Buffer, lcid)
    NativeMethods.RtlFreeUnicodeString(uni) 'освобождаем выделенный буфер
  End Sub
End Class

greg zakharov · 08.04.2020, 18:06

Быстро определить тип системы: рабочая станция, сервер или lanman

Личное - за минимализм и эффективность. Именно этим критериям соответствует код ниже.

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class ProductType
  Friend Enum NT_PRODUCT_TYPE As UInt32
    NtProductWinNt = 1
    NtProductLanManNt = 2
    NtProductServer = 3
  End Enum
 
  Shared Sub Main
    Console.WriteLine([Enum].GetName(GetType(NT_PRODUCT_TYPE), _
                  Marshal.ReadInt32(CType(&H7FFE0264, IntPtr))))
  End Sub
End Class

Как оно работает и почему? Также как и в этом примере мы обращаемся к одному из полей структуры KUSER_SHARED_DATA, в данном случае - NtProductType (смещение 0х264). Вот и весь секрет.
Стоит сделать замечание об NTAPI'шной функции RtlNtGetProductType имеющей прототип

VB.NET
1
2
3
4
Friend Declare Function RtlGetNtProductType _
Lib "ntdll.dll" ( _
   ByRef ProductType As NT_PRODUCT_TYPE _
) As <MarshalAs(UnmanagedType.Bool)> Boolean

Она делает все то же, что и код выше, то есть через указатель забирает данные из той же структуры.
В качестве альтернативы можно залезть в реестр (HKLM\SYSTEM\CurrentControlSet\Control\Pr oductOptions, значение ProductType), однако это не всегда самый надежный метод хотя бы в виду различного рода политик, ограничивающих чтение данных или нечто в этом роде.

@MrCrown · 14.04.2020, 20:16

Не могу удержаться, чтобы не выложить здесь этот незамысловатый примерчик вычисления дат Пасхи по алгоритму Гаусса
Написано по материалам Википедии.

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
Public Class Form1
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        NumericUpDown1.Maximum = 2099
        NumericUpDown1.Minimum = Now.Year
    End Sub
 
    Private Sub NumericUpDown1_ValueChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles NumericUpDown1.ValueChanged
        Dim a, b, c, d, ee, f, year As Integer
        Dim date1, date2 As Date
 
        year = NumericUpDown1.Value
        a = year Mod 19
        b = year Mod 4
        c = year Mod 7
        d = (19 * a + 15) Mod 30
        ee = (2 * b + 4 * c + 6 * d + 6) Mod 7
        f = d + ee
 
 
        If f <= 26 Then
            date1 = New Date(year, 4, f + 4)
        Else
            date1 = New Date(year, 5, f - 26)
        End If
 
        date2 = date1.AddDays(9)
        Label1.Text = "Пасха: " & date1.ToLongDateString & " " & Format(date1, "dddd")
        Label2.Text = "Радоница: " & date2.ToLongDateString & " " & Format(date2, "dddd")
    End Sub
End Class

Новые блоги и статьи Все статьи Все блоги /
Саморегулирующийся социальный контракт для сервера cross-section. Hrethgir 14.08.2026 С кодом конечно таких глубоких размышлений пока не было, впрочем я уже привык к алгоритмизации. Суть предмета записи: снова в диалоге с нейросетью (я взял пока себе ник для учётки админа - Rector). . . .	Часы электронные Uhbif79 12.08.2026 Выкладываю программу часов. Программа позволяет: 1. Использовать системное время и дату, 2. Есть возможность вводить время и дату вручную. 3. Реализованы 2 будильника: начало и конец рабочего дня. . . .	Часы с будильником на основе класса QLCDNumber Uhbif79 12.08.2026 Всем добрый день, выкладываю программу часов с будильником на основе класса QLCDNumber. Здесь я пробовал самостоятельно создавал классы, впервые столкнулся с видимостью переменной одного класса из. . .	Установка MinGW GCC 16.2 и CMake 8Observer8 10.08.2026 VK Видео: https:/ / vkvideo. ru/ video-240781534_456239017 YouTube: eY5-5PyI9NM Текстовая версия
Неделя из жизни имитационной модели склада: мои кривые руки растут, откуда надо anaschu 10.08.2026 Неделя из жизни имитационной модели склада: как я почти написал неправильную логику и что с этим делать Работаю сейчас над учебно-рабочим проектом: строю в AnyLogic имитационную модель процессов. . .	Калькулятор для расчета родства russiannick 07.08.2026 1. Задача: Создать калькулятор для расчета родства. Родственных связей существует 8 ступеней, такие как: p - отец P - мать q - муж Q - жена b - брат B - сестра s - сын S - дочь	Мир по моей воле kumehtar 07.08.2026 Когда-то кажется, что всё просто. Ты весь такой светлый. Причиняешь добро. Борешься за справедливость в этом тёмном мире. Потом начинаешь замечать одну неприятную вещь. Почти каждый хороший. . .	Кредитный калькулятор Maks 05.08.2026 Решение задачи по прикладной информатике средствами 1С. Задача: Напишите приложение-калькулятор, которое помогает рассчитывать параметры кредита для аннуитетного и дифференцированного видов. . .

@Yury Komar Модератор 4372 / 3442 / 512 Регистрация: 27.01.2014 Сообщений: 6,266
	19.06.2019, 06:43
	Таблица цветов в .NET Полезно визуально видеть цвет, его имя и HEX-значение цвета. Миниатюры 17