Сборник примеров кода Visual Basic (стр. 2 из 2)

Public Sub AsProgram(FileType As String)

Dim retval As Long

Dim Result As Long

Dim SA As SECURITY_ATTRIBUTES

Dim sPath As String

'// Создаем ключ для программы
retval = RegCreateKeyEx(HKEY_CLASSES_ROOT, App.Title, 0, vbNullString, 0, KEY_ALL_ACCESS, SA, Result, &H1)

'// Присваиваем значению по умолчанию название программы

RegSetValueEx Result, "", 0, REG_SZ, ByVal App.Title, Len(App.Title)

'// Создаём ключ, связанный с расширением файла

retval = RegCreateKeyEx(HKEY_CLASSES_ROOT, FileType, 0, vbNullString, 0, KEY_ALL_ACCESS, SA, Result, &H1)

'// Присваиваем значению по умолчанию название программы

RegSetValueEx Result, "", 0, REG_SZ, ByVal App.Title, Len(App.Title)

'// Последние шаг - ассоциация типа с приложением

'// Определяем командную строку для приложения

If Right(App.Path, 1) = "\" Then

sPath = App.Path & App.EXEName & ".exe %1"

Else

sPath = App.Path & "\" & App.EXEName & ".exe %1"

End If

retval = RegCreateKeyEx(HKEY_CLASSES_ROOT, App.Title & "\shell\open\command", 0, vbNullString, 0, KEY_ALL_ACCESS, SA, Result, &H1)

RegSetValueEx Result, "", 0, REG_SZ, ByVal sPath, Len(sPath)

End Sub

В начало

Убираем программу из списка Alt+Ctrl+Del.

Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Public Const RSP_SIMPLE_SERVICE = 1
Public Const RSP_UNREGISTER_SERVICE = 0

Чтобы убрать вашу программу из списка Ctrl+Alt+Delete list, используйте процедуру MakeMeService:

Public Sub MakeMeService()
Dim pid As Long
Dim reserv As Long
pid = GetCurrentProcessId()
regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE)
End Sub

Чтобы показать вашу программу в списке Ctrl+Alt+Delete, используйте процедуру UnMakeMeService:

Public UnMakeMeService()
Dim pid As Long
Dim reserv As Long
pid = GetCurrentProcessId()
regserv = RegisterServiceProcess(pid, RSP_UNREGISTER_SERVICE)
End Code

В начало

Разрываем соединение с Internet.

Поместите на форму кнопку с именем Command1

Const RAS_MAXENTRYNAME As Integer = 256
Const RAS_MAXDEVICETYPE As Integer = 16
Const RAS_MAXDEVICENAME As Integer = 128
Const RAS_RASCONNSIZE As Integer = 412
Const ERROR_SUCCESS = 0&

Private Type RasEntryName
dwSize As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
End Type

Private Type RasConn
dwSize As Long
hRasConn As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
szDeviceType(RAS_MAXDEVICETYPE) As Byte
szDeviceName(RAS_MAXDEVICENAME) As Byte
End Type

Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long

Private Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" (ByVal hRasConn As Long) As Long

Private gstrISPName As String
Public ReturnCode As Long

Public Sub HangUp()
Dim i As Long
Dim lpRasConn(255) As RasConn
Dim lpcb As Long
Dim lpcConnections As Long
Dim hRasConn As Long

lpRasConn(0).dwSize = RAS_RASCONNSIZE
lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize
lpcConnections = 0
ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)
If ReturnCode = ERROR_SUCCESS Then
For i = 0 To lpcConnections - 1
If Trim(ByteToString(lpRasConn(i).szEntryName)) = Trim(gstrISPName) Then
hRasConn = lpRasConn(i).hRasConn
ReturnCode = RasHangUp(ByVal hRasConn)
End If
Next i
End If
End Sub

Public Function ByteToString(bytString() As Byte) As String
Dim i As Integer
ByteToString = ""
i = 0
While bytString(i) = 0&
ByteToString = ByteToString & Chr(bytString(i))
i = i + 1
Wend
End Function

Private Sub Command1_Click()
Call HangUp
End Sub

В начало

Подключен ли к сети компьютер.

Private Declare Function InternetGetConnectedStateEx Lib "wininet.dll" Alias "InternetGetConnectedStateExA" (lpdwFlags As Long, lpszConnectionName As Long, dwNameLen As Long, ByVal dwReserved As Long) As Long

Private Sub Form_Load()
Dim strConnectionName As String
Dim lNameLen As Long
Dim lRetVal As Long
Dim lConnectionFlags As Long
Dim lPtr As Long
Dim lNameLenPtr As Long

strConnectionName = Space(256)
lNameLen = 256
lPtr = StrPtr(strConnectionName)
lNameLenPtr = VarPtr(lNameLen)

lRetVal = InternetGetConnectedStateEx(lConnectionFlags, ByVal lPtr, ByVal lNameLen, 0&)

If lRetVal <> 0 Then
MsgBox("Комп в сети")
Else
MsgBox("Комп не в сети")
End If
End Sub

В начало

Блокируем Alt+Ctrl+Del.

'Пример 1
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_SCREENSAVERRUNNING = 97&

Public Sub AllowKeys(bParam As Boolean)
Dim lRetVal As Long, bOld As Boolean
lRetVal = SystemParametersInfo(SPI_SCREENSAVERRUNNING, bParam, bOld, 0&)
End Sub

Private Sub Form_Load()
Call AllowKeys(True) 'блокировка сочетаний
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call AllowKeys(False) 'разблокировка сочетаний
End Sub

'Пример 2
Const SPI_SCREENSAVERRUNNING = 97
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Sub Command1_Click()
Call SystemParametersInfo(SPI_SCREENSAVERRUNNING, True, "1", 0)
End Sub

Private Sub Command2_Click()
Call SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, "1", 0)
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call SystemParametersInfo(SPI_SCREENSAVERRUNNING, False, "1", 0)
End Sub

В начало

Подсчет свободной памяти в данный момент.

Private Type MEMORYSTATUS
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

Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)

Const fmt As String = "###,###,###,###"
Const skb As String = " Kb"
Const nkb As Long = 1024

Private Sub Form_Load()

Dim MS As MEMORYSTATUS

MS.dwLength = Len(MS)

GlobalMemoryStatus MS

lbMemStat(0) = Format$(MS.dwMemoryLoad, fmt) & " % Use"

lbMemStat(1) = Format$(MS.dwTotalPhys / nkb, fmt) & skb

lbMemStat(2) = Format$(MS.dwAvailPhys / nkb, fmt) & skb

lbMemStat(3) = Format$(MS.dwTotalPageFile / nkb, fmt) & skb

lbMemStat(4) = Format$(MS.dwAvailPageFile / nkb, fmt) & skb

lbMemStat(5) = Format$(MS.dwTotalVirtual / nkb, fmt) & skb

lbMemStat(6) = Format$(MS.dwAvailVirtual / nkb, fmt) & skb

End Sub

В начало

Получение информации об окнах

1. Поиск окна по его заголовку

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'Процедура для получения манипулятора окна по его заголовку
Public Function GetHwnd(Caption As String) As Long
Dim hwnd As Long
hwnd = FindWindow(vbNullString, Caption) 'Caption - заголовок окна
GetHwnd = hwnd
End Function

2. Поиск окна по его классу

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'Процедура для получения манипулятора окна по его классу
Public Function GetHwnd(Class As String) As Long
Dim hwnd As Long
hwnd = FindWindow(Class, vbNullString)
GetHwnd = hwnd
End Function

3. Поиск дочернего окна

'Функция для получения окна первого уровня

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

'Разместите на форме кнопку (Command1)

Private Sub Command1_Click()
Dim hwnd As Long
hwnd = FindWindow("Класс родителя", "Заголовок родителя") 'Поиск родителя
hwnd = FindWindowEx(hwnd, 0, "Класс дочернего окна", "Заголовок дочернего окна") 'Поиск дочернего окна
End Sub

В начало

Окна и манипуляторы

1. Скрываем кнопку Пуск:

1. Создайте новый проект.
2. На создавшейся вместе с проектом форме разместите две кнопки.
3. Назовите первую кнопку cmdHide, и измените, свойство Caption на "Скрыть кнопку Пуск", вторую кнопку назовите cmdShow и измените Caption на "Показать кнопку Пуск".

4. Добавьте следующий код:

'Функция для поиска окна первого уровня
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 Form_Load()
'Кнопка Пуск является дочерним окном панели задач
'Кнопка Пуск относится к классу "BUTTON", Панель задач относится к классу "Shell_TrayWnd"
'Ищем, манипулятор панели задач
hnd = FindWindow("Shell_TrayWnd", vbNullString)
'Ищем манипулятор кнопки пуск
hnd = FindWindowEx(hnd, 0, "BUTTON", vbNullString)
End Sub

Private Sub cmdHide_Click()
'Скрываем окно с заданным манипулятором
ShowWindow hnd, 0
End Sub

Private Sub cmdShow_Click()
'Показываем окно с заданным манипулятором
ShowWindow hnd, 1
End Sub

2. Меняем заголовок заданного окна

1. Создайте новый проект.
2. На создавшейся вместе с проектом форме разместите две метки, два текстовых поля и одну кнопку
3. Назовите первое текстовое поле txt1, второе txt2, кнопку cmdRename.

4. Добавьте следующий код:

'Функция для поиска окна первого уровня
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Функция для изменения заголовка окна
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long

Private Sub cmdRename_Click()
Dim hwn As Long
'Ищем окно по его заголовку
hwn = FindWindow(vbNullString, txt1)
'Меняем заголовок окна
SetWindowText hwn, txt2
End Sub

В начало

Отключение системного меню

'процедура определения системного меню

Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long

'процедура удаления меню
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long

Sub Disable_SysMenu(handle As Long)
Dim menu_handle As Long 'переменная с хэндлом меню
menu_handle = GetSystemMenu(handle, 0)

DestroyMenu (menu_handle)
End Sub

handle =vForm.hwnd , где vForm - форма, над которой нужно поиздеваться

В начало

Заставляем VB работать с модемом.

Подключай к проекту mscomm32.ocx.

MSComm1.CommPort = 2 'номер порта
MSComm1.Settings = "9600,n,8,1" 'параметры порта
MSComm1.PortOpen = True 'открываем указанный выше порт
MSComm1.Output = "AT" 'пересылаем в порт
tim = Timer 'В течение 3-х секунд
1 DoEvents 'ждем ответ от модема
If tim + 3 > Timer Then Goto 1 '
receive$ = MSComm1.Input 'принимаем с порта
MSComm1.PortOpen = False 'закрываем порт

В начало

Размещение окна поверх всех

Public Declare Sub 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)
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40

' Для размещения окна OnTop:

SetWindowPos Form1.hWnd, HWND_TOPMOST, Form1.Left / 15, Form1.Top / 15, Form1.Width / 15, Form1.Height / 15, SWP_NOACTIVATE Or SWP_SHOWWINDOW

' Для возвращения окну нормального статуса:

SetWindowPos Form1.hWnd, HWND_NOTOPMOST, Form1.Left / 15, Form1.Top / 15, Form1.Width / 15, Form1.Height / 15, SWP_NOACTIVATE Or SWP_SHOWWINDO

Заменить "Form1" на имя вашей формы или поставить "Me" или вообще опустить название формы (для текущей формы). Число 15 было бы правильно заменить на значения Screen.TwipsPerPixelX и Screen.TwipsPerPixelY.

В начало