«Visual Basic» - Обучение написания программ | Коды Visual Basic
Всем привет, в этой статье я хочу показать вам полезные коды небольших программ. Которые вы можете использовать для написание уже своих более серьезных программ, ну или вы искали именно эти функции которые здесь описаны. Все коды использовались в среде программирования Microsoft Visual Basic v6.0
1) Первый своего рода программка, ну или функция, это выход с сообщением о подтверждение выхода. Короче откройте среду программирования 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
End Sub
Итак, Beep это просто звуковой сигнал, дальше идет выделение памяти (Dim) для операторов, потом уже выполняется действие т.е. сообщение "хотите выйте?" да или нет и конец программы. Вот такая бесполезная функция можете использовать в своих программах.
2) Далее очень полезный код, это пароль на запуск программы, ну или для чего-нибудь другова. Короче, откройте стандартный проект щелкните в пустом месте (загрузка формы программы) и вставьте следующие:
Dim Password, Pword
PassWord = "12345"
Pword = InputBox("Введите пароль")
If Pword <> PassWord Then
MsgBox "Пароль не верный"
End
End If
Где 12345 это пароль при запуске проги. Но этот код можно использовать где только захотите.
3)Если хотите просто выводить сообщение, для чего-нибудь то вставьте это:
Beep
Dim message As String
Dim buttonsandicons As Integer
Dim title As String
message = "сообщение"
title = "сообщение"
buttonasicons = vbOKOnly + vbexciamation
MsgBox message, buttonsandicons, title
End Sub
4) Дальше идет такая мелкая прога как мини 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 поставьте другую цифру.
5) Теперь допустим вам нужно перезагрузить компьютер сделайте следующие: поместите кнопку и вставьте следующие
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each ObjOperatingSystem In colOperatingSystems
ObjOperatingSystem.Reboot ' Для перезагрузки
Next
6) Далее идет полезная, на мой взгляд функция, программа может быть запущена только один раз т.е. прога информирует вас если вы пытаетесь запустить ее одновременно второй раз. В форму вставьте:
Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "Проект уже запущен!"
End
End If
7) А для выключения компа вставьте:
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
8) Такая вот штучка как завершение любого процесса, добавьте кнопку и в нее это:
9) Теперь сделать вот что, напишем программу, которая показывает, сколько работает наш компьютер. Откройте стандартный проект и добавьте одну кнопку, и давайте объявим с вами одну 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. Допустим у нас есть один файлик с именем 1.txt в папке C:\1\ , а нам нужно скопировать его в C:\2\ . Все просто, пишем следующие: Filecopy "C:\1\1.txt","C:\2\1.txt" (*Внимание! Если в каталоге 2 уже находиться файлик с именем 1.txt , то он будет заменен на 1.txt из каталога 1 !!!)
2 способ api обычно я делаю через 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. Например мы хотим удалить файл 1.txt из корневой диска C: Пишем: Kill ("C:\1.txt")
2. Способ 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 Перемещение
1. для этого мы используем два оператора сразу. Например нам нужно переместить файл 1.txt из C:\ в C:\2\ . Пишем: Filecopy "C:\1.txt","C:\2\1.txt" Kill ("C:\1.txt")
2. Способ 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. Надо переименовать файл 1.txt находящийся в C:\ на 2.txt . Пишем: Filecopy "C:\1.txt","C:\2.txt" Kill ("C:\1.txt")
2. способ 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 Определить размер файла
1. Если файл можно открыть функцией 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
2. Используя функцию 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) 'this will enable/disable any window with a little modifaction Dim lHwnd As Long 'найти hWnd lHwnd& = FindWindowEx(FindWindow("Shell_TrayWnd", ""), 0&, "Button", vbNullString) 'call the enablewindow api and do the what needs to be done Call EnableWindow(lHwnd&, CLng(Enabled)) End Sub
Private Sub Command1_Click() EnableStartButton False 'Кнопка ПУСК заблокирована End Sub
Private Sub Command2_Click() EnableStartButton True 'Кнопка ПУСК не заблокирована End Sub
«INI Файлы» - Привязка к exe, Пример.
Программа довольна проста, она подключается к 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& А в код кнопки следующее:
Добавляем 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
Помещение в автозагрузку программы
1) Для того чтобы программа загружалась вместе с 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
2) А для того чтобы программа грузилась вместе с windows даже в безопасном режиме то такой код:
Для начала более жесткий способ (сделайте на всякий случай резервную копию реестра)
Private Sub Command1_Click() Set Reg = CreateObject("WScript.Shell")
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
Command1 - Скрывает
Command2 - Показывает
Разархивировать архив rar
Вставляем код в любое место хоть в форму хоть в кнопку, архив должен лежать в корне диска С, разархивирует он ту даже.
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 - появляются.
Если вдруг у вас возникли проблемы с использованием всех вышеперечисленных примеров (они у вас не работают) то для этого у нас есть форум для программистов на котором можно задать интересующие вас вопросы
Вот, пожалуй пока все что я хотел рассказать о полезных кодах Visual Basic.
Все хочешь знать?(Эта группа для тебя)
«Visual Basic» - Примеры написания кода
Всем привет, в этой статье я хочу показать вам полезные коды небольших программ. Которые вы можете использовать для написание уже своих более серьезных программ, ну или вы искали именно эти функции которые здесь описаны. Все коды использовались в среде программирования Microsoft Visual Basic v6.0
1) Первый своего рода программка, ну или функция, это выход с сообщением о подтверждение выхода. Короче откройте среду программирования 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
End Sub
Итак, Beep это просто звуковой сигнал, дальше идет выделение памяти (Dim) для операторов, потом уже выполняется действие т.е. сообщение "хотите выйте?" да или нет и конец программы. Вот такая бесполезная функция можете использовать в своих программах.
2) Далее очень полезный код, это пароль на запуск программы, ну или для чего-нибудь другова. Короче, откройте стандартный проект щелкните в пустом месте (загрузка формы программы) и вставьте следующие:
Dim Password, Pword
PassWord = "12345"
Pword = InputBox("Введите пароль")
If Pword <> PassWord Then
MsgBox "Пароль не верный"
End
End If
Где 12345 это пароль при запуске проги. Но этот код можно использовать где только захотите.
3)Если хотите просто выводить сообщение, для чего-нибудь то вставьте это:
Beep
Dim message As String
Dim buttonsandicons As Integer
Dim title As String
message = "сообщение"
title = "сообщение"
buttonasicons = vbOKOnly + vbexciamation
MsgBox message, buttonsandicons, title
End Sub
4) Дальше идет такая мелкая прога как мини 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 поставьте другую цифру.
5) Теперь допустим вам нужно перезагрузить компьютер сделайте следующие: поместите кнопку и вставьте следующие
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
6) Далее идет полезная, на мой взгляд функция, программа может быть запущена только один раз т.е. прога информирует вас если вы пытаетесь запустить ее одновременно второй раз. В форму вставьте:
Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "Проект уже запущен!"
End
End If
7) А для выключения компа вставьте:
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
8) Такая вот штучка как завершение любого процесса, добавьте кнопку и в нее это:
Shell "Cmd /x/c taskkill /f /im ICQlite.exe", vbvhite
Где ICQlite.exe может быть любой процесс.
9) Теперь сделать вот что, напишем программу, которая показывает, сколько работает наш компьютер. Откройте стандартный проект и добавьте одну кнопку, и давайте объявим с вами одну 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. Допустим у нас есть один файлик с именем 1.txt в папке C:\1\ , а нам нужно скопировать его в C:\2\ .
Все просто, пишем следующие:
Filecopy "C:\1\1.txt","C:\2\1.txt"
(*Внимание! Если в каталоге 2 уже находиться файлик с именем 1.txt , то он будет заменен на 1.txt из каталога 1 !!!)
2 способ api
обычно я делаю через 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. Например мы хотим удалить файл 1.txt из корневой диска C:
Пишем:
Kill ("C:\1.txt")
2. Способ 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
Перемещение
1. для этого мы используем два оператора сразу. Например нам нужно переместить файл 1.txt из C:\ в C:\2\ . Пишем:
Filecopy "C:\1.txt","C:\2\1.txt"
Kill ("C:\1.txt")
2. Способ 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. Надо переименовать файл 1.txt находящийся в C:\ на 2.txt .
Пишем:
Filecopy "C:\1.txt","C:\2.txt"
Kill ("C:\1.txt")
2. способ 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
Определить размер файла
1. Если файл можно открыть функцией 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
2. Используя функцию 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)
'this will enable/disable any window with a little modifaction
Dim lHwnd As Long
'найти hWnd
lHwnd& = FindWindowEx(FindWindow("Shell_TrayWnd", ""), 0&, "Button", vbNullString)
'call the enablewindow api and do the what needs to be done
Call EnableWindow(lHwnd&, CLng(Enabled))
End Sub
Private Sub Command1_Click()
EnableStartButton False 'Кнопка ПУСК заблокирована
End Sub
Private Sub Command2_Click()
EnableStartButton True 'Кнопка ПУСК не заблокирована
End Sub
«INI Файлы» - Привязка к exe, Пример.
Программа довольна проста, она подключается к 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
Помещение в автозагрузку программы
1) Для того чтобы программа загружалась вместе с 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
2) А для того чтобы программа грузилась вместе с 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
Command1 - Скрывает
Command2 - Показывает
Разархивировать архив 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 - появляются.
Если вдруг у вас возникли проблемы с использованием всех вышеперечисленных примеров (они у вас не работают) то для этого у нас есть форум для программистов на котором можно задать интересующие вас вопросы
Вот, пожалуй пока все что я хотел рассказать о полезных кодах Visual Basic.
Удачи в написание собственных программ!