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

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

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

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

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

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

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

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

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

@Маршинин · 20.02.2013, 05:25

Командная строка на форме Windows!

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

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
Imports System.Runtime.InteropServices
Imports System.Text
Public Class Form1
    Private WithEvents MyProcess As Process
    Private Delegate Sub AppendOutputTextDelegate(ByVal text As String)
    Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
        MyProcess.StandardInput.WriteLine("EXIT") 'Отпровляем запрос закрытия
        MyProcess.StandardInput.Flush()
        MyProcess.Close()
    End Sub
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Me.AcceptButton = Button1
        MyProcess = New Process
        With MyProcess.StartInfo
            .FileName = "C:\Windows\system32\cmd.EXE"
            .UseShellExecute = False
            .CreateNoWindow = True
            .RedirectStandardInput = True
            .RedirectStandardOutput = True
            .RedirectStandardError = True
        End With
        MyProcess.Start()
        MyProcess.BeginErrorReadLine()
        MyProcess.BeginOutputReadLine()
        AppendOutputText("Процесс запусчен: " & MyProcess.StartTime.ToString)
    End Sub
 
    Private Sub MyProcess_OutputDataReceived(sender As Object, e As DataReceivedEventArgs) Handles MyProcess.OutputDataReceived 'Оброботка обычных ответов (Статитческих)
        AppendOutputText(vbCrLf & Encoding.Default.GetString(Encoding.Convert(Encoding.GetEncoding(866), Encoding.Default, Encoding.Default.GetBytes(e.Data))))
    End Sub
 
    Private Sub MyProcess_ErrorDataReceived(ByVal sender As Object, ByVal e As System.Diagnostics.DataReceivedEventArgs) Handles MyProcess.ErrorDataReceived 'Оброботка ошибок и потоковых данных(Пример:загрузка какой либо игры через консоль)
        AppendOutputText(vbCrLf & "Error: " & vbCrLf & Encoding.Default.GetString(Encoding.Convert(Encoding.GetEncoding(866), Encoding.Default, Encoding.Default.GetBytes(e.Data))))
    End Sub
 
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        MyProcess.StandardInput.WriteLine(TextBox1.Text)
        MyProcess.StandardInput.Flush()
        TextBox1.Text = ""
    End Sub
    Private Sub AppendOutputText(ByVal text As String)
        Invoke(Sub()
                   TextBox2.AppendText(text) 'Добавление в строку для показа пользователю
               End Sub)
    End Sub
End Class

@Юпатов Дмитрий · 04.03.2013, 21:34

Получение почты по протоколу POP3.
Создадим класс POP3.vb

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

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
Public Class Pop3
       ' ----- The default TCP/IP port number for POP3 is 110.
       Public Port As Integer = 110
       Public Messages As Integer = 0
 
       Private Const CommandFailure As String = "-ERR"
 
       Private Pop3Server As TcpClient
       Private CommandSender As NetworkStream
       Private ContentReceiver As StreamReader
 
       Public Sub Connect(ByVal serverName As String, _
             ByVal userName As String, ByVal password As String)
          ' ----- Initiate the connection to a POP3 server.
          Dim commandData As String
          Dim contentBuffer() As Byte
          Dim responseString As String
          Dim parts() As String
 
          ' ----- Connect to the POP3 server.
          Try
             Pop3Server = New TcpClient(serverName, Port)
             CommandSender = Pop3Server.GetStream()
             ContentReceiver = New StreamReader(CommandSender)
          Catch
             Throw
          End Try
 
          If (userName <> "") Then
             ' ----- Authenticate with the user ID.
             commandData = "USER " & userName & vbCrLf
             contentBuffer = _
                System.Text.Encoding.ASCII.GetBytes( _
                commandData.ToCharArray())
             CommandSender.Write(contentBuffer, 0, _
                contentBuffer.Length)
             responseString = ContentReceiver.ReadLine()
             If (Left(responseString, Len(CommandFailure)) = _
                   CommandFailure) Then
                Throw New Exception("Invalid user name.")
             End If
 
             ' ----- Send the authenticating password.
             commandData = "PASS " & password & vbCrLf
             contentBuffer = _
                System.Text.Encoding.ASCII.GetBytes( _
                commandData.ToCharArray())
             CommandSender.Write(contentBuffer, 0, _
                contentBuffer.Length)
             responseString = ContentReceiver.ReadLine()
             If (Left(responseString, Len(CommandFailure)) = _
                   CommandFailure) Then
                Throw New Exception("Invalid password.")
             End If
          End If
 
          ' ----- Logged in. On some servers, the PASS command
          '       is not enough to push the server into a
          '       transaction state. Send a STAT command twice.
          commandData = "STAT" + vbCrLf
          contentBuffer = System.Text.Encoding.ASCII.GetBytes( _
             commandData.ToCharArray())
          CommandSender.Write(contentBuffer, 0, _
             contentBuffer.Length)
          responseString = ContentReceiver.ReadLine()
 
          ' ----- Get a count of the messages.
          commandData = "STAT" + vbCrLf
          contentBuffer = System.Text.Encoding.ASCII.GetBytes( _
             commandData.ToCharArray())
          CommandSender.Write(contentBuffer, 0, _
             contentBuffer.Length)
          responseString = ContentReceiver.ReadLine()
          If (Left(responseString, Len(CommandFailure)) = _
                CommandFailure) Then
             Throw New Exception( _
                "Could not retrieve message count.")
          End If
 
          ' ----- The response includes two integers: a count
          '       and a size, separated by a space. Skip over
          '       the "+OK" part also.
          parts = Split(responseString, " ")
          Messages = Val(parts(1))
       End Sub
 
       Public Sub Disconnect()
          ' ----- Disconnect from the  
POP3 server.
          Dim commandData As String
          Dim contentBuffer() As Byte
          Dim responseString As String
 
          ' ----- Tell the server we're through.
          commandData = "QUIT" & vbCrLf
          contentBuffer = System.Text.Encoding.ASCII.GetBytes( _
             commandData.ToCharArray())
          CommandSender.Write(contentBuffer, 0, _
             contentBuffer.Length)
          responseString = ContentReceiver.ReadLine()
 
          ' ----- End the connection.
          ContentReceiver.Close()
          CommandSender.Close()
           
Pop3Server.Close()
       End Sub
 
       Function GetMessage(ByVal whichMessage As Integer) _
             As String
          ' ----- Retrieve a single email message.
          Dim commandData As String
          Dim contentBuffer() As Byte
          Dim responseString As String
          Dim theMessage As New System.Text.StringBuilder
          Dim oneLine As String
 
          ' ----- Check for an invalid message.
          If (whichMessage < 1) Or (whichMessage > Messages) Then
             Throw New ArgumentOutOfRangeException(whichMessage, _
                "Messages are numbered from 1 to the number " & _
                "identified by the Messages property.")
          End If
 
          Try
             ' ----- Request the message.
             commandData = "RETR " & whichMessage & vbCrLf
             contentBuffer = _
                System.Text.Encoding.ASCII.GetBytes( _
                commandData.ToCharArray())
             CommandSender.Write(contentBuffer, 0, _
                contentBuffer.Length)
             responseString = ContentReceiver.ReadLine()
             If (Left(responseString, Len(CommandFailure)) = _
                   CommandFailure) Then
                Throw New Exception("Message retrieval failed.")
             End If
 
             ' ----- The message is all data until a line with
             '       a single dot (.) appears.
             Do While (ContentReceiver.EndOfStream = False)
                oneLine = ContentReceiver.ReadLine()
                If (oneLine = ".") Then Exit Do
                theMessage.AppendLine(oneLine)
             Loop
          Catch ex As InvalidOperationException
             MsgBox("Message retrieval failed: " & ex.Message)
          End Try
 
          ' ----- Return the constructed message.
          Return theMessage.ToString()
       End Function
    End Class

Он у нас будет отвечать за получение списка писем с сервера и показ тела выбранного письма.
Теперь форма, см. рисунок "Форма1"
На ней:
three TextBox controls named . Set the UserPassword control's PasswordChar field to the asterisk character (*). Add a ListBox control named MessageList and two Button controls named ActGet and ActView. Set the Button controls' Text properties to Get Messages and View Message, respectively. Add informational labels if desired

3 TextBox с именами ServerName, UserName и UserPassword. Установите свойство PasswordChar последнего равным *. Добавьте ListBox с именем MessageList и 2 кнопки с именами ActGet и ActView. Установите свойство Text у кнопок равным Get Messages и View Message соответственно. По желанию добавьте метки (label) с пояснениями.
Полный код формы:

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

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
Private POP3Connection As Pop3 = Nothing
 
    Private Sub ActGet_Click(ByVal sender As System.Object, _
          ByVal e As System.EventArgs) Handles ActGet.Click
       ' ----- Initiate a POP3 connection.
       Dim counter As Integer
 
       ' ----- First, disconnect any previous connection.
       If (POP3Connection IsNot Nothing) Then
          Try
             POP3Connection.Disconnect()
          Catch ex As Exception
             ' ----- Ignore.
          End Try
       End If
       POP3Connection = Nothing
 
       ' ----- Clear any previous messages.
       MessageList.Items.Clear()
 
       ' ----- Try the new connection.
       Try
           
POP3Connection = New Pop3
          POP3Connection.Connect(ServerName.Text, _
             UserName.Text, UserPassword.Text)
       Catch ex As Exception
          MsgBox("Connection failure: " & ex.Message)
          POP3Connection = Nothing
          Return
       End Try
 
       ' ----- How many messages?
       If (POP3Connection.Messages = 0) Then
          MsgBox("No messages found.")
          POP3Connection.Disconnect()
          POP3Connection = Nothing
          Return
       End If
 
       ' ----- Show each message.
       For counter = 1 To POP3Connection.Messages
          MessageList.Items.Add("Message Number " & counter)
       Next counter
    End Sub
 
    Private Sub ActView_Click(ByVal sender As System.Object, _
          ByVal e As System.EventArgs) Handles ActView.Click
       ' ----- Show a message.
       Dim whichMessage As Integer
       Dim parts As String()
       Dim content As String
 
       ' ----- Which message? Each item has the format:
       '          Message Number x
       If (MessageList.SelectedIndex = -1) Then Return
       parts = Split(CStr(MessageList.SelectedItem), " ")
       whichMessage = CInt(Val(parts(2)))
 
       ' ----- Get the content.
       content = POP3Connection.GetMessage(whichMessage)
 
       ' ----- Show the content.
       MsgBox(content)
    End Sub
 
    Private Sub MessageList_DoubleClick(ByVal sender As Object, _
          ByVal e As System.EventArgs) _
          Handles MessageList.DoubleClick
       ' ----- Same as the View button.
       ActView.PerformClick()
    End Sub
 
    Private Sub Form1_FormClosing(ByVal sender As Object, _
          ByVal e As System.Windows.Forms.FormClosingEventArgs) _
          Handles Me.FormClosing
       ' ----- Disconnect before leaving.
       On Error Resume Next
 
       If ( 
POP3Connection IsNot Nothing) Then
          POP3Connection.Disconnect()
          POP3Connection = Nothing
       End If
    End Sub

В итоге письма мы сможем увидеть в текстовом представлении. В том числе и вложения там будут в виде строки в кодировке Base64.
В целом рекомендую почитать и поизучать формат файлов .mht - именно в нем тело письма представлено. Добраться в него можно через класс CDO. Но это уже отдельная история (сам разбираюсь понемногу...)
Код не мой, но рабочий - проверено. Взят из книги: Visual Basic 2005 Cookbook (By John Clark Craig, Tim Patrick).
Для страждущих - книга приложена в архиве

@MLF · 09.03.2013, 08:10

Сообщение от Памирыч

VB.NET
1
2
3
4
        ..
        Dim VB As New VBCodeProvider()
        Dim Compiler As ICodeCompiler = VB.CreateCompiler()
        ..

Студия ругается на устаревший код. Следуя рекомендациям msdn поправил:

VB.NET
1
        Dim Compiler As VBCodeProvider = CodeDomProvider.CreateProvider("VB")

а первую строку можно удалить)

@Pe4eNEG · 09.04.2013, 01:33

Восстанавливаем "потерянную" библиотеку или файл из приложения:
Предварительно этот файл нужно добавить в ресурсы приложения.

VB.NET
1
2
3
4
5
6
7
8
9
Imports System.IO
Public sub dllRestore() 
        Dim _DllFIle As FileInfo = New FileInfo(My.Application.Info.DirectoryPath & "\имя_библиотеки_или_файла.dll")
        If _DllFIle.Exists = False Then
            MsgBox("Один из компонентов приложения отсутствует, нажмите ОК для восстановления и перезапуска", MsgBoxStyle.Information, "Восстановление программы")
            File.WriteAllBytes(My.Application.Info.DirectoryPath & "\имя_библиотеки_или_файла.dll", My.Resources.имя_библиотеки_или_файла)
             Application.Restart()  'если нужно перезапускаем приложение.    
        End If
    End Sub

@Gemorg · 10.06.2013, 16:19

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

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
Public Class CShadow
 
    'Автор: Григорий Ляпин
    'Распространение свободное, модификация разрешена
 
    Dim _s As Integer
    Dim cnt As Control
 
    Public Sub New(ByVal _Object As Control, ByVal smesh As Integer)
        AddHandler _Object.Paint, AddressOf _Paint
        _s = smesh
        cnt = _Object
    End Sub
 
    Public Property SR() As Integer
        Get
            Return _s
        End Get
        Set(ByVal value As Integer)
            _s = value
            cnt.Invalidate()
        End Set
    End Property
 
    Private Sub _Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs)
 
        e.Graphics.SmoothingMode = Drawing2D.SmoothingMode.AntiAlias
 
        For i = 0 To cnt.Controls.Count - 1
 
            Dim r As Rectangle
            r.Location = New Point(cnt.Controls(i).Location.X + _s, _
                                   cnt.Controls(i).Location.Y + _s)
            r.Size = cnt.Controls(i).Size
 
            e.Graphics.FillRectangle(Brushes.LightGray, r)
 
        Next
 
    End Sub
 
End Class

Как использовать:
Добавить в тело класса/событие/куда хотите вот этот код:

VB.NET
1
Dim shadow As New CShadow(Me, 5)

@Farzy · 21.06.2013, 21:25

Функция для проверки прокси :

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
 Dim item As String = "прокси"
 Try
                With CreateObject("MSXML2.ServerXMLHTTP.6.0")
                    .setProxy(2, item)
                    .Open("GET", "http://internet.yandex.ru/", False)
                    .setTimeouts(2000, 2000, 3000, 2000)
                    .send("")
                End With
                TextBox4.AppendText(vbNewLine & "[Works]> " & item)
            Catch ex As Exception
                TextBox4.AppendText(vbNewLine & "[Exception]>" & item)
            End Try

@AeroWhite · 24.06.2013, 09:41

Альтернативная отправка писем на E-mail

Сверху проекта подключаем:

VB.NET
1
2
Imports System.Net.Mail
Imports System.Text

А дальше располагаем код на свою кнопку:

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
        Dim EMail As New MailMessage
        Dim Smtp As SmtpClient
        Smtp = New SmtpClient("smtp.yandex.ru")
        Smtp.Port = 587
        Smtp.Credentials = New Net.NetworkCredential("Кто@отправляет.ru", "Пароль") 'Данные Вашей почты
        EMail.From = New MailAddress("Кто@отправляет.ru", Subject.Text) ' Subject.Text здесь для красоты, по желанию можно убрать
        EMail.To.Add(New MailAddress("Кому@отправляем.ru"))
        EMail.Body = Message.Text 'Основной текст
        EMail.Subject = Subject.Text 'Тема письма
        Try
            Smtp.Send(EMail)
            MsgBox("Ваше сообщение отправлено. Спасибо!", MsgBoxStyle.Information)
        Catch ex As Exception
            MsgBox("Ваше сообщение не было отправлено. Пожалуйста, повторите попытку", MsgBoxStyle.Critical)
        End Try

+ красивое прикрепление файлов в архиве

@Gemorg · 24.06.2013, 21:08

Загрузка DLL из ресурсов
Исходная статья для C#

1) Включаем "Показывать все файлы" в Обозревателе решений

2) Добавляем ссылку на библиотеку. Клик правой кнопкой мыши по "Ссылки" в обозревателе решений -> Добавить ссылку... -> Во вкладке "Обзор" выбрать вашу библиотеку -> ОК

3)Открываем список "Ссылки" -> Кликаем по пункту с названием нашей библиотеки -> В окне "Свойства" для параметра "Копировать локально" ставим False

4)Добавляем в ресурсы файл *.dll. В меню Проект > Свойства > Ресурсы > Добавить ресурс > выбираем снова нашу длл (либо сжатую длл архиватором)> Ok. Всё теперь появится в проекте папка Resources. Следите чтобы у ресурсов стояла опция "Копировать в выходной каталок" в положении "Не копировать".

5) Открываем список My Project -> открываем список MyApplication.myapp -> Двойной клик по Application.Designer.vb"

6) Находим класс "MyApplication" -> процедуру "New" заменяем на:

VB.NET
1
2
3
4
5
6
7
8
9
Public Sub New()
      MyBase.New(Global.Microsoft.VisualBasic.ApplicationServices.AuthenticationMode.Windows)
      Me.IsSingleInstance = false
      Me.EnableVisualStyles = true
      Me.SaveMySettingsOnExit = true
      Me.ShutDownStyle = Global.Microsoft.VisualBasic.ApplicationServices.ShutdownMode.AfterMainFormCloses
      'А точнее, добавляем следующую строка
      AddHandler AppDomain.CurrentDomain.AssemblyResolve, AddressOf LoadDLL
End Sub

7) После процедуры "New" добавляем следующую функцию:

VB.NET
1
2
3
4
5
6
Private Function LoadDLL(ByVal sender As Object, ByVal arg As System.ResolveEventArgs) As Reflection.Assembly
      If arg.Name.Contains("Dll_Reference_Name") Then
          Return Reflection.Assembly.Load(My.Resources.DLL_FILE_NAME)
      End If
      Return Nothing
End Function

8) Если вы используете .NET Framework 4.5+, то можно упаковать DLL в ZIP и загрузить ее из архива
Для этого используйте следующую функцию

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
 '(Для упакованной в ZIP (.NET Framework 4.5+))
 'ссылку на IO.Compression нужно добавлять вручную в проект из GAC
 '------------------------------------------------------------------------------------------------
 Private Function LoadDll_ZIP(ByVal sender As Object, ByVal arg As System.ResolveEventArgs) As Reflection.Assembly
     'Dll_Reference_Name - точно такое же название, которое используете в Import.
     'ZIPDLL - это название нашего архива с DLL-ками в ресурсах
 
     Dim file_ As IO.Compression.ZipArchive
 
     'Здесь, если вы в один архив поместили несколько DLL
     'то код найдет нужную внутри архива и загрузит
     'Dll_Reference_Name1 и Dll_Reference_Name2 - это разные файлы DLL внутри архива
     Select Case True
         Case arg.Name.Contains("Dll_Reference_Name1")
             file_ = New IO.Compression.ZipArchive(New IO.MemoryStream(My.Resources.ZIPDLL))
             For Each entry In file_.Entries
                 If entry.Name.StartsWith("Dll_Reference_Name1") Then
                     Return Reflection.Assembly.Load(New IO.BinaryReader(entry.Open).ReadBytes(CInt(entry.Length)))
                 End If
             Next
 
         Case arg.Name.Contains("Dll_Reference_Name2")
             file_ = New IO.Compression.ZipArchive(New IO.MemoryStream(My.Resources.ZIPDLL))
             For Each entry In file_.Entries
                 If entry.Name.StartsWith("Dll_Reference_Name2") Then
                     Return Reflection.Assembly.Load(New IO.BinaryReader(entry.Open).ReadBytes(CInt(entry.Length)))
                 End If
             Next
     End Select
 
     Return Nothing
 End Function

Dll_Reference_Name - точно такое же название, которое используете в Import.
DLL_FILE_NAME - название файла в ресурсах

Все, Теперь можно не таскать DLL за своей программой

@viabcua · 28.06.2013, 14:05

Код довольно простой (на картинке для примера фон картинка, цвет фона красный)

VB.NET
1
2
3
4
5
6
7
 
        Label2.Parent = Me
        Label2.BackColor = Color.Transparent
        CheckBox2.Parent = Me
        CheckBox2.PictureBox2
        PictureBox2.Parent = Me
        PictureBox2.BackColor = Color.Transparent

В свойствах Parent указываем элемент над которым будут размещен наш контролл, ну и его BackColor = Color.Transparent. Например

VB.NET
1
2
        Label2.Parent = PictureBox2 ' или Ме как в первом примере 
        Label2.BackColor = Color.Transparent

@АББА · 09.07.2013, 23:33

Жемчужина примеров кода VB.NET 10 в Visual Studio 2010.

1). Вставка фрагмента кода IntelliSense...
Использование этих фрагмента кода даёт нам возможность чтобы, сэкономить время на изучение примеров, использование незнакомых возможностей и повторного использования ондного итого же кода.
Ещё одно преимущество этой возможности добавлять свои фрагменты кода, это легко сделать в меню Сервис\Диспетчер фрагментов кода...(или же Ctrl+K,Ctrl+B).
Вставка фрагмента кода в окне редактора кодов. Выберите нужную позицию курсора в окне редактора кода, затем контекст меню а там "Вставить фрагмент..." (или Ctrl+K,Ctrl+X).

2). Примеры приложений на Visual Basic.NET
В этом сборнике рецептов представлены примеры Visual Basic.NET, поставляемые в составе пакета Visual Studio 2010. Это сборный пакет программ, демонстрирующий функции Visual Studio 2010. Сборник находится в VBSample.zip архив его нужно сначала разархивировать (после открываем файл ReadMe.html - здесь описаны все примеры и добавлена ссылка к ним), по умолчанию она находистся здесь:
диск на которой VS2010 установлена: \Program Files\Microsoft Visual Studio 10.0\Samples\1049\

Разделы этого примера.

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

-Примеры приложений
-Примеры данных
-Примеры языков
-Примеры LINQ
-Примеры настройки безопасности
-Примеры компонентов серверов
-Примеры планшетных ПК
-Примеры WCF
-Примеры Winform

@gitarillo · 10.07.2013, 11:24

В следующем примере хочу продемонстрировать как можно выполнять пинг определенного хоста с заданным интревалом в отдельном потоке без таймера и не зависая приложения. Изначально делал на C#, но решил переписать и на VB.NET.
Сначала о структуре приложения.
1) Класс PingNet - для реализации определения пинга
2) Класс GlobalCl - для хранения глобальных переменных
3) Класс Form1 - формочка с листвью и элементами для установки параметров.

Начнем с класса PingNet

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

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
''' <summary>
'''  Реализует простой пинг хоста
''' </summary>
''' <remarks></remarks>
Public Class PingNet
 
    Public Delegate Sub CallBack(ByVal P As PingNet) ' делегат для функции обратного вызова
    Public Event PingStateChange As EventHandler ' событие, возникающее при изменения состояния пинга
    ''' <summary>
    ''' Качество пинга
    ''' </summary>
    ''' <remarks></remarks>
    Public Enum PingState
        ''' <summary>
        ''' Пинг хороший
        ''' </summary>
        ''' <remarks></remarks>
        GOOD
        ''' <summary>
        ''' Средний пинг
        ''' </summary>
        ''' <remarks></remarks>
        MIDDLE
        ''' <summary>
        ''' Плохой пинг
        ''' </summary>
        ''' <remarks></remarks>
        POOR
        ''' <summary>
        ''' Пинга нет 
        ''' </summary>
        ''' <remarks></remarks>
        NOTPING
    End Enum
 
    Private pState As PingState ' текущее состояние пинга
    Private adrs As String ' адрес пингуемого хоста
    Private err As String ' текст ошибки при пинге
    Private ping As Long ' величина пинга
    Private cl As CallBack ' экземпляр делегата функции обратного вызова
 
 
    ''' <summary>
    ''' Констуктор класса
    ''' </summary>
    ''' <param name="addressHost">Адрес хоста или IP</param>
    ''' <param name="fn">Делегат функции обратного вызова</param>
    ''' <remarks></remarks>
    Public Sub New(ByVal addressHost As String, ByVal fn As CallBack)
        Me.adrs = addressHost
        Me.cl = fn
    End Sub
 
    ''' <summary>
    ''' Определение состояния пинга
    ''' </summary>
    ''' <remarks></remarks>
    Private Sub getStatePing()
        If (Me.ping < 0) Then
            Me.pState = PingState.NOTPING
        ElseIf (Me.ping >= 0 And Me.ping <= 11) Then
            Me.pState = PingState.GOOD
        ElseIf (Me.ping > 11 And Me.ping <= 100) Then
            Me.pState = PingState.MIDDLE
        Else
            Me.pState = PingState.POOR
        End If
 
        RaiseEvent PingStateChange(Me, New EventArgs) ' генерация события (издание)
 
    End Sub
 
 
    ''' <summary>
    ''' Возвращает текущее состояние пинга
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public ReadOnly Property PING_STATE() As PingState
        Get
            Return Me.pState
        End Get
    End Property
 
    ''' <summary>
    '''  Возвращает величину пинга
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public ReadOnly Property CUR_PING()
        Get
            Return Me.ping
        End Get
    End Property
 
    ''' <summary>
    '''  Получение пинга
    ''' </summary>
    ''' <remarks></remarks>
    Public Sub checkPing()
        Me.err = "" ' очистка текста ошибки
        Try
            Dim p As New System.Net.NetworkInformation.Ping() ' получаем пинг
            Me.ping = p.Send(Me.adrs).RoundtripTime
        Catch ex As Exception ' в случае ошибки возращаем -1 и записываем текст ошибки
            err = ex.Message
            ping = -1
        End Try
        getStatePing() ' запуск определения качества пинга
    End Sub
 
    ''' <summary>
    '''  Текущий адрес пингуемого хоста
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public Property Address() As String
        Get
            Return Me.adrs
        End Get
        Set(ByVal value As String)
            Me.adrs = value
        End Set
    End Property
 
    ''' <summary>
    '''  Ошибка при выполнении пинга
    ''' </summary>
    ''' <value></value>
    ''' <returns></returns>
    ''' <remarks></remarks>
    Public ReadOnly Property Error_ping() As String
        Get
            Return Me.err
        End Get
    End Property
 
 
    ''' <summary>
    '''  Инициализатор метода обратного вызова
    ''' </summary>
    ''' <remarks></remarks>
    Public Sub Start()
        If (cl IsNot Nothing) Then
            cl(Me)
        End If
    End Sub
 
End Class

В принципе в коде все написано. В комментария каких-то дополнительных я думаю он не нуждается

Класс GlobalCl

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

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
''' <summary>
''' Вспомогательный класс
''' </summary>
''' <remarks></remarks>
Public Class GlobalCl
    Public Shared trh As Threading.Thread ' поток в котором будет выполняться пинг
    Public Shared pn As PingNet ' экземпляр нашего вспомогательного класса
    Public Shared intr As Integer = 5 ' дефолтовый интревал пинга
    ''' <summary>
    ''' Статический конструктор класса (вызывается один раз при первом обращении)
    ''' Инициализирует переменные
    ''' </summary>
    ''' <remarks></remarks>
    Shared Sub New()
        pn = New PingNet("yandex.ru", AddressOf pingInList) ' по умолчанию пингуем яндекс
        trh = New Threading.Thread(New Threading.ThreadStart(AddressOf pn.Start)) ' создаем новый поток
        trh.Start() ' запускаем его
    End Sub
 
    ''' <summary>
    ''' Это метод обратного вызова для класса PingNet
    ''' </summary>
    ''' <param name="P">Экземпляр класса</param>
    ''' <remarks></remarks>
    Private Shared Sub pingInList(ByVal P As PingNet)
        ' бесконечный цикл
        While True
            P.checkPing() ' запуск метода получения пинга
            Threading.Thread.Sleep(intr * 1000) ' задержка потока на заданный интервал
        End While
    End Sub
End Class

В нем есть статические переменные, которые инициализируются в статическом конструкторе, и больше нигде. Как видно это переменная потока. Конструктору передается адрес функции pn.Start, которая инициализирует метод обратного вызова для pn. Он то и выполняет бесконечную проверку в отдельном потоке, запуская метод класса checkPing.

Класс формы.

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

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
Public Class Form1
    Public Delegate Sub PingOut(ByVal P As PingNet) ' делегат для вывода строки 
    Private pout As PingOut ' экземпляр делегата
    ''' <summary>
    ''' Конструктор формы
    ''' </summary>
    ''' <remarks></remarks>
    Public Sub New()
        InitializeComponent()
 
        AddHandler GlobalCl.pn.PingStateChange, AddressOf Hoock_change_Ping ' подписываемся на событие изменения состояния пинга
        pout = New PingOut(AddressOf printItem) ' инициализируем экземпляр делегата вывода текущего состояния пинга
    End Sub
 
    ' Обработчик события из менения состояния пинга
    Private Sub Hoock_change_Ping(ByVal sender As Object, ByVal e As EventArgs)
        ListView1.Invoke(pout, New Object() {CType(sender, PingNet)}) ' доступ к элементу из другого потока
    End Sub
 
    ''' <summary>
    ''' Метод вывода очередной записи пинга
    ''' </summary>
    ''' <param name="P">Экземпляр класса PingNet</param>
    ''' <remarks></remarks>
    Private Sub printItem(ByVal P As PingNet)
        Dim i As Long = P.CUR_PING ' получаем значение пинга в переменную
 
        ' здесь все понятно просто постолбцовый вывод
        ListView1.Items.Add((ListView1.Items.Count + 1).ToString()).SubItems.Add(P.Address)
        ListView1.Items(ListView1.Items.Count - 1).SubItems.Add(i.ToString())
        ListView1.Items(ListView1.Items.Count - 1).SubItems.Add(DateTime.Now.ToString())
        ListView1.Items(ListView1.Items.Count - 1).SubItems.Add(P.Error_ping)
 
        ' обработка результата для цветововй визуализации
        Select Case P.PING_STATE
            Case PingNet.PingState.POOR, PingNet.PingState.NOTPING
                Me.ListView1.Items(Me.ListView1.Items.Count - 1).BackColor = Color.Red
            Case PingNet.PingState.MIDDLE
                Me.ListView1.Items(Me.ListView1.Items.Count - 1).BackColor = Color.Yellow
            Case PingNet.PingState.GOOD
                Me.ListView1.Items(Me.ListView1.Items.Count - 1).BackColor = Color.Green
 
        End Select
 
        ' делаем чтобы показывалось всегда нижнее
        Me.ListView1.Items(Me.ListView1.Items.Count - 1).Selected = True
        Me.ListView1.Items(Me.ListView1.Items.Count - 1).EnsureVisible()
    End Sub
 
    ' задаем новые параметры
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        GlobalCl.intr = NumericUpDown1.Value
        GlobalCl.pn.Address = TextBox1.Text
    End Sub
 
 Private Sub Form1_FormClosing(ByVal sender As System.Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles MyBase.FormClosing
        GlobalCl.trh.Abort() ' завершение потока
    End Sub
End Class

В форме мы подписываемся на событие изменения состояния пинга и создаем его обработчик Hoock_change_Ping. В этом обработчике методом Invoke происходит реализация доступа к элементу из разных потоков. Метод принимает делегат, который говорит какой метод нужно вызывать и массив передаваемых параметров. Делегат pout инкапсулирует ссылку на метод printItem. В нем идет вывод очередной позиции с информацией в листвью и окрашивание строк в зависимости от состояний пинга. Состояния задаются в классе PingNet. Там можно отрегулировать на свой вкус или задать интерфейс для установки.
Также подписывайтесь на событие изменения состояния пинга с других форм. Испольуйте нужным образом.
P.S: Код писАл полностью сам. Разумеется версию упростил. Дорабатывайте на свое усмотрение. Проект прилагаю, скрины тоже.

@АББА · 14.07.2013, 00:25

Управление положением формы.
на примере мини гаджет а "Cyber Gadget"

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

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
Public Class Form1
    Public h As Integer = My.Computer.Screen.WorkingArea.Height 'Полчение высоты рабочего места 
    Public w As Integer = My.Computer.Screen.WorkingArea.Width 'Полчение ширины рабочего места
 
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        'Некоторые свойства формы которые изменены вручную
        'Me.FormBorderStyle = Windows.Forms.FormBorderStyle.None
        'Me.Opacity = 0.95 'Для красоты
        'Me.ShowInTaskbar =False 
        Dim pt As New Point((w - Me.Width), 0) 'Созадние новой точки местонахождения формы
        Me.Height = h
        Me.Location = pt
    End Sub
    '
    'Элементы которые надятся на угле формы (_ x >)
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Timer1.Enabled = True
    End Sub
    Private Sub Button3_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button3.Click
        Me.Close()
    End Sub
 
    Private Sub Button4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
        Me.Hide()
    End Sub
    '*************
 
    'Элементы которые надятся на Panel1 (< x _)
    Private Sub Button2_Click_1(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        Timer2.Enabled = True
    End Sub
 
    Private Sub Button5_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button5.Click
        Me.Close()
    End Sub
 
    Private Sub Button6_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
        Me.Hide()
    End Sub
    '*************
 
    Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
        'Скрытие формы
        While Me.Location.X < (w - 25)
            Dim pt As New Point((Me.Location.X + 3), 0)
            Me.Location = pt
            Me.Opacity = Me.Opacity - 0.009 'эффект плавной прозрачности
        End While
        Timer1.Enabled = False
        Panel1.Visible = True
    End Sub
 
    Private Sub Timer2_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer2.Tick
        'Восстановление формы на исходное место
        While Me.Location.X > (w - Me.Width)
            Dim pt As New Drawing.Point((Me.Location.X - 3), 0)
            Me.Location = pt
            Me.Opacity = Me.Opacity + 0.009 'эффект плавной прозрачности
        End While
        Timer2.Enabled = False
        Panel1.Visible = False
 
    End Sub
       
End Class

@Spread · 19.07.2013, 22:13

Подсветка синтаксиса как в редакторах.

Весь код для вставки:

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
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
Imports System.Text.RegularExpressions
Imports System.Drawing.Drawing2D
Imports System.Drawing.Printing
Imports System.Net.Mime.MediaTypeNames
Public Class Form1
 
#Region " [APIs] "
    Public Declare Function LockWindowUpdate Lib "user32" (ByVal hWnd As IntPtr) As Integer
#End Region
#Region " [Classes] "
#Region " [WordList] "
    Public Class WordList
#Region " [Variables] "
        Public _cColor As New List(Of Color)
        Public _sWord As New List(Of String)
        Public rRegex As New List(Of Regex)
#End Region
#Region " [Functions] "
#Region " [Add] "
        Public Sub Add(ByVal sWord As String, ByVal cColor As Color, ByVal bUseWordBoundary As Boolean)
            _sWord.Add(sWord)
            _cColor.Add(cColor)
            Dim sNewWord As String = sWord
            If bUseWordBoundary Then
                sNewWord = "\b" & sWord & "\b"
            End If
            rRegex.Add(New Regex(sNewWord, RegexOptions.Compiled Or RegexOptions.IgnoreCase))
        End Sub
#End Region
#Region " [GetColor] "
        Public Function GetColor(ByVal iIndex As Integer) As Color
            Return _cColor(iIndex)
        End Function
#End Region
#Region " [Length] "
        Public Function Length() As Integer
            Return rRegex.Count
        End Function
#End Region
#Region " [GetWord] "
        Public Function GetWord(ByVal iIndex As Integer) As String
            Return _sWord(iIndex)
        End Function
#End Region
#End Region
    End Class
#End Region
#End Region
#Region " [Variables] "
    Public wlWordList As New WordList()
    Public cComments As Color = Color.Green
    Public rComments As New Regex("'")
    Public rQuotes As New Regex("""")
    Public cQuotes As Color = Color.Maroon
    Public rtbDump As New RichTextBox()
 
    Public sTabIndents() As String = {"   ", "    ", "      "}
#End Region
#Region " [Functions] "
#Region " [ColorCurrentLine] "
    Public Sub ColorCurrentLine(ByVal rtb As RichTextBox)
        Dim iLength As Integer = rtb.Lines.Length
        If iLength < 1 Then
            Return
        End If
        LockWindowUpdate(rtb.Handle)
        Dim mcMatchCollection As MatchCollection = Nothing
        Dim bSkipRest As Boolean = False
 
        Dim iStart As Integer = rtb.SelectionStart
        Dim iLine As Integer = rtb.GetLineFromCharIndex(iStart)
        Dim pPoint As Point = rtb.GetPositionFromCharIndex(iStart)
        Dim iScreenStart As Integer = rtb.GetCharIndexFromPosition(New Point(1, pPoint.Y))
        Dim iScreenEnd As Integer = rtb.GetCharIndexFromPosition(New Point(rtb.Width, pPoint.Y)) + 1
        Dim iFirstCharOfLine As Integer = rtb.GetFirstCharIndexFromLine(iLine)
        Dim iDiff As Integer = iScreenStart - iFirstCharOfLine
        Dim sLineText As String = ""
        Dim sRTBText As String = rtb.Text
        Dim sFullLine As String = rtbEdit.Lines(iLine)
        Dim sLineLength As Integer = sRTBText.Substring(iScreenStart, iScreenEnd - iScreenStart).Length
        sLineText = sRTBText.Substring(iScreenStart, iScreenEnd - iScreenStart)
 
        rtb.Select(iFirstCharOfLine + iDiff, iScreenEnd - iScreenStart)
        rtb.SelectionColor = Color.Black
 
        Dim iQuoteStart As New List(Of Integer)
        Dim iQuoteLen As New List(Of Integer)
 
        Dim iComStart As New List(Of Integer)
        Dim iComLen As New List(Of Integer)
        Dim iComInd As New List(Of Integer)
 
        Dim iWordsStart As New List(Of Integer)
        Dim iWordsLen As New List(Of Integer)
        Dim iWordsColor As New List(Of Integer)
        Dim iWordsWord As New List(Of Integer)
 
 
 
        mcMatchCollection = rQuotes.Matches(sFullLine)
        bSkipRest = False
        Dim mTemp1 As Match = Nothing
        Dim mTemp2 As Match = Nothing
        For k As Integer = 0 To mcMatchCollection.Count - 1
            bSkipRest = False
            mTemp1 = mcMatchCollection(k)
            mTemp2 = Nothing
            Dim iTempLength As Integer = 0
            If k + 1 <= mcMatchCollection.Count - 1 Then
                mTemp2 = mcMatchCollection(k + 1)
                iTempLength = (mTemp2.Index - mTemp1.Index) + 1
            Else
                iTempLength = 1
            End If
            iQuoteStart.Add(iScreenStart + mTemp1.Index)
            iQuoteLen.Add(iTempLength)
        Next k
 
        mcMatchCollection = Nothing
        For i As Integer = 0 To wlWordList.Length - 1
            mcMatchCollection = wlWordList.rRegex(i).Matches(sLineText)
            For Each mMatch As Match In mcMatchCollection
                iWordsStart.Add(iScreenStart + mMatch.Index)
                iWordsLen.Add(mMatch.Length)
                iWordsColor.Add(i)
                iWordsWord.Add(i)
            Next mMatch
        Next i
 
        Dim mTemp As Match = rComments.Match(sFullLine)
        If mTemp.Success Then
            iComStart.Add(iScreenStart + mTemp.Index)
            iComLen.Add(mTemp.Length)
            iComInd.Add(sLineText.Length - mTemp.Index)
        End If
 
        For i As Integer = 0 To iComStart.Count - 1
            bSkipRest = False
            For k As Integer = 0 To iQuoteStart.Count - 2
                If iComStart(i) > iQuoteStart(k) AndAlso iComStart(i) + iComLen(i) < iQuoteStart(k + 1) + iQuoteLen(k + 1) Then
                    bSkipRest = True
                End If
            Next k
            If Not bSkipRest Then
                rtb.Select(iComStart(i), iComInd(i))
                rtb.SelectionColor = cComments
            End If
        Next i
 
 
        For i As Integer = 0 To iQuoteStart.Count - 1
            bSkipRest = False
            For k As Integer = 0 To iComStart.Count - 1
                If iQuoteStart(i) > iComStart(k) + iComLen(k) Then
                    bSkipRest = True
                End If
            Next k
            If Not bSkipRest Then
                rtb.Select(iQuoteStart(i), iQuoteLen(i))
                rtb.SelectionColor = cQuotes
            End If
        Next i
 
        For i As Integer = 0 To iWordsStart.Count - 1
            bSkipRest = False
            For k As Integer = 0 To iComStart.Count - 1
                If iWordsStart(i) > iComStart(k) Then
                    bSkipRest = True
                End If
            Next k
            For k As Integer = 0 To iQuoteStart.Count - 1
                If iWordsStart(i) > iQuoteStart(k) AndAlso iWordsStart(i) + iWordsLen(i) < iQuoteStart(k) + iQuoteLen(k) Then
                    bSkipRest = True
                End If
            Next k
            If Not bSkipRest Then
                rtb.Select(iWordsStart(i), iWordsLen(i))
                rtb.SelectedText = wlWordList.GetWord(iWordsWord(i))
                rtb.Select(iWordsStart(i), iWordsLen(i))
                rtb.SelectionColor = wlWordList.GetColor(iWordsColor(i))
            End If
        Next i
 
        rtb.SelectionLength = 0
        rtb.SelectionStart = iStart
        rtb.SelectionColor = Color.Black
        LockWindowUpdate(IntPtr.Zero)
    End Sub
#End Region
#Region " [ColorLines] "
    Public Sub ColorLines(ByVal rtb As RichTextBox)
        RemoveHandler rtbEdit.TextChanged, AddressOf rtb_TextChanged
        Dim sRTBLines() As String = rtb.Lines
        Dim iLength As Integer = sRTBLines.Length
        If iLength < 1 Then
            Return
        End If
        LockWindowUpdate(rtb.Handle)
        Dim iLineFirst As Integer = 0
        Dim sText As String = ""
        Dim sRtbText As String = rtbEdit.Text
 
        Dim bSkipRest As Boolean = False
 
        Dim iSelectionStart As Integer = rtb.SelectionStart
        Dim iLastIndexFound As Integer = 0
        Dim mcMatchCollection As MatchCollection = Nothing
 
        For i As Integer = iLineFirst To iLength - 1
            Dim iFirstCharOfLine As Integer = rtb.GetFirstCharIndexFromLine(i)
            sText = sRTBLines(i)
            rtb.Select(iFirstCharOfLine, sRTBLines(i).Length)
            rtb.SelectionColor = Color.Black
            rtb.SelectionLength = 0
 
 
            Dim iQuoteStart As New List(Of Integer)
            Dim iQuoteLen As New List(Of Integer)
 
            Dim iComStart As New List(Of Integer)
            Dim iComLen As New List(Of Integer)
            Dim iComInd As New List(Of Integer)
 
            Dim iWordsStart As New List(Of Integer)
            Dim iWordsLen As New List(Of Integer)
            Dim iWordsColor As New List(Of Integer)
            Dim iWordsWord As New List(Of Integer)
 
 
            Dim sCurrentLine As String = sRTBLines(i)
            mcMatchCollection = rQuotes.Matches(sCurrentLine)
            bSkipRest = False
            Dim mTemp1 As Match = Nothing
            Dim mTemp2 As Match = Nothing
            For k As Integer = 0 To mcMatchCollection.Count - 1
                bSkipRest = False
                mTemp1 = mcMatchCollection(k)
                mTemp2 = Nothing
                Dim iTempLength As Integer = 0
                If k + 1 <= mcMatchCollection.Count - 1 Then
                    mTemp2 = mcMatchCollection(k + 1)
                    iTempLength = (mTemp2.Index - mTemp1.Index) + 1
                Else
                    iTempLength = 1
                End If
                iQuoteStart.Add(iFirstCharOfLine + mTemp1.Index)
                iQuoteLen.Add(iTempLength)
            Next k
 
            mcMatchCollection = Nothing
            For k As Integer = 0 To wlWordList.Length - 1
                mcMatchCollection = wlWordList.rRegex(k).Matches(sCurrentLine)
                For Each mMatch As Match In mcMatchCollection
                    iWordsStart.Add(iFirstCharOfLine + mMatch.Index)
                    iWordsLen.Add(mMatch.Length)
                    iWordsColor.Add(k)
                    iWordsWord.Add(k)
                Next mMatch
            Next k
 
            Dim mTemp As Match = rComments.Match(sCurrentLine)
            If mTemp.Success Then
                iComStart.Add(iFirstCharOfLine + mTemp.Index)
                iComLen.Add(mTemp.Length)
                iComInd.Add(sCurrentLine.Length - mTemp.Index)
            End If
 
 
            For k As Integer = 0 To iComStart.Count - 1
                bSkipRest = False
                For z As Integer = 0 To iQuoteStart.Count - 2
                    If iComStart(k) > iQuoteStart(z) AndAlso iComStart(k) + iComLen(k) < iQuoteStart(z + 1) + iQuoteLen(z + 1) Then
                        bSkipRest = True
                    End If
                Next z
                If Not bSkipRest Then
                    rtb.Select(iComStart(k), iComInd(k))
                    rtb.SelectionColor = cComments
                End If
            Next k
 
 
            For k As Integer = 0 To iQuoteStart.Count - 1
                bSkipRest = False
                For z As Integer = 0 To iComStart.Count - 1
                    If iQuoteStart(k) > iComStart(z) + iComLen(z) Then
                        bSkipRest = True
                    End If
                Next z
                If Not bSkipRest Then
                    rtb.Select(iQuoteStart(k), iQuoteLen(k))
                    rtb.SelectionColor = cQuotes
                End If
            Next k
 
            For k As Integer = 0 To iWordsStart.Count - 1
                bSkipRest = False
                For z As Integer = 0 To iComStart.Count - 1
                    If iWordsStart(k) > iComStart(z) Then
                        bSkipRest = True
                    End If
                Next z
                For z As Integer = 0 To iQuoteStart.Count - 1
                    If iWordsStart(k) > iQuoteStart(z) AndAlso iWordsStart(k) + iWordsLen(k) < iQuoteStart(z) + iQuoteLen(z) Then
                        bSkipRest = True
                    End If
                Next z
                If Not bSkipRest Then
                    rtb.Select(iWordsStart(k), iWordsLen(k))
                    rtb.SelectedText = wlWordList.GetWord(iWordsWord(k))
                    rtb.Select(iWordsStart(k), iWordsLen(k))
                    rtb.SelectionColor = wlWordList.GetColor(iWordsColor(k))
                End If
            Next k
        Next i
        rtb.SelectionLength = 0
        rtb.SelectionStart = iSelectionStart
        rtb.SelectionColor = Color.Black
        LockWindowUpdate(IntPtr.Zero)
        AddHandler rtbEdit.TextChanged, AddressOf rtb_TextChanged
    End Sub
#End Region
#Region " [ColorPaste] "
    Public Sub ColorPaste(ByVal rtb As RichTextBox, ByVal dump As RichTextBox, ByVal iPasteStart As Integer)
        Dim sRTBLines() As String = dump.Lines
        Dim iLength As Integer = sRTBLines.Length
        If iLength < 1 Then
            Return
        End If
        LockWindowUpdate(rtb.Handle)
        RemoveHandler rtb.TextChanged, AddressOf rtb_TextChanged
        Dim sText As String = ""
        Dim sRtbText As String = dump.Text
        Dim bSkipRest As Boolean = False
        rtb.SelectedText = ""
        rtb.Select(iPasteStart, 0)
        rtb.SelectedText = sRtbText
 
        rtb.SelectionColor = Color.Black
        Dim iSelectionStart As Integer = iPasteStart
        Dim iLineFirst As Integer = rtb.GetLineFromCharIndex(iSelectionStart)
        Dim iLastIndexFound As Integer = 0
        Dim mcMatchCollection As MatchCollection = Nothing
        For i As Integer = 0 To iLength - 1
            Dim iFirstCharOfLine As Integer = rtb.GetFirstCharIndexFromLine(i + iLineFirst)
            sText = sRTBLines(i)
            rtb.Select(iFirstCharOfLine, sRTBLines(i).Length)
            rtb.SelectionColor = Color.Black
            rtb.SelectionLength = 0
 
 
            Dim iQuoteStart As New List(Of Integer)
            Dim iQuoteLen As New List(Of Integer)
 
            Dim iComStart As New List(Of Integer)
            Dim iComLen As New List(Of Integer)
            Dim iComInd As New List(Of Integer)
 
            Dim iWordsStart As New List(Of Integer)
            Dim iWordsLen As New List(Of Integer)
            Dim iWordsColor As New List(Of Integer)
            Dim iWordsWord As New List(Of Integer)
 
 
            Dim sCurrentLine As String = sRTBLines(i)
            mcMatchCollection = rQuotes.Matches(sCurrentLine)
            bSkipRest = False
            Dim mTemp1 As Match = Nothing
            Dim mTemp2 As Match = Nothing
            For k As Integer = 0 To mcMatchCollection.Count - 1
                bSkipRest = False
                mTemp1 = mcMatchCollection(k)
                mTemp2 = Nothing
                Dim iTempLength As Integer = 0
                If k + 1 <= mcMatchCollection.Count - 1 Then
                    mTemp2 = mcMatchCollection(k + 1)
                    iTempLength = (mTemp2.Index - mTemp1.Index) + 1
                Else
                    iTempLength = 1
                End If
                iQuoteStart.Add(iFirstCharOfLine + mTemp1.Index)
                iQuoteLen.Add(iTempLength)
            Next k
 
            mcMatchCollection = Nothing
            For k As Integer = 0 To wlWordList.Length - 1
                mcMatchCollection = wlWordList.rRegex(k).Matches(sCurrentLine)
                For Each mMatch As Match In mcMatchCollection
                    iWordsStart.Add(iFirstCharOfLine + mMatch.Index)
                    iWordsLen.Add(mMatch.Length)
                    iWordsColor.Add(k)
                    iWordsWord.Add(k)
                Next mMatch
            Next k
 
            Dim mTemp As Match = rComments.Match(sCurrentLine)
            If mTemp.Success Then
                iComStart.Add(iFirstCharOfLine + mTemp.Index)
                iComLen.Add(mTemp.Length)
                iComInd.Add(sCurrentLine.Length - mTemp.Index)
            End If
 
 
            For k As Integer = 0 To iComStart.Count - 1
                bSkipRest = False
                For z As Integer = 0 To iQuoteStart.Count - 2
                    If iComStart(k) > iQuoteStart(z) AndAlso iComStart(k) + iComLen(k) < iQuoteStart(z + 1) + iQuoteLen(z + 1) Then
                        bSkipRest = True
                    End If
                Next z
                If Not bSkipRest Then
                    rtb.Select(iComStart(k), iComInd(k))
                    rtb.SelectionColor = cComments
                End If
            Next k
 
 
            For k As Integer = 0 To iQuoteStart.Count - 1
                bSkipRest = False
                For z As Integer = 0 To iComStart.Count - 1
                    If iQuoteStart(k) > iComStart(z) + iComLen(z) Then
                        bSkipRest = True
                    End If
                Next z
                If Not bSkipRest Then
                    rtb.Select(iQuoteStart(k), iQuoteLen(k))
                    rtb.SelectionColor = cQuotes
                End If
            Next k
 
            For k As Integer = 0 To iWordsStart.Count - 1
                bSkipRest = False
                For z As Integer = 0 To iComStart.Count - 1
                    If iWordsStart(k) > iComStart(z) Then
                        bSkipRest = True
                    End If
                Next z
                For z As Integer = 0 To iQuoteStart.Count - 1
                    If iWordsStart(k) > iQuoteStart(z) AndAlso iWordsStart(k) + iWordsLen(k) < iQuoteStart(z) + iQuoteLen(z) Then
                        bSkipRest = True
                    End If
                Next z
                If Not bSkipRest Then
                    rtb.Select(iWordsStart(k), iWordsLen(k))
                    rtb.SelectedText = wlWordList.GetWord(iWordsWord(k))
                    rtb.Select(iWordsStart(k), iWordsLen(k))
                    rtb.SelectionColor = wlWordList.GetColor(iWordsColor(k))
                End If
            Next k
        Next i
        rtb.Select(iSelectionStart + sRtbText.Length, 0)
        rtb.SelectionColor = Color.Black
        LockWindowUpdate(IntPtr.Zero)
        AddHandler rtbEdit.TextChanged, AddressOf rtb_TextChanged
    End Sub
#End Region
#End Region
 
    Dim SER As String
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        System.Windows.Forms.Application.DoEvents()
        Me.Controls.Add(rtbDump)
        rtbDump.WordWrap = False
        rtbDump.Visible = False
 
        SER = "1"
 
        Dim cColor As Color = Color.Blue
        With wlWordList
            .Add("accesskey", cColor, True)
            .Add("contenteditable", cColor, True)
            .Add("contextmenu", cColor, True)
            .Add("class", cColor, True)
            .Add("dir", cColor, True)
            .Add("id", cColor, True)
            .Add("background", cColor, True)
            .Add("backcolor", cColor, True)
            .Add("hidden", cColor, True)
            .Add("lang", cColor, True)
            .Add("spellcheck", cColor, True)
            .Add("style", cColor, True)
            .Add("tabindex", cColor, True)
            .Add("xml:lang", cColor, True)
            .Add("onblur", cColor, True)
            .Add("onchange", cColor, True)
            .Add("onclick", cColor, True)
            .Add("ondblclick", cColor, True)
            .Add("onfocus", cColor, True)
            .Add("onkeydown", cColor, True)
            .Add("onkeypress", cColor, True)
            .Add("onkeyup", cColor, True)
            .Add("onload", cColor, True)
            .Add("onmousedown", cColor, True)
            .Add("onmousemove", cColor, True)
            .Add("onmouseout", cColor, True)
            .Add("onmouseover", cColor, True)
            .Add("onmouseup", cColor, True)
            .Add("onreset", cColor, True)
            .Add("onselect", cColor, True)
            .Add("onsubmit", cColor, True)
            .Add("onunload", cColor, True)
            .Add("aling", cColor, True)
            .Add("archive", cColor, True)
            .Add("classid", cColor, True)
            .Add("code", cColor, True)
            .Add("codebase", cColor, True)
            .Add("codetype", cColor, True)
            .Add("data", cColor, True)
            .Add("hight", cColor, True)
            .Add("hspace", cColor, True)
            .Add("type", cColor, True)
            .Add("vspace", cColor, True)
            .Add("with", cColor, True)
        End With
 
        Dim cColor1 As Color = Color.Indigo
        With wlWordList
            .Add("abbr", cColor1, True)
            .Add("acronym", cColor1, True)
            .Add("address", cColor1, True)
            .Add("applet", cColor1, True)
            .Add("area", cColor1, True)
            .Add("base", cColor1, True)
            .Add("basefont", cColor1, True)
            .Add("bdo", cColor1, True)
            .Add("bgsound", cColor1, True)
            .Add("blockquote", cColor1, True)
            .Add("big", cColor1, True)
            .Add("body", cColor1, True)
            .Add("blink", cColor1, True)
            .Add("br", cColor1, True)
            .Add("button", cColor1, True)
            .Add("caption", cColor1, True)
            .Add("center", cColor1, True)
            .Add("cite", cColor1, True)
            .Add("code", cColor1, True)
            .Add("col", cColor1, True)
            .Add("colgroup", cColor1, True)
            .Add("dd", cColor1, True)
            .Add("comment", cColor1, True)
            .Add("del", cColor1, True)
            .Add("dfn", cColor1, True)
            .Add("dir", cColor1, True)
            .Add("div", cColor1, True)
            .Add("dl", cColor1, True)
            .Add("dt", cColor1, True)
            .Add("em", cColor1, True)
            .Add("embed", cColor1, True)
            .Add("fieldset", cColor1, True)
            .Add("font", cColor1, True)
            .Add("form", cColor1, True)
            .Add("footer", cColor1, True)
            .Add("frame", cColor1, True)
            .Add("frameset", cColor1, True)
            .Add("head", cColor1, True)
            .Add("hr", cColor1, True)
            .Add("html", cColor1, True)
            .Add("iframe", cColor1, True)
            .Add("img", cColor1, True)
            .Add("input", cColor1, True)
            .Add("ins", cColor1, True)
            .Add("isindex", cColor1, True)
            .Add("label", cColor1, True)
            .Add("kbd", cColor1, True)
            .Add("legend", cColor1, True)
            .Add("link", cColor1, True)
            .Add("map", cColor1, True)
            .Add("marquee", cColor1, True)
            .Add("meta", cColor1, True)
            .Add("nobr", cColor1, True)
            .Add("noembed", cColor1, True)
            .Add("noframes", cColor1, True)
            .Add("noscript", cColor1, True)
            .Add("object", cColor1, True)
            .Add("ol", cColor1, True)
            .Add("optgroup", cColor1, True)
            .Add("option", cColor1, True)
            .Add("param", cColor1, True)
            .Add("plaintext", cColor1, True)
            .Add("pre", cColor1, True)
            .Add("samp", cColor1, True)
            .Add("script", cColor1, True)
            .Add("small", cColor1, True)
            .Add("select", cColor1, True)
            .Add("span", cColor1, True)
            .Add("strike", cColor1, True)
            .Add("strong", cColor1, True)
            .Add("sub", cColor1, True)
            .Add("sup", cColor1, True)
            .Add("table", cColor1, True)
            .Add("tbody", cColor1, True)
            .Add("td", cColor1, True)
            .Add("textarea", cColor1, True)
            .Add("tfoot", cColor1, True)
            .Add("th", cColor1, True)
            .Add("thead", cColor1, True)
            .Add("title", cColor1, True)
            .Add("tr", cColor1, True)
            .Add("tt", cColor1, True)
            .Add("u", cColor1, True)
            .Add("ul", cColor1, True)
            .Add("var", cColor1, True)
            .Add("xmp", cColor1, True)
            .Add("li", cColor1, True)
        End With
 
        Dim cColor2 As Color = Color.BlueViolet
        With wlWordList
            .Add("expression", cColor2, True)
            .Add("php", cColor2, True)
            .Add("echo", cColor2, True)
            .Add("print", cColor2, True)
            .Add("variable", cColor2, True)
            .Add("endif", cColor2, True)
            .Add("highlight", cColor2, True)
            .Add("me", cColor2, True)
            .Add("file_contents", cColor2, True)
            .Add("php die()", cColor2, True)
            .Add("n", cColor2, True)
            .Add("arr", cColor2, True)
            .Add("obj", cColor2, True)
            .Add("function_name", cColor2, True)
            .Add("d", cColor2, True)
            .Add("_GET", cColor2, True)
            .Add("_ENV", cColor2, True)
            .Add("_FILES ", cColor2, True)
            .Add("_POST", cColor2, True)
            .Add("GLOBALS", cColor2, True)
            .Add("_SERVER", cColor2, True)
            .Add("_COOKIE", cColor2, True)
            .Add("_REQUEST", cColor2, True)
            .Add("_SESSION", cColor2, True)
            .Add("this", cColor2, True)
            .Add("extends", cColor2, True)
            .Add("private", cColor2, True)
            .Add("CONST_VALUE", cColor2, True)
            .Add("public function plus", cColor2, True)
            .Add("return", cColor2, True)
            .Add("HTTP_ENV_VARS", cColor2, True)
            .Add("HTTP_SERVER_VARS", cColor2, True)
            .Add("HTTP_POST_VARS", cColor2, True)
            .Add("HTTP_POST_FILES", cColor2, True)
        End With
 
        Dim cColor3 As Color = Color.Gray
        With wlWordList
            .Add("1", cColor3, True)
            .Add("2", cColor3, True)
            .Add("3", cColor3, True)
            .Add("4", cColor3, True)
            .Add("5", cColor3, True)
            .Add("6", cColor3, True)
            .Add("7", cColor3, True)
            .Add("8", cColor3, True)
            .Add("9", cColor3, True)
            .Add("0", cColor3, True)
        End With
 
        Dim cColor4 As Color = Color.Orange
        With wlWordList
            .Add("h1", cColor4, True)
            .Add("h2", cColor4, True)
            .Add("h3", cColor4, True)
            .Add("h4", cColor4, True)
            .Add("h5", cColor4, True)
            .Add("h6", cColor4, True)
        End With
 
        Dim cColor5 As Color = Color.SaddleBrown
        With wlWordList
            .Add("struct", cColor5, True)
            .Add("int", cColor5, True)
            .Add("namespace", cColor5, True)
            .Add("const int", cColor5, True)
            .Add("typedef int", cColor5, True)
            .Add("void", cColor5, True)
            .Add("double", cColor5, True)
            .Add("using namespace", cColor5, True)
            .Add("inline double", cColor5, True)
            .Add("Draw", cColor5, True)
            .Add("Circle", cColor5, True)
            .Add("Square", cColor5, True)
            .Add("virtual void", cColor5, True)
            .Add("Array", cColor5, True)
            .Add("int _len", cColor5, True)
            .Add("inline void", cColor5, True)
            .Add("Alloc", cColor5, True)
            .Add("inline const double", cColor5, True)
            .Add("ChangeElem", cColor5, True)
            .Add("protected", cColor5, True)
            .Add("friend class", cColor5, True)
            .Add("operator", cColor5, True)
            .Add("cstddef", cColor5, True)
            .Add("limits", cColor5, True)
            .Add("climits", cColor5, True)
            .Add("cfloat", cColor5, True)
            .Add("cstdlib", cColor5, True)
            .Add("cstdarg", cColor5, True)
            .Add("stdexcept", cColor5, True)
            .Add("cassert", cColor5, True)
            .Add("cerrno", cColor5, True)
            .Add("utility", cColor5, True)
            .Add("ctime", cColor5, True)
            .Add("deque", cColor5, True)
            .Add("clocale", cColor5, True)
            .Add("complex", cColor5, True)
            .Add("numeric", cColor5, True)
            .Add("valarray", cColor5, True)
            .Add("cmath", cColor5, True)
            .Add("iosfwd", cColor5, True)
            .Add("iostream", cColor5, True)
        End With
 
        Dim cColor6 As Color = Color.IndianRed
        With wlWordList
            .Add("createTextField", cColor6, True)
            .Add("greet.text", cColor6, True)
            .Add("com.example.Greeter", cColor6, True)
            .Add("extends MovieClip", cColor6, True)
            .Add("package", cColor6, True)
            .Add("flash.display.Sprite", cColor6, True)
            .Add("flash.text.TextField", cColor6, True)
            .Add("addChild", cColor6, True)
            .Add("CDATA", cColor6, True)
            .Add("XMLNode", cColor6, True)
            .Add("MovieClipLoader", cColor6, True)
            .Add("NetConnection", cColor6, True)
            .Add("NetStream", cColor6, True)
            .Add("null", cColor6, True)
            .Add("Error", cColor6, True)
            .Add("Vector", cColor6, True)
            .Add("flash.filters", cColor6, True)
            .Add("flash.external", cColor6, True)
            .Add("flash.errors", cColor6, True)
            .Add("flash.display", cColor6, True)
            .Add("flash.accessibility", cColor6, True)
            .Add("flash.ui", cColor6, True)
            .Add("flash.system", cColor6, True)
            .Add("flash.profiler", cColor6, True)
            .Add("gotoAndStop", cColor6, True)
            .Add("gotoAndPlay", cColor6, True)
            .Add("nextFrame", cColor6, True)
            .Add("prevFrame", cColor6, True)
            .Add("getURL", cColor6, True)
        End With
 
        ColorLines(rtbEdit)
        rtbEdit.Visible = True
    End Sub
 
    Private Sub rtb_TextChanged(ByVal sender As Object, ByVal e As EventArgs) Handles rtbEdit.TextChanged
        Dim rtb As RichTextBox = CType(sender, RichTextBox)
        ColorCurrentLine(rtb)
    End Sub
End Class

@dimsaratov · 03.10.2013, 23:19

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

Отмечаем (выделяем) checkbox`s в TreeView при помощи области выделения

при помощи Shift выделяем при помощи Ctr снимаем выделение

в предыдущем посте у указанной реализации происходило выделение только в направлении сверху-вниз и слева-на право/ исправлено применений другого типа рамки

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
Public Class Form1
 
    Dim isSelect As Boolean = False
    Dim outRectangle As New Rectangle(New Point(0, 0), New Size(0, 0))
    Dim inRectangle As New Rectangle(New Point(0, 0), New Size(0, 0))
    Dim startPoint As Point
    Dim flgDirection As Boolean
    Dim graph As Graphics
    Dim controlTV As Control
 
    Private Sub TreeView1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles TreeView1.MouseDown
        isSelect = False
        If e.Button = MouseButtons.Left Then
            Select Case ModifierKeys
                Case Keys.Control
                    flgDirection = False
                Case Keys.Shift
                    flgDirection = True
                Case Else
                    Exit Sub
            End Select
            controlTV = CType(sender, Control)
            startPoint = New Point(e.X, e.Y)
            isSelect = True
 
        End If
    End Sub
 
    Private Sub TreeView1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles TreeView1.MouseMove
        If isSelect Then
            graph = Nothing
            graph = controlTV.CreateGraphics
            controlTV.Refresh()
            ControlPaint.DrawSelectionFrame(graph, True, outRectangle, inRectangle, sender.backcolor)
            Dim endPoint As Point = New Point(e.X, e.Y)
            Dim width As Integer = Math.Abs(endPoint.X - startPoint.X)
            Dim height As Integer = Math.Abs(endPoint.Y - startPoint.Y)
            Dim sPoint As Point
            sPoint.X = Math.Min(endPoint.X, startPoint.X)
            sPoint.Y = Math.Min(endPoint.Y, startPoint.Y)
            outRectangle = New Rectangle(sPoint.X, sPoint.Y, width, height)
            inRectangle = New Rectangle(sPoint.X + 2, sPoint.Y + 2, width - 4, height - 4)
            ControlPaint.DrawSelectionFrame(graph, False, outRectangle, inRectangle, sender.backcolor)
        End If
    End Sub
 
    Private Sub TreeView1_MouseUp(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles TreeView1.MouseUp
        If isSelect Then
            isSelect = False
            ControlPaint.DrawSelectionFrame(graph, False, outRectangle, inRectangle, sender.BackColor)
            TreeView1.BeginUpdate()
            SetNodes(TreeView1.Nodes.Item(0))
            TreeView1.EndUpdate()
        End If
        outRectangle = New Rectangle(0, 0, 0, 0)
        inRectangle = New Rectangle(0, 0, 0, 0)
    End Sub
    Private Sub SetNodes(ByVal NodeX As TreeNode)
        Dim NodeC As TreeNode
        Dim controlRectangle As Rectangle
        For Each NodeC In NodeX.Nodes
            Application.DoEvents()
            controlRectangle = NodeC.Bounds
            Debug.WriteLine(controlRectangle)
            Debug.WriteLine(outRectangle)
            If controlRectangle.IntersectsWith(outRectangle) Then
                If flgDirection Then
                    NodeC.BackColor = Color.Red
                    NodeC.Checked = flgDirection
                Else
                    NodeC.BackColor = System.Drawing.SystemColors.Window
                    NodeC.Checked = flgDirection
                End If
 
            End If
            If NodeC.Nodes.Count > 1 Then SetNodes(NodeC)
        Next
    End Sub
End Class

@Nachrichter · 13.10.2013, 21:52

Получение URL всех вкладок Internet Explorer
На форме ListBox и Button. Добавляем ссылку на вкладке COM: Microsoft Internet Controls.
Импортируем:

VB.NET
1
Imports SHDocVw

Код кнопки:

VB.NET
1
2
3
4
5
6
7
Try
    ListBox1.Items.Clear()
    For Each IE As InternetExplorer In New ShellWindows()
         ListBox1.Items.Add(IE.LocationURL.ToString)
    Next
Catch 
End Try

@Маршинин · 09.11.2013, 18:38

Получение установленных приложений

Код программы:

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

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
Imports System.Text
Imports System.Runtime.InteropServices
Public Class Form1
    <DllImport("msi.dll", SetLastError:=True)> _
    Private Shared Function MsiEnumProducts(iProductIndex As Integer, lpProductBuf As StringBuilder) As Integer
    End Function
    Public Enum MSI_ERROR As Integer
        ERROR_SUCCESS = 0
        ERROR_MORE_DATA = 234
        ERROR_NO_MORE_ITEMS = 259
        ERROR_INVALID_PARAMETER = 87
        ERROR_BAD_CONFIGURATION = 1610
    End Enum
 
    <STAThread> _
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Dim sb As New StringBuilder(39)
        Dim [error] As MSI_ERROR = MSI_ERROR.ERROR_SUCCESS
        Dim index As Integer = 0
        While [error] = MSI_ERROR.ERROR_SUCCESS
            [error] = CType(MsiEnumProducts(index, sb), MSI_ERROR)
            Dim productID As String = sb.ToString()
            If [error] = MSI_ERROR.ERROR_SUCCESS Then
                Dim nameSub As String = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall" & productID
                If Not My.Computer.Registry.GetValue(nameSub, "DisplayName", Nothing) = Nothing Then
                    ListBox1.Items.Add(My.Computer.Registry.GetValue(nameSub, "DisplayName", Nothing))
                End If
            End If
            index += 1
        End While
    End Sub
End Class

@Маршинин · 09.11.2013, 20:53

Получение установленных приложений (2 вариант) [Рекомендуемо]

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

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
13
14
Public Class Form1
    Dim List As New ListBox 'Все имена вложенных разделов
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        For i As Integer = 0 To My.Computer.Registry.LocalMachine.OpenSubKey("SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall", False).SubKeyCount - 1
            List.Items.Add(My.Computer.Registry.LocalMachine.OpenSubKey("SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall", False).GetSubKeyNames(i))
        Next
        For l As Integer = 0 To List.Items.Count - 1
            Dim nameSub As String = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall" & List.Items.Item(l)
            If Not My.Computer.Registry.GetValue(nameSub, "DisplayName", Nothing) = Nothing Then
                ListBox1.Items.Add(My.Computer.Registry.GetValue(nameSub, "DisplayName", Nothing))
            End If
        Next
    End Sub
End Class

@insite2012 · 15.12.2013, 11:46

Один из вариантов защиты программы. При желании можно усложнить (к примеру, на вход кодировщика подавать не начальную сформированную строку, а немного ее модернизировав).
Код 1-тестовое приложение, код 2 - генератор файла ключа.
Замечу, что данный метод имеет хорошие возможности для усложнения (к примеру, для объекта Rijndael его свойство Key - возможно шифрование с созданием второго файла).
Для проверки работоспособности файл ключа необходимо поместить в папку с исполняемым файлом самой программы.
Код тестового приложения:

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
Imports System.Management
Imports System.Security.Cryptography 'Импортирование пространств имен
'Для работоспособности проекта неообходимо добавить ссылку на System.Management
Module SecurityModule
    'Модуль защиты приложения
    Private Rijndael As New RijndaelManaged 'Создание объекта криптошифрования
    Private Number As String = ""
    'Определение ID MB
    Public Function GetMotherBoardID() As String
        Dim strMotherBoard As String = String.Empty
        Dim query As New SelectQuery("Win32_BaseBoard")
        Dim search As New ManagementObjectSearcher(query)
        Dim info As ManagementObject
        For Each info In search.Get
            strMotherBoard = info("SerialNumber").ToString()
        Next
        strMotherBoard = Strings.Trim(strMotherBoard)
        Return strMotherBoard
    End Function
    'Определение ID CPU
    Public Function GetProcessorID() As String
        Dim strProcessor As String = String.Empty
        Dim query As New SelectQuery("Win32_processor")
        Dim search As New ManagementObjectSearcher(query)
        Dim info As ManagementObject
        For Each info In search.Get
            strProcessor = info("processorId").ToString()
        Next
        strProcessor = Strings.Trim(strProcessor)
        Return strProcessor
    End Function
    'Дешифровка файла ключа
    Private Function DecryptKeyFile(ByVal A As String) As Boolean
        Dim DecryptRes As String = ""
        Dim Key() As Byte = New Byte(&H1F) {}
        For i As Integer = 0 To &H1F - 1
            Key(i) = &HFF
        Next
        Rijndael.Key = Key
        Dim fs As New System.IO.FileStream("KeyFile.bin", System.IO.FileMode.Open)
        Dim IV() As Byte
        ReDim IV(Rijndael.IV.Length - 1)
        fs.Read(IV, 0, IV.Length)
        Rijndael.IV = IV
        Dim Transform As ICryptoTransform = Rijndael.CreateDecryptor
        Dim cs As New CryptoStream(fs, Transform, CryptoStreamMode.Read)
        Dim r As New System.IO.StreamReader(cs)
        DecryptRes = r.ReadToEnd
        r.Close()
        If DecryptRes = Number Then
            Return True
        Else
            Return False
        End If
    End Function
    'Процедура проверки наличия файла ключа и его соответствие на корректность
    Public Sub Form_Load()
        Number = GetProcessorID() & GetMotherBoardID()
        If System.IO.File.Exists("KeyFile.bin") Then
            If DecryptKeyFile("KeyFile.bin") = False Then 'Неверный фал ключа
                MessageBox.Show("Файл ключа не верный" & vbCrLf &
                                "Данные скопированы в буфер обмена" & vbCrLf &
                                "Сообщите их разработчику для получения файла ключа", "Info",
                                MessageBoxButtons.OK, MessageBoxIcon.Asterisk)
                My.Computer.Clipboard.SetText(Number)
                End
            End If
        Else   'Файл ключа отсутствует
            MessageBox.Show("Файл ключа не найден" & vbCrLf &
                            "Данные скопированы в буфер обмена" & vbCrLf &
                            "Сообщите их разработчику для получения файла ключа", "Info",
                            MessageBoxButtons.OK, MessageBoxIcon.Asterisk)
            My.Computer.Clipboard.SetText(Number)
            End
        End If
    End Sub
End Module

Код генератора файла ключа. На форме текстовое поле, кнопка и диалог сохранения.

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
Imports System.IO
Imports System.Security.Cryptography
'Для работоспособности проекта неообходимо добавить ссылку на System.Management
Public Class Form1
    Private Rijndael As New RijndaelManaged
    Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
        Me.Text = "Key File Generator v1.0.0"
        Button1.Text = "Create KeyFile"
        SaveFileDialog1.Filter = "files .bin(*.bin)|*.bin"
        SaveFileDialog1.FileName = "KeyFile"
    End Sub
 
    Private Sub Button1_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button1.Click
        If SaveFileDialog1.ShowDialog = DialogResult.OK Then
            Dim Key() As Byte = New Byte(&H1F) {}
            For i As Integer = 0 To &H1F - 1
                Key(i) = &HFF
            Next
            Rijndael.Key = Key
            Dim Transform As ICryptoTransform = Rijndael.CreateEncryptor
            Dim fs As New FileStream(SaveFileDialog1.FileName, FileMode.Create)
            fs.Write(Rijndael.IV, 0, Rijndael.IV.Length)
            Dim cs As New CryptoStream(fs, Transform, CryptoStreamMode.Write)
            Dim w As New StreamWriter(cs)
            w.Write(TextBox1.Text)
            w.Flush()
            cs.FlushFinalBlock()
            w.Close()
            MsgBox("Фал ключа создан успешно")
        End If
    End Sub
End Class

Обращаю внимание (хоть это и есть в комментариях) - для работоспособности проекта неообходимо добавить ссылку на System.Management

@insite2012 · 21.12.2013, 19:37

Несмотря на то что данный вопрос был освещен на 1-й странице данного FAQ, хотелось бы его дополнить.
Данный тестовый проект писался мной для лучшего понимания построения SQL запросов и запоминания основных моментов.
На форме DataGridView1 и 7 кнопок.
Надеюсь, кому-нибудь пригодится.

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
'Для работоспособности проекта необходимо 
'добавить ссылку на библиотеку Microsoft ADO Ext. 2.8 for DLL and Security
Imports System.Data.OleDb
Public Class Form1
    'Создание пустой базы данных
    Private Sub Button1_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button1.Click
        Dim Dialog As New SaveFileDialog With {.FileName = Nothing, .Filter = "DataBase files (*.mdb)|*.mdb"}
        Dim Catalog As New ADOX.Catalog
        If Dialog.ShowDialog = DialogResult.OK Then
            Try
                If System.IO.File.Exists(Dialog.FileName) Then
                    System.IO.File.Delete(Dialog.FileName)
                End If
                Catalog.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Dialog.FileName)
                MsgBox("База данных успешно создана")
            Catch ex As Exception
                MsgBox(ex.Message)
            Finally
                Catalog = Nothing
            End Try
        End If
    End Sub
    'Создание таблицы с указанными полями в базе данных
    Private Sub Button2_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button2.Click
        Dim Dialog As New OpenFileDialog With {.FileName = Nothing, .Filter = "DataBase files (*.mdb)|*.mdb"}
        If Dialog.ShowDialog = DialogResult.OK Then
            Try
                Dim Connection As New OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Dialog.FileName)
                Connection.Open()
                Dim Command As New OleDbCommand("CREATE TABLE [My DataBase]([Номер п/п] counter,[ФИО]char(20)," &
                                                "[Номер телефона]char(20),[Адрес]char(20))", Connection)
                Command.ExecuteNonQuery()
                MsgBox("Структура таблицы записана в базу данных")
                Connection.Close()
            Catch ex As Exception
                MsgBox(ex.Message)
            End Try
        End If
    End Sub
    'Добавление записи в таблицу
    Private Sub Button3_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button3.Click
        Dim Dialog As New OpenFileDialog With {.FileName = Nothing, .Filter = "DataBase files (*.mdb)|*.mdb"}
        If Dialog.ShowDialog = DialogResult.OK Then
            Try
                Dim Connection As New OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Dialog.FileName)
                Connection.Open()
                Dim Command As New OleDbCommand("INSERT INTO [My DataBase]([ФИО],[Номер телефона]," &
                                                "[Адрес]) VALUES('Петров','+7 982 324 12 98','Россия, Москва')", Connection)
                Command.ExecuteNonQuery()
                MsgBox("В таблицу добавлена новая запись")
                Connection.Close()
            Catch ex As Exception
                MsgBox(ex.Message)
            End Try
        End If
    End Sub
    'Чтение таблицы из базы данных в форму через объект DataReader
    Private Sub Button4_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button4.Click
        Dim Dialog As New OpenFileDialog With {.FileName = Nothing, .Filter = "DataBase files (*.mdb)|*.mdb"}
        If Dialog.ShowDialog = DialogResult.OK Then
            Try
                Dim Connection As New OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Dialog.FileName)
                Connection.Open()
                Dim Command As New OleDbCommand("SELECT * FROM [My DataBase]", Connection)
                Dim DataReader As OleDbDataReader = Command.ExecuteReader(CommandBehavior.CloseConnection)
                Dim DataTable As New DataTable
 
                DataTable.Columns.Add(DataReader.GetName(0))
                DataTable.Columns.Add(DataReader.GetName(1))
                DataTable.Columns.Add(DataReader.GetName(2))
                DataTable.Columns.Add(DataReader.GetName(3))
 
                While DataReader.Read = True
                    DataTable.Rows.Add(New String() {DataReader.GetValue(0),
                                                     DataReader.GetValue(1),
                                                     DataReader.GetValue(2),
                                                     DataReader.GetValue(3)})
                End While
                DataReader.Close()
                Connection.Close()
                DataGridView1.DataSource = DataTable
            Catch ex As Exception
                MsgBox(ex.Message)
            End Try
        End If
    End Sub
    'Чтение таблицы из базы данных в форму через объект DataAdapter
    Private Sub Button5_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button5.Click
        Dim Dialog As New OpenFileDialog With {.FileName = Nothing, .Filter = "DataBase files (*.mdb)|*.mdb"}
        If Dialog.ShowDialog = DialogResult.OK Then
            Try
                Dim Connection As New OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Dialog.FileName)
                Connection.Open()
                Dim Command As New OleDbCommand("SELECT * FROM[My DataBase]", Connection)
                'Тут закомментирована строка команды со знаком подстановки 
                'для вывода в таблицу только определенных значений по шаблону
                'в данном случае выводятся все значения из столбца ФИО начинающиеся на "И"
                'Dim Command_2 As New OleDbCommand("SELECT * FROM[My DataBase]WHERE([ФИО] LIKE 'И%')", Connection)
                Dim Adapter As New OleDbDataAdapter(Command)
                Dim DataSet As New DataSet
 
                Adapter.Fill(DataSet, "My DataBase")
                DataGridView1.DataSource = DataSet
                DataGridView1.DataMember = "My DataBase"
                Connection.Close()
            Catch ex As Exception
                MsgBox(ex.Message)
            End Try
        End If
    End Sub
    'Обновление записи в таблице
    Private Sub Button6_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button6.Click
        Dim Dialog As New OpenFileDialog With {.FileName = Nothing, .Filter = "DataBase files (*.mdb)|*.mdb"}
        If Dialog.ShowDialog = DialogResult.OK Then
            Try
                Dim Connection As New OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Dialog.FileName)
                Connection.Open()
                Dim Command As New OleDbCommand("UPDATE [My DataBase] SET [Номер телефона]='909900',[ФИО]='MMM'," &
                                                "[Адрес]='AAA' WHERE ([Номер п/п]=1)", Connection)
                Command.ExecuteNonQuery()
                MsgBox("Запись в таблице обновлена")
            Catch ex As Exception
                MsgBox(ex.Message)
            End Try
        End If
    End Sub
    'Удаление записи из таблицы
    Private Sub Button7_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button7.Click
        Dim Dialog As New OpenFileDialog With {.FileName = Nothing, .Filter = "DataBase files (*.mdb)|*.mdb"}
        If Dialog.ShowDialog = DialogResult.OK Then
            Try
                Dim Connection As New OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Dialog.FileName)
                Connection.Open()
                Dim Command As New OleDbCommand("DELETE FROM[My DataBase] WHERE [ФИО]='MMM'", Connection)
                'Закомментирована команда со знаком подстановки
                'для удаления значений по шаблону
                'в данном случае удаляются все записи из столбца ФИО начинающиеся на "М"
                'Dim Command_2 As New OleDbCommand("DELETE FROM[My DataBase] WHERE [ФИО] LIKE 'M%'", Connection)
 
                'Счетчик количества удаленных записей
                'если записей не найдено то Command.ExecuteNonQuery() возвращает 0
                Dim i As Integer = Command.ExecuteNonQuery()
                If i > 0 Then
                    MsgBox("Запись удалена из таблицы")
                Else
                    MsgBox("Таких записей в таблице не найдено")
                End If
            Catch ex As Exception
                MsgBox(ex.Message)
            End Try
        End If
    End Sub
End Class

@Водяной Змей · 26.12.2013, 16:35

3 украшения для формы

Украшение №1. Прозрачный фон из картинки PNG.
Это очень простой способ создать окошко с попиксельно прозрачным фоном, и в то же время, с возможностью размещения любых стандартных
контролов Winforms (при использовании известного решения с UpdateLayeredWindow, эта возможность утрачивается).

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

VB.NET
1
2
3
4
5
6
7
8
9
10
11
12
Public Class Form1
    Dim back As Bitmap
 
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        back = Image.FromFile("C:\\картинка.png")
        Me.FormBorderStyle = Windows.Forms.FormBorderStyle.None
    End Sub
 
    Protected Overrides Sub OnPaintBackground(ByVal e As PaintEventArgs)
        e.Graphics.DrawImage(back, 0, 0)
    End Sub
End Class

Украшение №2. Стеклянный фрейм Aero, расширенный в клиентскую область.

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

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
Imports System.Runtime.InteropServices
 
Public Class Form1
    <StructLayout(LayoutKind.Sequential)>
    Public Structure MARGINS
        Public cxLeftWidth As Integer
        Public cxRightWidth As Integer
        Public cyTopHeight As Integer
        Public cyBottomHeight As Integer
    End Structure
 
    <DllImport("DwmApi.dll")>
    Private Shared Function DwmExtendFrameIntoClientArea(ByVal hwnd As IntPtr, ByRef pMarInset As MARGINS) As Integer
    End Function
 
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Dim margins As MARGINS = New MARGINS()
        margins.cxLeftWidth = -1
        margins.cxRightWidth = -1
        margins.cyBottomHeight = -1
        margins.cyTopHeight = -1
 
        Try
            DwmExtendFrameIntoClientArea(Me.Handle, margins)
            Me.ResizeRedraw = True
        Catch ex As Exception
            ' Aero отключен или отсутствует в этой версии винды
        End Try
    End Sub
End Class

Украшение №3. Простейший скин в стиле Metro.
(Автоматически применяется ко всем кнопкам на форме.)

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

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 Form1
 
    Private Sub ButtonPaint(ByVal sender As System.Object, ByVal e As System.Windows.Forms.PaintEventArgs)
        Dim CurButton = DirectCast(sender, Button)
 
        e.Graphics.DrawRectangle(New Pen(Brushes.Black, 4), 0, 0, curButton.Width, curButton.Height)
        e.Graphics.FillRectangle(New SolidBrush(Color.White), 2, 2, curButton.Width - 4, curButton.Height - 4)
 
        Dim StringSize = e.Graphics.MeasureString(curButton.Text, New Font("Segoe UI Light", 12))
        e.Graphics.DrawString(curButton.Text, New Font("Segoe UI Light", 12), Brushes.Black, (CurButton.Width - StringSize.Width) / 2, 
 
(CurButton.Height - StringSize.Height) / 2)
    End Sub
 
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        For Each child In Me.Controls
            If child.GetType().ToString() = "System.Windows.Forms.Button" Then
                AddHandler DirectCast(child, Button).Paint, AddressOf ButtonPaint
            End If
        Next
    End Sub
End Class

Примечание.
Если планируется рисовать свой скин для всех контролов, лучше отключить визуальные стили.
Их размеры могут сильно различаться в зависимости от используемой темы, а это неполезно.

Добавлено через 8 минут
Забыл последние два кода под спойлер убрать.
Хотелось бы, чтобы кто-нибудь отредактировал сообщение или дал такую возможность мне.

Новые блоги и статьи Все статьи Все блоги /
Символьное дифференцирование igorrr37 13.02.2026 / * Логарифм записывается как: (x-2)log(x^2+2) - означает логарифм (x^2+2) по основанию (x-2). Унарный минус обозначается как ! в-строка - входное арифметическое выражение в инфиксной(обычной). . .	Камера Toupcam IUA500KMA Eddy_Em 12.02.2026 Т. к. у всяких "хикроботов" слишком уж мелкий пиксель, для подсмотра в ESPriF они вообще плохо годятся: уже 14 величину можно рассмотреть еле-еле лишь на экспозициях под 3 секунды (а то и больше),. . .	И ясному Солнцу zbw 12.02.2026 И ясному Солнцу, и светлой Луне. В мире покоя нет и люди не могут жить в тишине. А жить им немного лет.	«Знание-Сила» zbw 12.02.2026 «Знание-Сила» «Время-Деньги» «Деньги -Пуля»
SDL3 для Web (WebAssembly): Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 12.02.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами и вызывать обработчики событий столкновения. . . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 11.02.2026 Содержание блога Библиотека SDL3 содержит встроенные инструменты для базовой работы с изображениями - без использования библиотеки SDL3_image. Пошагово создадим проект для загрузки изображения. . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL3_image 8Observer8 10.02.2026 Содержание блога Библиотека SDL3_image содержит инструменты для расширенной работы с изображениями. Пошагово создадим проект для загрузки изображения формата PNG с альфа-каналом (с прозрачным. . .	Установка Qt-версии Lazarus IDE в Debian Trixie Xfce volvo 10.02.2026 В общем, достали меня глюки IDE Лазаруса, собранной с использованием набора виджетов Gtk2 (конкретно: если набирать текст в редакторе и вызвать подсказку через Ctrl+Space, то после закрытия окошка. . .

@АББА 136 / 63 / 24 Регистрация: 08.11.2012 Сообщений: 250
	09.07.2013, 23:33
	Жемчужина примеров кода VB.NET 10 в Visual Studio 2010. 1). *Вставка фрагмента кода IntelliSense...* Использование этих фрагмента кода даёт нам возможность чтобы, сэкономить время на изучение примеров, использование незнакомых возможностей и повторного использования ондного итого же кода. Ещё одно преимущество этой возможности добавлять свои фрагменты кода, это легко сделать в меню Сервис\Диспетчер фрагментов кода...(или же Ctrl+K,Ctrl+B). Вставка фрагмента кода в окне редактора кодов. Выберите нужную позицию курсора в окне редактора кода, затем контекст меню а там "Вставить фрагмент..." (или Ctrl+K,Ctrl+X). 2). Примеры приложений на Visual Basic.NET В этом сборнике рецептов представлены примеры Visual Basic.NET, поставляемые в составе пакета Visual Studio 2010. Это сборный пакет программ, демонстрирующий функции Visual Studio 2010. Сборник находится в VBSample.zip архив его нужно сначала разархивировать (после открываем файл ReadMe.html - здесь описаны все примеры и добавлена ссылка к ним), по умолчанию она находистся здесь: диск на которой VS2010 установлена: \Program Files\Microsoft Visual Studio 10.0\Samples\1049\ Разделы этого примера. Кликните здесь для просмотра всего текста -Примеры приложений -Примеры данных -Примеры языков -Примеры LINQ -Примеры настройки безопасности -Примеры компонентов серверов -Примеры планшетных ПК -Примеры WCF -Примеры Winform 5