Язык Visual Basic — примеры написания кода

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

Все коды использовались в среде программирования Microsoft Visual Basic v6.0.

Выход с подтверждением

Первая своего рода программка, ну или функция, это выход с сообщением о подтверждение выхода. В общем, откройте среду программирования Visual Basic, создайте стандартный проект, потом поместите на форму одну кнопку, щелкните на кнопке и у Вас откроется окно редактирования кода, и туда Вам необходимо вставить следующий код:

 Beep
 Dim message As String
 Dim buttonsandicons As Integer
 Dim title As String
 Dim response As String
 message = "Хотите выйти?"
 title = "Выход"
 buttonasicons = vbYesNo + vbQuestion
 response = MsgBox(message, buttonasicons, title)
 If response = vbYes Then
        End
 End If

Итак, Beep это просто звуковой сигнал, дальше идет выделение памяти (Dim), потом уже выполняется действие, т.е. сообщение «Хотите выйти?», да или нет и конец программы. Вот такая бесполезная функция можете использовать в своих программах.

Пароль на запуск программы

Далее идет очень полезный код, это пароль на запуск программы, ну или для чего-нибудь другого. Открывайте стандартный проект щелкните в пустом месте (загрузка формы программы) и вставляйте следующее:

 Dim Password, Pword
 PassWord = "12345"
 Pword = InputBox("Введите пароль")
 If Pword <> PassWord Then
        MsgBox "Пароль не верный"
        End
 End If

Где, 12345 это пароль на запуск программы. Но этот код можно использовать, где только захотите.

Вывод сообщения

Если хотите просто выводить сообщение, для чего-нибудь, то вставьте это:

 Beep
 Dim message As String
 Dim buttonsandicons As Integer
 Dim title As String
 message = "Сообщение"
 title = "Сообщение"
 buttonasicons = vbOKOnly + vbexciamation
 MsgBox message, buttonsandicons, title

Рисование на форме

Дальше идет такая мелкая программа как мини Paint, т.е. рисование, причем на самой форме. Откройте стандартный проект, щелкните в пустом месте и вставьте следующий код:

 Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
        Form1.CurrentX = X
        Form1.CurrentY = Y
 End Sub
 Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Button = 1 Then
                Line (Form1.CurrentX, Form1.CurrentY)-(X, Y), QBColor(0)
        End If
 End Sub

Цвет можете менять с помощью параметра QBColor(0), т.е. вместо 0 поставьте другую цифру.

Перезагрузка компьютера

Для того чтобы перезагрузить компьютер: поместите кнопку и вставьте следующий код:

 Dim strComputer As String
 strComputer = "."
 Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate, (Shutdown)}!\\" _ 
 & strComputer & "\root\cimv2")
 Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
 For Each ObjOperatingSystem In colOperatingSystems
        ObjOperatingSystem.Reboot ' Для перезагрузки
 Next

Запуск программы в единственном экземпляре

Следующий пример поможет Вам сделать так, чтобы программа запускалась только один раз, т.е. в случае повторного запуска она выдаст соответствующее сообщение. В код формы вставьте:

 Private Sub Form_Load()
        If App.PrevInstance = True Then
                MsgBox "Проект уже запущен!"
        End
 End If

Выключение компьютера

Для того чтобы выключить компьютер можно использовать следующий код:

 Dim strComputer As String
 strComputer = "."
 Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate,(Shutdown)}!\\" _ 
 & strComputer & "\root\cimv2")
 Set colOperatingSystems = objWMIService.ExecQuery( "Select * from Win32_OperatingSystem")
 For Each ObjOperatingSystem In colOperatingSystems
        ObjOperatingSystem.ShutDown 'Для выключения
 Next

Завершение любого процесса

Для того чтобы завершить процесс можете использовать следующий код:

 Shell "Cmd /x/c taskkill /f /im ICQlite.exe", vbvhite

Где, вместо ICQlite.exe может быть любой процесс.

Сколько работает компьютер

Ниже показан пример того, как можно определить время работы компьютера. Данный способ основан на использование библиотеки kernel32, поэтому в самом начале кода формы подключите данную DLL.

 Private Declare Function GetTickCount Lib "kernel32" () As Long
 'А в код кнопки:
 Dim a_hour, a_minute, a_second
 a = Format(GetTickCount() / 1000, "0") 'всего секунд
 a_days = Int(a / 86400)
 a = a - a_days * 86400
 a_hour = Int(a / 3600)
 a = a - a_hour * 3600
 a_minute = Int(a / 60)
 a_second = a - a_minute * 60
 MsgBox "Ваш компьютер работает " & Str(a_days) & " дня" & Str(a_hour) _ 
                & " часа " & Str(a_minute) & " минут" & Str(a_second) & " секунд"

Мы рассмотрели простые функции, которые можно использовать практически везде. Теперь рассмотрим более серьезные примеры, и они Вам могут очень сильно помочь написать свои крупные проекты.

Примеры работы с папками

Удалить каталог

 Private Declare Function RemoveDirectory& Lib _ 
        "kernel32" Alias "RemoveDirectoryA" (ByVal lpPathName As String)
 'Удаление каталога (пустого!)
 PathName$ = "D:\t"
 code& = RemoveDirectory(PathName)
 If code& = 0 Then
        'Ошибка удаления каталога
 Else
        'Каталог удален
 End If

Создать каталог

 Sub MakeDir(dirname As String)
 Dim i As Long, path As String
        Do
                i = InStr(i + 1, dirname & "\", "\")
                path = Left$(dirname, i - 1)
                If Right$(path, 1) <> ":" And Dir$(path, vbDirectory) = "" Then
                        MkDir path
                End If
        Loop Until i >= Len(dirname)
 End Sub

 Private Sub Command1_Click()
        Call MakeDir("C:\Soft\1\2\3\")
 End Sub

Список всех папок с под папками

На форму добавляем 2 текстовых поля и кнопку, имя первого текстового поля: StartText, имя второго текстового поля OutText. Свойство Multiline = true, имя кнопки = CmdStart

Далее пишем код в кнопке:

Static running As Boolean
Dim AllDirs As New Collection
Dim next_dir As Integer
Dim dir_name As String
Dim sub_dir As String
Dim i As Integer
Dim txt As String
If running Then
        running = False
        CmdStart.Enabled = False
        CmdStart.Caption = "Stopping"
Else
        running = True
        MousePointer = vbHourglass
        CmdStart.Caption = "Stop"
        OutText.Text = ""
        DoEvents
        next_dir = 1
        AllDirs.Add StartText.Text
        Do While next_dir <= AllDirs.Count
                dir_name = AllDirs(next_dir)
                next_dir = next_dir + 1
                sub_dir = Dir$(dir_name & "\*", vbDirectory)
                Do While sub_dir <> ""
                        If UCase$(sub_dir) <> "PAGEFILE.SYS" And sub_dir <> "." And sub_dir <> ".." Then
                                sub_dir = dir_name & "\" & sub_dir
                        On Error Resume Next
                        If GetAttr(sub_dir) And vbDirectory Then 
                                AllDirs.Add sub_dir
                        End If
                        sub_dir = Dir$(, vbDirectory)
                Loop
                DoEvents
                If Not running Then Exit Do
        Loop
        txt = ""
        For i = 1 To AllDirs.Count
                txt = txt & AllDirs(i) & vbCrLf
        Next i
        OutText.Text = txt
        MousePointer = vbDefault
        unning = False
End If

Теперь запускаем программу, в текстовом поле StartText пишем: C:\windows, и жмем на кнопку.

Размер каталога

Const MAX_PATH = 260
Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib _ 
"kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As
WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib _ 
"kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA)
As Long
Private Declare Function FindClose Lib _ 
"kernel32" (ByVal hFindFile As Long) As Long

Public Function SizeOf(ByVal DirPath As String) As Double
Dim hFind As Long
Dim fdata As WIN32_FIND_DATA
Dim dblSize As Double
Dim sName As String
Dim x As Long
On Error Resume Next
x = GetAttr(DirPath)
If Err Then SizeOf = 0: Exit Function
        If (x And vbDirectory) = vbDirectory Then
                dblSize = 0
                Err.Clear
                sName = Dir$(EndSlash(DirPath) & "*.*", vbSystem Or vbHidden Or vbDirectory)
                If Err.Number = 0 Then
                        hFind = FindFirstFile(EndSlash(DirPath) & "*.*", fdata)
                        If hFind = 0 Then Exit Function
                        Do
                                If (fdata.dwFileAttributes And vbDirectory) = vbDirectory Then
                                        sName = Left$(fdata.cFileName, InStr(fdata.cFileName, vbNullChar) - 1)
                                        If sName <> "." And sName <> ".." Then
                                                dblSize = dblSize + SizeOf(EndSlash(DirPath) & sName)
                                        End If
                                Else
                                        dblSize = dblSize + fdata.nFileSizeHigh * 65536 + fdata.nFileSizeLow
                                End If
                        DoEvents
                        Loop While FindNextFile(hFind, fdata) <> 0
                hFind = FindClose(hFind)
        End If
Else
        On Error Resume Next
        dblSize = FileLen(DirPath)
End If
SizeOf = dblSize
End Function

Private Function EndSlash(ByVal PathIn As String) As String
If Right$(PathIn, 1) = "\" Then
        EndSlash = PathIn
Else
        EndSlash = PathIn & "\"
End If
End Function

Private Sub Form_Load()
        'Замените 'D:\soft' той директорией, размер которой хотите узнать
        MsgBox SizeOf("D:\soft") / 1000000
End Sub

Примеры работы с файлами

Копировать

Допустим, у нас есть файл с именем 1.txt в папке C:\1\ , а нам нужно скопировать его в C:\2\  для этого пишем следующий код:

 Filecopy "C:\1\1.txt","C:\2\1.txt"

Примечание! Если в каталоге 2 уже находится файл с именем 1.txt, то он будет заменен на 1.txt из каталога 1.

Можно использовать и функции API:

Private Declare Function CopyFile Lib _ 
"kernel32.dll" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

Private Sub Command1_Click()
' Скопируем файл C:\1.txt в D:\1.txt.
Dim retval As Long ' возвращаемое значение
'Копируем файл
retval = CopyFile("C:\1.txt", "D:\1.txt", 1)
If retval = 0 Then 'Если ошибка
        MsgBox "Не могу скопировать"
Else 'Если все нормально
        MsgBox "Файл скопирован."
End If
End Sub

Удаление

Например, мы хотим удалить файл 1.txt из корня диска C:\

 Kill ("C:\1.txt")

Способ API

 Private Declare Function DeleteFile Lib _
 "kernel32.dll" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
 Private Sub Command1_Click()
 'Удаляем файл C:\Samples\anyfile.txt
 Dim retval As Long 'Возвращаемое значение
 retval = DeleteFile("C:\1.txt")
 If retval = 1 Then MsgBox "Файл успешно удален."
 End Sub

Перемещение

Можно, например, переместит и так:

 Filecopy "C:\1.txt","C:\2\1.txt"
 Kill ("C:\1.txt")

Но лучше так (через API):

 Private Declare Function MoveFile Lib _
 "kernel32.dll" Alias "MoveFileA" _
 (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long

 Private Sub Command1_Click()
        Dim retval As Long 'Возвращаемое значение
        retval = MoveFile("C:\1.txt", "C:\2\1.txt")
        If retval = 1 Then
                MsgBox "Успешно переместился"
        Else
                MsgBox "Ошибка"
        End If
 End Sub

Переименование

Для того чтобы переименовать файл 1.txt находящийся в C:\ на 2.txt можно использовать следующий код:

 Filecopy "C:\1.txt","C:\2.txt"
 Kill ("C:\1.txt")

Способ API

 Private Declare Function MoveFile Lib _
 "kernel32.dll" Alias "MoveFileA" _
 (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
 Private Sub Command1_Click()
        Dim retval As Long ' возвращаемое значение
        retval = MoveFile("C:\1.txt", "C:\2.txt")
        If retval = 1 Then
                MsgBox "Успешно"
        Else
                MsgBox "Ошибка"
        End If
 End Sub

Определить размер файла

Размер файла можно определить двумя путями:

Если файл можно открыть функцией OPEN, то можно воспользоваться функцией LOF

 Dim FileFree As Integer
 Dim FileSize As Long
 FileFree = FreeFile
 Open "C:\WIN\GENERAL.TXT" For Input As FileFree
 FileSize = LOF(FileFree)
 Close FileFree

Или использовать функцию FileLen

 Dim lFileSize As Long
 FileSize = FileLen("C:\WIN\GENERAL.TXT")

Скрыть часы программно

Добавьте 2 кнопки и вставляйте код:

Option Explicit
Private Declare Function FindWindow Lib _
"user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib _
"user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ShowWindow Lib _
"user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Dim hnd As Long
Private Sub Command1_Click()
        ShowWindow hnd, 0
End Sub
Private Sub Command2_Click()
        ShowWindow hnd, 1
End Sub

Private Sub Form_Load()
        hnd = FindWindow("Shell_TrayWnd", vbNullString)
        hnd = FindWindowEx(hnd, 0, "TrayNotifyWnd", vbNullString)
        hnd = FindWindowEx(hnd, 0, "TrayClockWClass", vbNullString)
        Command1.Caption = "Скрыть часы"
        Command2.Caption = "Показать часы"
End Sub

Добавить иконку в трей

Добавляем модуль, вставляем в него код:

Declare Function Shell_NotifyIconA Lib _
"SHELL32" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Integer
Public Const NIM_ADD = 0
Public Const NIM_MODIFY = 1
Public Const NIM_DELETE = 2
Public Const NIF_MESSAGE = 1
Public Const NIF_ICON = 2
Public Const NIF_TIP = 4

Type NOTIFYICONDATA
        cbSize As Long
        hWnd As Long
        uID As Long
        uFlags As Long
        uCallbackMessage As Long
        hIcon As Long
        szTip As String * 64
End Type
Public Function SetTrayIcon(Mode As Long, hWnd As Long, Icon As Long, tip As String) As Long
        Dim nidTemp As NOTIFYICONDATA
        nidTemp.cbSize = Len(nidTemp)
        nidTemp.hWnd = hWnd
        nidTemp.uID = 0&
        nidTemp.uFlags = NIF_ICON Or NIF_TIP
        nidTemp.uCallbackMessage = 0&
        nidTemp.hIcon = Icon
        nidTemp.szTip = tip & Chr$(0)
        SetTrayIcon = Shell_NotifyIconA(Mode, nidTemp)
End Function

Чтобы использовать вставьте в код формы:

Private Sub Form_Load()
        SetTrayIcon NIM_ADD, Me.hWnd, Me.Icon, "Test"
End Sub

'Чтобы удалить
Private Sub Command1_Click()
        SetTrayIcon NIM_DELETE, Me.hWnd, 0&, ""
End Sub

Блокируем кнопку пуск

Добавляем 2 кнопки и вставляем код:

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function EnableWindow Lib "user32" _
(ByVal hwnd As Long, ByVal fEnable As Long) As Long
Public Sub EnableStartButton(Optional Enabled As Boolean = True)
Dim lHwnd As Long
'найти hWnd
lHwnd& = FindWindowEx(FindWindow("Shell_TrayWnd", ""), 0&, "Button", vbNullString)
Call EnableWindow(lHwnd&, CLng(Enabled))
End Sub

Private Sub Command1_Click()
        EnableStartButton False 'Кнопка ПУСК заблокирована
End Sub

Private Sub Command2_Click()
        EnableStartButton True 'Кнопка ПУСК не заблокирована
End Sub

Считываем параметры из INI файла

Программа подключается к FTP, а в ини файле прописаны параметры — сервер, логин, порт, пароль.

С начало создаем INI файл:

[General]
servname=сервер
usern=Логин
pwd=пароль
port=порт

Его необходимо поместите в папку с программой. Далее, вставляем в модуль:

Private Declare Function WritePrivateProfileString Lib _
"kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, _ 
ByVal lpString As String, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib _
"kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, _ 
ByVal lpDefault As String, ByVal lpReturnedString As String, _ 
ByVal nSize As Long, ByVal lpFileName As String) As Long

Public Function ReadIni(Razdel As String, Param) As String
        ReadIni = GetValue(Razdel, Param, App.Path & "\test.ini", "0")
End Function

Private Function GetValue(ByVal Section As String, _ 
ByVal Key As String, ByVal fFileName As String, Optional ByVal DefaultValue As String = vbNullString) As String
Dim Data As String
Data = String$(1000, Chr$(0))
If GetPrivateProfileString(Section, Key, DefaultValue, Data, 1000, fFileName) > 0 Then
        GetValue = Left$(Data, InStr(Data$, Chr$(0)) - 1)
Else
        GetValue = DefaultValue
End If
Exit Function
End Function

Затем вставляем в код формы:

Private Declare Function InternetOpen Lib _
"wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal nAccessType As Long, ByVal sProxyName As String, _ 
ByVal sProxyBypass As String, ByVal nFlags As Long) As Long
Private Declare Function InternetConnect Lib _
"wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, _ 
ByVal nServerPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal nService As Long, _ 
ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpPutFile Lib _
"wininet.dll" Alias "FtpPutFileA" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, _ 
ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function FtpGetFile Lib _
"wininet.dll" Alias "FtpGetFileA" (ByVal hFtpSession As Long, ByVal lpszRemoteFile As String, _ 
ByVal lpszNewFile As String, ByVal fFailIfExists As Boolean, ByVal dwFlagsAndAttributes As Long, _
ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function InternetCloseHandle Lib _
"wininet.dll" (ByVal hInet As Long) As Integer
Dim rc&
Dim rs&

А в код кнопки:

 rc& = InternetOpen("", 0, vbNullString, vbNullString, 0)
 rs& = InternetConnect(rc&, ReadIni("General", "servname"), "0", _ 
 ReadIni("General", "usern"), ReadIni("General", "pwd"), 1, 0, 0)
 If FtpGetFile(rs&, "Ваш файл.txt", "путь куда", False, 0, 1, 0) = False Then End
 Call InternetCloseHandle(rs&)
 Call InternetCloseHandle(rc&)

Список запущенных процессов

Добавляем Listbox и 1 кнопку, вставляем следующий код:

Option Explicit
Private Declare Function CreateToolhelpSnapshot Lib _
"Kernel32" Alias "CreateToolhelp32Snapshot" _
(ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib _
"Kernel32" Alias "Process32First" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib _
"Kernel32" Alias "Process32Next" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long)

Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Integer = 260

Private Type PROCESSENTRY32
        dwSize As Long
        cntUsage As Long
        th32ProcessID As Long
        th32DefaultHeapID As Long
        th32ModuleID As Long
        cntThreads As Long
        th32ParentProcessID As Long
        pcPriClassBase As Long
        dwFlags As Long
        szExeFile As String * MAX_PATH
End Type

Dim hSnapShot As Long
Dim uProcess As PROCESSENTRY32
Dim r As Long

Private Sub Command1_Click()
        List1.Clear
        hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
        If hSnapShot = 0 Then
                Exit Sub
        End If
        uProcess.dwSize = Len(uProcess)
        r = ProcessFirst(hSnapShot, uProcess)
        Do While r
                List1.AddItem uProcess.szExeFile
                r = ProcessNext(hSnapShot, uProcess)
        Loop
        Call CloseHandle(hSnapShot)
End Sub

Помещение программы в автозагрузку

Для того чтобы программа загружалась вместе с Windows, как и другие некоторые программы, можно использовать реестр:

Добавьте 2 кнопки и следующий код:

Private Sub Command1_Click() 'Запись в реестр
        Set Reg = CreateObject("WScript.Shell")
        Reg.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\Имя твоей проги", _
        "Путь к твоей проге"
End Sub

Private Sub Command2_Click() 'Удаление из реестра
        Set Reg = CreateObject("WScript.Shell")
        Reg.RegDelete "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\Имя твоей проги"
End Sub

А для того чтобы программа загружалась вместе с Windows, даже в безопасном режиме, то такой код:

Для начала более серьезный способ (сделайте на всякий случай резервную копию реестра).

Private Sub Command1_Click()
        Set Reg = CreateObject("WScript.Shell")
        Reg.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\WindowsNT\CurrentVersion\Winlogon\Shell", _
        "Путь к Вашей программе"
End Sub

Private Sub Command2_Click()'Это для восстановления
        Set Reg = CreateObject("WScript.Shell")
        Reg.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\WindowsNT\CurrentVersion\Winlogon\Shell", _
        "Explorer.exe,"
End Sub

Ну и простой способ.

Private Sub Command1_Click()
        Set Reg = CreateObject("WScript.Shell")
        Reg.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\WindowsNT\CurrentVersion\Winlogon\Userinit", _
        "C:\\WINDOWS\\system32\\userinit.exe,Путь к Вашей программе"
End Sub

Private Sub Command2_Click()'Для восстановления
        Set Reg = CreateObject("WScript.Shell")
        Reg.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\WindowsNT\CurrentVersion\Winlogon\Userinit", _
        "C:\\WINDOWS\\system32\\userinit.exe,"
End Sub

Скрываем панель задач

Добавляем 2 кнопки и вставляем код:

Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const SWP_HIDEWINDOW = &H80
Const SWP_SHOWWINDOW = &H40

'Скрывает
Private Sub Command1_Click()
        hwnd1 = FindWindow("Shell_traywnd", "")
        Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub
'Показывает
Private Sub Command2_Click()
        hwnd1 = FindWindow("Shell_traywnd", "")
        Call SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub

Разархивировать архив RAR

Для того чтобы разархивировать архив RAR можно использовать следующий код:

 WinRarApp = "C:\Program Files\WinRAR\WinRAR.exe  x -o+"
 iPath = "C:\"
 iArhivName = "Имя файла.rar"
 adr = WinRarApp & " """ & iPath & iArhivName & """ """ & iPath & """ "
 RetVal = Shell(adr, vbHide)

Сколько оперативной памяти в компьютере

Добавьте одну кнопку и вставляйте следующий код:

Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As TMemoryStatus)
Private Type TMemoryStatus
        dwLength As Long
        dwMemoryLoad As Long
        dwTotalPhys As Long
        dwAvailPhys As Long
        dwTotalPageFile As Long
        dwAvailPageFile As Long
        dwTotalVirtual As Long
        dwAvailVirtual As Long
End Type

Dim ms As TMemoryStatus

Private Sub Command1_Click()
        ms.dwLength = Len(ms)
        Call GlobalMemoryStatus(ms)
        MsgBox "Всего:" & ms.dwTotalPhys & vbCr & "Свободно:" _
        & ms.dwAvailPhys & vbCr & "Используется в % :" & ms.dwMemoryLoad
End Sub

Скрыть значки рабочего стола

Это делается следующим образом. Добавите 2 кнопки и вставляйте следующий код:

Private Declare Function ShowWindow& Lib "user32" (ByVal hwnd&, ByVal nCmdShow&)
Private Declare Function FindWindow Lib _ 
"user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Const SW_HIDE = 0
Const SW_NORMAL = 1

Private Sub Command1_Click()
        Dim hHandle As Long
        hHandle = FindWindow("progman", vbNullString)
        Call ShowWindow(hHandle, SW_HIDE)
End Sub

Private Sub Command2_Click()
        Dim hHandle As Long
        hHandle = FindWindow("progman", vbNullString)
        Call ShowWindow(hHandle, SW_NORMAL)
End Sub

С помощью кнопки Command1 значки скрываются, Command2 — появляются.

На этом у меня все, надеюсь, вышеперечисленные примеры будут Вам полезны, пока!