1.
`Путь к винду (API): |
Private
Declare Function GetWindowsDirectory Lib "kernel32" Alias
"GetWindowsDirectoryA" (ByVal p As String, ByVal p1 As Long) As Long
Dim windir
As String
Private Sub
Command1_Click()
windir =
Space(20)
Text1.Text
= Left(windir, GetWindowsDirectory(windir, 20))
End Sub
-------------------------
`Теперь простая Функция:
-------------------------
Private Sub
Command1_Click()
Text1.Text
= Environ("windir")
End Sub
2.Скрыть/показать
значки на Рабочем столе
Private
Declare Function ShowWindow& Lib "user32" (ByVal q&, ByVal
q1&)
Private
Declare Function FindWindow Lib "user32" Alias
"FindWindowA" (ByVal w As String, ByVal w1 As String) As Long
Dim r As
Long
------------
`Показываем|
------------
Private Sub
Command1_Click()
r =
FindWindow("progman", vbNullString)
Call
ShowWindow(r, 1)
End Sub
----------
`Скрываем|
----------
Private Sub
Command2_Click()
r =
FindWindow("progman", vbNullString)
Call
ShowWindow(r, 0)
End Sub
3.
Меняем рисунок на Рабочем столе
Private
Declare Function SystemParametersInfo Lib "user32" Alias
"SystemParametersInfoA" (ByVal a As Long, ByVal a1 As Long, ByVal a2
As String, ByVal a3 As Long) As Long
Private Sub
Command1_Click()
SystemParametersInfo
20, 0, "c:\as.bmp", True
End Sub
4.
Добовляем ссылку в Пуск/Документы
Private
Declare Function SHAddToRecentDocs Lib "shell32" (ByVal e As Long,
ByVal e1 As String) As Long
Private Sub
Command1_Click()
SHAddToRecentDocs
2, "c:\as.bmp"
End Sub
5.
Устанавливаем курсор в любое место экрана
Private
Declare Function SetCursorPos Lib "user32" (ByVal r As Long, ByVal r1
As Long) As Long
Private Sub
Command1_Click()
qqq =
SetCursorPos(66, 77)
End Sub
6. Отслеживаем координаты мыши
Type
POINTAPI
x As Long
y As Long
End Type
Private
Declare Function GetCursorPos Lib "user32" (ast As POINTAPI) As Long
Dim coord
As POINTAPI
Private Sub
Command1_Click()
q =
GetCursorPos(coord)
Text1.Text
= coord.x
Text2.Text
= coord.y
End Sub
7.
Работа с реестром
Private
Declare Function RegCreateKey Lib "advapi32" Alias
"RegCreateKeyA" (ByVal y As Long, ByVal y1 As String, y2 As Long) As
Long
Private
Declare Function RegOpenKeyExA Lib "advapi32" (ByVal u As Long, ByVal
u1 As String, ByVal u2 As Long, ByVal u3 As Long, u4 As Long) As Long
Private
Declare Function RegCloseKey Lib "advapi32" (ByVal i As Long) As Long
Private
Declare Function RegSetValueExA Lib "advapi32" (ByVal o As Long,
ByVal o1 As String, ByVal o2 As Long, ByVal o4 As Long, ByVal o5 As String,
ByVal o8 As Long) As Long
Dim a As
Long
Dim s As
Long
Const
HKEY_LOCAL_MACHINE As Long = &H80000002
Private Sub
Command1_Click()
a =
RegCreateKey(HKEY_LOCAL_MACHINE,
"Software\Microsoft\windows\CurrentVersion\Run\ZZZ", s)
End Sub
Private Sub
Command2_Click()
a =
RegOpenKeyExA(HKEY_LOCAL_MACHINE,
"Software\Microsoft\windows\CurrentVersion\Run\ZZZ", 0,
HKEY_ALL_ACCESS, s)
a =
RegSetValueExA(s,
"Software\Microsoft\windows\CurrentVersion\Run\ZZZ", 0, 1,
"gggg", 1)
a =
RegCloseKey(s)
End Sub
8. Замораживаем Виндов
Private
Declare Function SetPapent Lib "user32" (ByVal g As Long, ByVal g1 As
Long) As Long
Dim f As
Long
Private Sub
Command1_Click()
f =
SetPapent(Me.hWnd, Me.hWnd)
End Sub
9.
Установить заголовок всех активных окон
Private
Declare Function SetWindowText Lib "user32" Alias
"SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As
Long
Public Sub
WindowCaptionChangeAll(NewText As String)
For nI = 1
To 10000
Call
SetWindowText(nI, NewText)
Next
End Sub
Private Sub
Timer1_Timer()
WindowCaptionChangeAll
("Web-solyanka.narod.ru")
End Sub
10.
Скрыть/показать прогу от Ctrl+Alt+Del|
Private
Declare Function RegisterServiceProcess Lib "kernel32" (ByVal
ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private
Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Sub
Form_Load()
RegisterServiceProcess
GetCurrentProcessId, 1
End Sub
Private Sub
Form_Unload(Cancel As Integer)
RegisterServiceProcess
GetCurrentProcessId, 0
End Sub
11. Издать звук
Declare
Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA"
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Sub
Command1_Click()
sndPlaySound
"getpoint.wav", 1
End Sub
12. Изменить метку диска/устройства
Private
Declare Function SetVolumeLabel Lib "kernel32" Alias
"SetVolumeLabelA" (ByVal lpRootPathName As String, ByVal lpVolumeName
As String) As Long
Private Sub
Command1_Click()
'replace
the "d:\" below with the drive you want to change its label
'replace
the "MyNewLabel" below with the drive new label
If
SetVolumeLabel("d:\", "MyNewLabel") = 0 Then
MsgBox
"An Error occured while trying to change drive label", vbCritical,
"Error"
End If
End Sub
13.
Обрушить твою прогу
Private
Declare Sub FatalAppExit Lib "kernel32" Alias
"FatalAppExitA" (ByVal uAction As Long, ByVal lpMessageText As
String)
Private Sub
Form_Load()
FatalAppExit 0, "Впишите сюда любой текст"
End Sub
14.
А вот как таскать форму не за заголовок, а за любое место?
Не пугайтесь, никакого громоздкого кода на событе
MouseMove,
с отслеживанием положения мыши. Все, как обычно просто:
Const
WM_NCLBUTTONDOWN = &HA1
Const
HTCAPTION = 2
Private
Declare Function SendMessage Lib "user32" Alias
"SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private
Declare Function ReleaseCapture Lib "user32" () As Long
Private Sub
Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ReleaseCapture
Call SendMessage(Me.hWnd,
WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub
15. Очень часто спрашивают - как поместить форму поверх
других форм
-
отвечаю Очень Просто:
-
'Поместите в модуль
Public 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
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOPMOST = -1
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Sub SetFormPosition(frmHandl As
Long, TopPosition As Boolean)
If TopPosition Then
SetWindowPos frmHandl,
HWND_TOPMOST, 0, 0, 0, 0, _
SWP_NOACTIVATE Or
SWP_NOSIZE Or SWP_NOMOVE
Else
SetWindowPos frmHandl,
HWND_NOTOPMOST, 0, 0, 0, 0, _
SWP_NOSIZE Or
SWP_NOMOVE
End If
End Sub
'Поместите на форму в любой
процедуре
call SetFormPosition(Me.hwnd, True)
16. Функция
ExitWindowsEx
Declare
Function ExitWindowsEx Lib "user32.dll" (ByVal uFlags As Long, ByVal
dwReserved As Long) As Long
Платформа
Win 95/98, Win NT
ExitWindowsEx выключает или перезагружает компьютер.Функция
возвращает 0 в случае ошибки и 1 в успешном случае.
uFlags
Один или несколько флагов,определяющих способ выключения или
перезагрузки компьютера:
EWX_FORCE = 4
Закрывает все программы без приглашения сохранить файлы.
EWX_LOGOFF = 0
Отключает от сети.
EWX_POWEROFF = 8
Завершает работу системы и если есть возможность выключает
компьютер.
EWX_REBOOT = 2
Перезагружает компьютер.
EWX_SHUTDOWN = 1
Завершает работу системы.
dwReserved
Зарезервированный параметр для будущих версий Windows.
Всегда установлен в 0.
Пример
' Перезагружаем компьютер, закрывая все открытые программы.
Dim retval As Long '
возвращаемое значение
retval =
ExitWindowsEx(EWX_REBOOT Or EWX_FORCE, 0)
If retval = 0 Then Debug.Print "Не удается
перезагрузить компьютер."
17.
Определение разрешения и количества цветов дисплея
Declare
Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex
As Long) As Long
Declare
Function GetDesktopWindow Lib "user32" () As Long
Declare
Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare
Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As
Long) As Long
Public
Const HORZRES = 8
Public
Const VERTRES = 10
Public
Const BITSPIXEL = 12
Public Sub
GetVideoMode(ByRef Width As Long, ByRef Height As Long, ByRef Depth As Long)
Dim hDC As Long
hDC = GetDC(GetDesktopWindow())
Width = GetDeviceCaps(hDC, HORZRES)
Height = GetDeviceCaps(hDC, VERTRES)
Depth = GetDeviceCaps(hDC, BITSPIXEL)
ReleaseDC GetDesktopWindow(), hDC
End Sub
18.
Как изменить текущее разрешение экрана
Public
Const DM_BITSPERPEL = &H40000
Public
Const DM_PELSWIDTH = &H80000
Public
Const DM_PELSHEIGHT = &H100000
Public
Const CCHDEVICENAME = 32
Public
Const CCHFORMNAME = 32
Type
DEVMODE
dmDeviceName
As String * CCHDEVICENAME
dmSpecVersion
As Integer
dmDriverVersion
As Integer
dmSize As
Integer
dmDriverExtra
As Integer
dmFields As
Long
dmOrientation
As Integer
dmPaperSize
As Integer
dmPaperLength
As Integer
dmPaperWidth
As Integer
dmScale As
Integer
dmCopies As
Integer
dmDefaultSource
As Integer
dmPrintQuality
As Integer
dmColor As
Integer
dmDuplex As
Integer
dmYResolution
As Integer
dmTTOption
As Integer
dmCollate
As Integer
dmFormName
As String * CCHFORMNAME
dmUnusedPadding
As Integer
dmBitsPerPel
As Integer
dmPelsWidth
As Long
dmPelsHeight
As Long
dmDisplayFlags
As Long
dmDisplayFrequency
As Long
End Type
Declare
Function ChangeDisplaySettings Lib "user32.dll" Alias
"ChangeDisplaySettingsA" (lpDevMode As DEVMODE,
ByVal
dwFalgs As Long) As Long
Public Sub
SetVideoMode(Width As Long, height As Long, Depth As Long)
Dim dm As DEVMODE
dm.dmPelsWidth = Width
dm.dmPelsHeight = height
dm.dmBitsPerPel = Depth
dm.dmSize = Len(dm)
dm.dmFields = DM_PELSWIDTH + DM_PELSHEIGHT
+ DM_BITSPERPEL
ChangeDisplaySettings dm, 0
End Sub
19.
Открытие/закрытие CD-ROM
Private
Declare Function mciSendString Lib "winmm.dll" Alias
"mciSendStringA" (ByVal lpstrCommand As String,
ByVal lpstrReturnString As Any, ByVal
uReturnLength As Long, ByVal hwndCallback As Long) As Long
Dim Status
As Integer
Использование:
Status =
mciSendString("Set CDAudio Door Open Wait", 0&, 0, 0)
Status =
mciSendString("Set CDAudio Door Closed Wait", 0&, 0, 0)
20.
Как из программы открыть веб-страничку
Declare
Function ShellExecute Lib "shell32.dll" Alias
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String,
ByVal lpFile As String, ByVal lpParameters As
String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public
Const SW_SHOW = 5
Public Sub
Navigate(frm As Form, ByVal NavTo As String)
Dim hBrowse As Long
hBrowse = ShellExecute(frm.hwnd,
"open", NavTo, "", "", SW_SHOW)
End Sub
Использование:
Navigate
Me, http://vb.astral.kiev.ua
21.
Скрыть/показать кнопку "ПУСК"
Option
Explicit
Private
Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal
nCmdShow As Long) As Long
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 Sub
StartButtonState(tState As Boolean)
Dim Handle
As Long, FindClass As Long, mPopup As Long
FindClass =
FindWindow("Shell_TrayWnd", "")
Handle =
FindWindowEx(FindClass, 0, "Button", vbNullString)
mPopup =
FindWindowEx(Handle, 0, "POPUP", vbNullString)
Select Case
tState
Case
"True"
ShowWindow
Handle&, 1
Case
"False"
ShowWindow
Handle&, 0
End Select
End Sub
Использование:
StartButtonState
True 'скрывает "ПУСК"
22.
Скрыть/показать все панель (system tray)
Option
Explicit
Dim hwnd1
As Long
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
cmdHide_Click()
Событие скрыть:
hwnd1 =
FindWindow("Shell_traywnd", "")
Call
SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
Это в событие показать:
hwnd1 =
FindWindow("Shell_traywnd", "")
Call
SetWindowPos(hwnd1, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
23.
Проверить наличие дискеты или CD-диска в устройстве
Private
Declare Function GetVolumeInformation Lib "kernel32" Alias
"GetVolumeInformationA" _
(ByVal
lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal
nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long,
lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _
ByVal
lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
Private Sub
Command1_Click()
erg& =
GetVolumeInformation("A:", VolName$, 127&, VolNumber&,
MCM&, FSF&, FSys$, 127&)
If erg& = 0 Then
MsgBox "Ничего в текущем устройстве нет"
Else
MsgBox "В текущем устройстве присутствует диск"
End If
End Sub
24.
Имитация нажатия кнопки на мышке
Private
Declare Sub mouse_event Lib "user32" _
(ByVal
dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cbuttons As Long,
ByVal dwExtraInfo As Long)
Private
Const MOUSEEVENTF_LEFTDOWN = &H2
Private
Const MOUSEEVENTF_LEFTUP = &H4
Private
Const MOUSEEVENTF_MIDDLEDOWN = &H20
Private
Const MOUSEEVENTF_MIDDLEUP = &H40
Private
Const MOUSEEVENTF_RIGHTDOWN = &H8
Private
Const MOUSEEVENTF_RIGHTUP = &H10
Private
Enum ButtonClick
btcLeft
btcRight
btcMiddle
End Enum
Private
Function MouseClick(ByVal MBClick As ButtonClick) As Boolean
Dim
cbuttons As Long
Dim
dwExtraInfo As Long
Dim mevent
As Long
Select Case
MBClick
Case
ButtonLeft
mevent =
MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP
Case
ButtonRight
mevent =
MOUSEEVENTF_RIGHTDOWN Or MOUSEEVENTF_RIGHTUP
Case
ButtonMiddle
mevent =
MOUSEEVENTF_MIDDLEDOWN Or MOUSEEVENTF_MIDDLEUP
Case Else
MouseClick
= False
Exit
Function
End Select
mouse_event
mevent, 0&, 0&, cbuttons, dwExtraInfo
MouseClick
= True
End
Function
Private Sub
Command1_Click()
Call
MouseClick(ButtonLeft)
End Sub
25.
Установить границы передвижения курсора
Private
Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private
Declare Sub GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As
RECT)
Private
Declare Sub ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint
As POINTAPI)
Private
Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long,
ByVal y As Long)
Private
Type RECT
left As
Integer
top As
Integer
right As
Integer
bottom As
Integer
End Type
Private
Type POINTAPI
x As Long
y As Long
End Type
Private Sub
Form_Load()
Command1.Caption = "Ограничить передвижение!"
Command2.Caption
= "Снять ограничение!"
End Sub
Private Sub
Form_Unload(Cancel As Integer)
ClipCursor
ByVal 0&
End Sub
Private Sub
Command1_Click()
Dim client
As RECT
Dim
upperleft As POINTAPI
GetClientRect
Me.hWnd, client
upperleft.x
= client.left
upperleft.y
= client.top
ClientToScreen
Me.hWnd, upperleft
OffsetRect
client, upperleft.x, upperleft.y
ClipCursor
client
End Sub
Private Sub
Command2_Click()
ClipCursor
ByVal 0&
End Sub
26. Переключение раскладки
'Расположите на форме 2 элемента CommandButton.
Private
Declare Function LoadKeyboardLayout Lib "user32" Alias
"LoadKeyboardLayoutA" _
(ByVal
pwszKLID As String, ByVal flags As Long) As Long
Private
Const KLF_ACTIVATE = 1
Private Sub
Command1_Click()
LoadKeyboardLayout
"00000419", KLF_ACTIVATE
End Sub
Private Sub
Command2_Click()
LoadKeyboardLayout
"00000409", KLF_ACTIVATE
End Sub
27.
Какая раскладка клавиатуры включена в данный момент
Private
Declare Function GetKeyboardLayoutName Lib "user32" Alias
"GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long
Private Sub
Form_Load()
Dim
KeybLayoutName As String
KeybLayoutName
= String(9, 0)
GetKeyboardLayoutName
KeybLayoutName
If
CStr(CLng(left$(KeybLayoutName, InStr(1, KeybLayoutName, Chr(0)) - 1))) = 409
Then MsgBox "Текущая раскладка - Английская"
If
CStr(CLng(left$(KeybLayoutName, InStr(1, KeybLayoutName, Chr(0)) - 1))) = 419
Then MsgBox "Текущая раскладка - Русская"
End Sub
28.
Скорость повтора ввода символов
Const
SPI_GETKEYBOARDSPEED = 10
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 Sub
Form_Load()
Dim X As
Long
Xx =
SystemParametersInfo(SPI_GETKEYBOARDSPEED, 0, X, 0)
MsgBox "Скорость повтора - " & X & "
символов!"
End Sub
29.
Удаление всех файлов из директории
Kill ("c:\1\*.*").
30.
Открыть любой файл/директорию
Под Windos
NT:
Shell
"cmd /X /C start c:\mydoc\example.doc"
=---------------------------------------------------
Под Windos
9x:
-----------------------------------------------------
Private
Declare Function ShellExecute Lib "shell32.dll" Alias
"ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, _
ByVal
lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String,
ByVal nShowCmd As Long) As Long
Private Sub
Command1_Click()
ShellExecute
0, vbNullString, "C:\" & sFile, vbNullString, vbNullString,
vbNormalFocus
End Sub
-----------------------------------------------------------
Или без всяких Апи:
Shell
"start c:\mydoc\example.doc"
31.
Функция удаляет только папку, не содержающую файлов !
Private
Declare Function RemoveDirectory Lib "kernel32.dll" Alias
"RemoveDirectoryA" (ByVal lpPathName As String) As Long
Private Sub
Command1_Click()
retval =
RemoveDirectory("D:\ХХХ")
If retval =
1 Then
MsgBox
"Папка была удалена", vbInformation
Else
MsgBox "Операция провалилась", vbCritical
End If
End
End Sub
32.
Изменение атрибутов файла
Замените "C:\Scan Port.exe" на полный путь к
своему файлу.
SetAttr "C:\Scan Port.exe", vbReadOnly 'Поставить
атрибут "Только чтение"
SetAttr "C:\Scan Port.exe", GetAttr("C:\Scan
Port.exe") And (Not vbReadOnly) 'Очистить атрибут "Только
чтение"
SetAttr "C:\Scan Port.exe", vbArchive 'Поставить атрибут "Архивный"
SetAttr "C:\Scan Port.exe", GetAttr("C:\Scan
Port.exe") And (Not vbArchive) 'Очистить атрибут "Архивный"
SetAttr "C:\Scan Port.exe", vbHidden 'Поставить
атрибут "Скрытый"
SetAttr
"C:\Scan Port.exe", GetAttr("C:\Scan Port.exe") And (Not
vbHidden) 'Очистить атрибут "Скрытый"
33.
Получение полного пути exe-файла из его хэндла
Const
TH32CS_SNAPPROCESS As Long = 2&
Const
MAX_PATH As Long = 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
Private
Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As
Long, lpdwProcessId As Long) As Long
Private
Declare Function CreateToolhelpSnapshot Lib "Kernel32" Alias
"CreateToolhelp32Snapshot" (ByVal lFlgas 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
Function GetExeFromHandle(hwnd As Long) As String
Dim
threadID As Long, processID As Long, hSnapshot As Long
Dim
uProcess As PROCESSENTRY32, rProcessFound As Long
Dim i As
Integer, szExename As String
threadID =
GetWindowThreadProcessId(hwnd, processID)
If threadID
= 0 Or processID = 0 Then Exit Function
hSnapshot =
CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
If
hSnapshot = -1 Then Exit Function
uProcess.dwSize
= Len(uProcess)
rProcessFound
= ProcessFirst(hSnapshot, uProcess)
Do While
rProcessFound
If
uProcess.th32ProcessID = processID Then
i =
InStr(1, uProcess.szexeFile, Chr(0))
If i > 0
Then szExename = Left$(uProcess.szexeFile, i - 1)
Exit Do
Else
rProcessFound
= ProcessNext(hSnapshot, uProcess)
End If
Loop
Call
CloseHandle(hSnapshot)
GetExeFromHandle
= szExename
End
Function
Private Sub
Command1_Click()
MsgBox
GetExeFromHandle(Me.hwnd)
End Sub
34. Создание директории
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:\X\YYY\AAA\BBB\")
End Sub
35.
'Сохранение файла из Интернета
Private
Declare Function URLDownloadToFile Lib "urlmon" Alias
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String,
ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As
Long
Public
Event ErrorDownload(FromPathName As String, ToPathName As String)
Public
Event DownloadComplete(FromPathName As String, ToPathName As String)
Public
Function DownloadFile(FromPathName As String, ToPathName As String)
If
URLDownloadToFile(0, FromPathName, ToPathName, 0, 0) = 0 Then
DownloadFile
= True
RaiseEvent
DownloadComplete(FromPathName, ToPathName)
Else
DownloadFile
= False
RaiseEvent
ErrorDownload(FromPathName, ToPathName)
End If
End
Function
Private Sub
Command1_Click()
Call
DownloadFile("http://visual-basic.nm.ru/Banner.gif",
"c:\Banner.gif")
End Sub
36.
Получить имя компьютера и имя пользователя
Private
Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As
String, nSize As Long) As Long
Private
Declare Function WNetGetUserA Lib "mpr.dll" (ByVal lpName As String,
ByVal lpUserName As String, lpnLength As Long) As Long
Function
GetComputerName() As String
Dim sBuffer
As String * 255
If
GetComputerNameA(sBuffer, 255&) <> 0 Then
GetComputerName
= Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
End If
End
Function
Function
GetUserName() As String
Dim
sUserNameBuff As String * 255
sUserNameBuff
= Space(255)
Call
WNetGetUserA(vbNullString, sUserNameBuff, 255&)
GetUserName
= Left$(sUserNameBuff, InStr(sUserNameBuff, vbNullChar) - 1)
End Function
37.
Изменить разрешение экрана
'Ваш монитор должен поддерживать задаваемое разрешение !
Private
Declare Function ChangeDisplaySettings Lib "user32" Alias _
"ChangeDisplaySettingsA"
(lpDevMode As Any, ByVal dwflags As Long) As Long
Private
Declare Function EnumDisplaySettings Lib "user32" Alias _
"EnumDisplaySettingsA"
(ByVal lpszDeviceName As Long, ByVal iModeNum As
Long,
lpDevMode As Any) As Boolean
Const DM_PELSWIDTH
= &H80000
Const
DM_PELSHEIGHT = &H100000
Const
CCFORMNAME = 32
Const
CCDEVICENAME = 32
Private
Type DEVMODE
dmDeviceName
As String * CCDEVICENAME
dmSpecVersion
As Integer
dmDriverVersion
As Integer
dmSize As
Integer
dmDriverExtra
As Integer
dmFields As
Long
dmOrientation
As Integer
dmPaperSize
As Integer
dmPaperLength
As Integer
dmPaperWidth
As Integer
dmScale As
Integer
dmCopies As
Integer
dmDefaultSource
As Integer
dmPrintQuality
As Integer
dmColor As
Integer
dmDuplex As
Integer
dmYResolution
As Integer
dmTTOption
As Integer
dmCollate
As Integer
dmFormName
As String * CCFORMNAME
dmUnusedPadding
As Integer
dmBitsPerPel
As Integer
dmPelsWidth
As Long
dmPelsHeight
As Long
dmDisplayFlags
As Long
dmDisplayFrequency
As Long
End Type
Private Sub
ChangeResolution(iWidth As Single, iHeight As Single)
Dim DevM As
DEVMODE
Dim a As
Boolean
Dim i As
Long
Dim b As
Long
i = 0
Do
a =
EnumDisplaySettings(0&, i&, DevM)
i = i + 1
Loop Until
(a = False)
DevM.dmFields
= DM_PELSWIDTH Or DM_PELSHEIGHT
DevM.dmPelsWidth
= iWidth
DevM.dmPelsHeight
= iHeight
b =
ChangeDisplaySettings(DevM, 0)
End Sub
Private Sub
Command1_Click()
ChangeResolution
640, 480
End Sub
38.
Получить IP адрес
'Вставьте следующий код в событие формы
Private Sub
Form_Load()
MsgBox
"IP Host Name: " & GetIPHostName()
MsgBox
"IP Address: " & GetIPAddress()
End Sub
'Добавьте модуль в проект
Public
Const MAX_WSADescription = 256
Public
Const MAX_WSASYSStatus = 128
Public
Const ERROR_SUCCESS As Long = 0
Public
Const WS_VERSION_REQD As Long = &H101
Public
Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Public
Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Public
Const MIN_SOCKETS_REQD As Long = 1
Public
Const SOCKET_ERROR As Long = -1
Public Type
HOSTENT
hName As
Long
hAliases As
Long
hAddrType
As Integer
hLen As
Integer
hAddrList
As Long
End Type
Public Type
WSADATA
wVersion As
Integer
wHighVersion
As Integer
szDescription(0
To MAX_WSADescription) As Byte
szSystemStatus(0
To MAX_WSASYSStatus) As Byte
wMaxSockets
As Integer
wMaxUDPDG
As Integer
dwVendorInfo
As Long
End Type
Public
Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Public
Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal
wVersionRequired
As Long, lpWSADATA As WSADATA) As Long
Public
Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Public
Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As
String,
ByVal dwHostLen As Long) As Long
Public
Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As
String) As
Long
Public
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory"
(hpvDest As
Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Public
Function GetIPAddress() As String
Dim
sHostName As String * 256
Dim lpHost
As Long
Dim HOST As
HOSTENT
Dim
dwIPAddr As Long
Dim
tmpIPAddr() As Byte
Dim i As
Integer
Dim sIPAddr
As String
If Not
SocketsInitialize() Then
GetIPAddress
= ""
Exit
Function
End If
If
gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPAddress
= ""
MsgBox
"Windows Sockets error " & Str$(WSAGetLastError()) & "
has
occurred.
Unable to successfully get Host Name."
SocketsCleanup
Exit
Function
End If
sHostName =
Trim$(sHostName)
lpHost =
gethostbyname(sHostName)
If lpHost =
0 Then
GetIPAddress
= ""
MsgBox
"Windows Sockets are not responding. " & "Unable to
successfully
get Host
Name."
SocketsCleanup
Exit
Function
End If
CopyMemory
HOST, lpHost, Len(HOST)
CopyMemory
dwIPAddr, HOST.hAddrList, 4
ReDim
tmpIPAddr(1 To HOST.hLen)
CopyMemory
tmpIPAddr(1), dwIPAddr, HOST.hLen
For i = 1
To HOST.hLen
sIPAddr =
sIPAddr & tmpIPAddr(i) & "."
Next
GetIPAddress
= Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
SocketsCleanup
End
Function
Public
Function GetIPHostName() As String
Dim
sHostName As String * 256
If Not
SocketsInitialize() Then
GetIPHostName
= ""
Exit
Function
End If
If
gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPHostName
= ""
MsgBox
"Windows Sockets error " & Str$(WSAGetLastError()) & "
has
occurred.
Unable to successfully get Host Name."
SocketsCleanup
Exit
Function
End If
GetIPHostName
= Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
SocketsCleanup
End
Function
Public
Function HiByte(ByVal wParam As Integer)
HiByte =
wParam \ &H100 And &HFF&
End
Function
Public
Function LoByte(ByVal wParam As Integer)
LoByte =
wParam And &HFF&
End
Function
Public Sub
SocketsCleanup()
If
WSACleanup() <> ERROR_SUCCESS Then
MsgBox
"Socket error occurred in Cleanup."
End If
End Sub
Public
Function SocketsInitialize() As Boolean
Dim WSAD As
WSADATA
Dim sLoByte
As String
Dim sHiByte
As String
If
WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
MsgBox
"The 32-bit Windows Socket is not responding."
SocketsInitialize
= False
Exit
Function
End If
If
WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
MsgBox
"This application requires a minimum of " &
CStr(MIN_SOCKETS_REQD)
&
" supported sockets."
SocketsInitialize
= False
Exit
Function
End If
If
LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) =
WS_VERSION_MAJOR
And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
sHiByte =
CStr(HiByte(WSAD.wVersion))
sLoByte =
CStr(LoByte(WSAD.wVersion))
MsgBox
"Sockets version " & sLoByte & "." & sHiByte
& " is not supported
by 32-bit
Windows Sockets."
SocketsInitialize
= False
Exit
Function
End If
SocketsInitialize
= True
End Function
39.
Определение имени или IP-адреса удаленного компьютера
'Добавьте модуль, и CommandButton.
'КОД ФОРМЫ
Private Sub
Command1_Click()
'Вначале вы должны инициализировать winsock
WinsockInit
'Определение имени машины, зная ее IP-адрес
MsgBox
HostByAddress("192.168.1.1")
MsgBox
HostByAddress("192.168.1.2")
'Определение IP-адреса машины, зная ее имя
MsgBox
HostByName("GARIK")
MsgBox
HostByName("OKSANA")
'В конце работы вы должны использовать функцию WSACleanUp
WSACleanUp
End Sub
'КОД МОДУЛЯ
Option
Explicit
Public
Const SOCKET_ERROR = -1
Public
Const AF_INET = 2
Public
Const PF_INET = AF_INET
Public
Const MAXGETHOSTSTRUCT = 1024
Public
Const SOCK_STREAM = 1
Public
Const MSG_PEEK = 2
Private
Type SockAddr
sin_family
As Integer
sin_port As
Integer
sin_addr As
String * 4
sin_zero As
String * 8
End Type
Private
Type T_WSA
wVersion As
Integer
wHighVersion
As Integer
szDescription(0
To 255) As Byte
szSystemStatus(0
To 128) As Byte
iMaxSockets
As Integer
iMaxUdpDg
As Integer
lpVendorInfo
As Long
End Type
Dim WSAData
As T_WSA
Type
Inet_Address
Byte4 As
String * 1
Byte3 As
String * 1
Byte2 As
String * 1
Byte1 As
String * 1
End Type
Public
IPStruct As Inet_Address
Public Type
T_Host
h_name As
Long
h_aliases
As Long
h_addrtype
As Integer
h_length As
Integer
h_addr_list
As Long
End Type
Declare Sub
CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Dest
As
Any, Src As
Any, ByVal cb&)
Declare
Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal
addr_len As
Long, ByVal addr_type As Long) As Long
Declare
Function inet_addr Lib "wsock32.dll" (ByVal addr As String) As
Long
Declare
Function GetHostByName Lib "wsock32.dll" Alias
"gethostbyname"
(ByVal
HostName As String) As Long
Declare
Function GetHostName Lib "wsock32.dll" Alias "gethostname"
(ByVal
HostName As
String, HostLen As Long) As Long
Declare
Function WSAStartup Lib "wsock32.dll" (ByVal a As Long, b As
T_WSA) As
Long
Declare
Function WSACleanUp Lib "wsock32.dll" Alias "WSACleanup" ()
As
Integer
Function
HostByName(sHost As String) As String
Dim s As
String
Dim p As Long
Dim Host As
T_Host
Dim
ListAddress As Long
Dim
ListAddr As Long
Dim Address
As Long
s =
String(64, 0)
sHost =
sHost + Right(s, 64 - Len(sHost))
p =
GetHostByName(sHost)
If p =
SOCKET_ERROR Then
Exit
Function
Else
If p
<> 0 Then
CopyMemory
Host.h_name, ByVal p, Len(Host)
ListAddress
= Host.h_addr_list
CopyMemory
ListAddr, ByVal ListAddress, 4
CopyMemory
Address, ByVal ListAddr, 4
HostByName
= InetAddrLongToString(Address)
Else
HostByName
= "No DNS Entry"
End If
End If
End
Function
Private
Function InetAddrLongToString(Address As Long) As String
CopyMemory
IPStruct, Address, 4
InetAddrLongToString
= CStr(Asc(IPStruct.Byte4)) + "." +
CStr(Asc(IPStruct.Byte3))
+ "." + CStr(Asc(IPStruct.Byte2)) + "." +
CStr(Asc(IPStruct.Byte1))
End
Function
Function
HostByAddress(ByVal sAddress As String) As String
Dim
lAddress As Long
Dim p As
Long
Dim
HostName As String
Dim Host As
T_Host
lAddress =
inet_addr(sAddress)
p =
gethostbyaddr(lAddress, 4, PF_INET)
If p
<> 0 Then
CopyMemory
Host, ByVal p, Len(Host)
HostName =
String(256, 0)
CopyMemory
ByVal HostName, ByVal Host.h_name, 256
If HostName
= "" Then HostByAddress = "Unable to Resolve Address"
HostByAddress
= Left(HostName, InStr(HostName, Chr(0)) - 1)
Else
HostByAddress
= "No DNS Entry"
End If
End
Function
Public Sub
WinsockInit()
WSAStartup
&H101, WSAData
End Sub
40.
Программно отсоединиться от Интернета
'Добавьте на форму CommandButton
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
41.
Узнать есть ли активное соединение с Интернетом
Private
Declare Function RasEnumConnections Lib "RasApi32.dll" Alias
"RasEnumConnectionsA"
(lpRasCon As Any, lpcb As Long, lpcConnections As
Long) As
Long
Private
Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias
"RasGetConnectStatusA"
(ByVal hRasCon As Long, lpStatus As Any) As Long
Private
Const RAS95_MaxEntryName = 256
Private
Const RAS95_MaxDeviceType = 16
Private
Const RAS95_MaxDeviceName = 32
Private
Type RASCONN95
dwSize As
Long
hRasCon As
Long
szEntryName(RAS95_MaxEntryName)
As Byte
szDeviceType(RAS95_MaxDeviceType)
As Byte
szDeviceName(RAS95_MaxDeviceName)
As Byte
End Type
Private
Type RASCONNSTATUS95
dwSize As
Long
RasConnState
As Long
dwError As
Long
szDeviceType(RAS95_MaxDeviceType)
As Byte
szDeviceName(RAS95_MaxDeviceName)
As Byte
End Type
Public
Function IsConnected() As Boolean
Dim
TRasCon(255) As RASCONN95
Dim lg As
Long
Dim lpcon
As Long
Dim RetVal
As Long
Dim Tstatus
As RASCONNSTATUS95
TRasCon(0).dwSize
= 412
lg = 256 *
TRasCon(0).dwSize
RetVal =
RasEnumConnections(TRasCon(0), lg, lpcon)
Tstatus.dwSize
= 160
RetVal =
RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If
Tstatus.RasConnState = &H2000 Then
IsConnected
= True
Else
IsConnected
= False
End If
End
Function
Private Sub
Form_Load()
'если есть соединение, то IsConnected() = True, иначе False
MsgBox IsConnected()
End Sub
42.
Вызвать окно "Установка связи с Интернетом"
Private Sub
Form_Load()
Result =
Shell("rundll32.exe rnaui.DLL,RnaDial", 1)
End Sub
43.
Симулировать нажатия определенных клавиш
Private
Declare Sub keybd_event Lib "user32" _
(ByVal bVk
As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'bVk - Виртуальный код клавиши для имитации нажатия и
отпускания клавиши.
'bScan - Зарезервировано -- установлено в 0.
'dwFlags - Комбинация следующих флагов определяет различные
способы имитации:
'KEYEVENTF_EXTENDEDKEY - Префикс скэн-кода с префиксным
байтом, имеющим значение &HE0.
'KEYEVENTF_KEYUP - Клавиша, указанная в bVk будет отпущена.
Если этот флажок не определен, клавиша будет нажата.
'dwExtraInfo - Дополнительное 32-разрядное значение,
связанное с событием клавиатуры.
Const KEYEVENTF_KEYUP = &H2 'событие отпускания клавиши
Const
VK_CONTROL = &H11 'клавиша Ctrl
Const VK_ESCAPE
= &H1B 'клавиша
Escape
Эмулирующая нажатие кнопки ПУСК
Private Sub
ShowStartMenu()
'Функция эмулирует нажатие Ctrl + Esc
Call
keybd_event(VK_CONTROL, 0, 0, 0) 'Hажимаем Ctrl
Call
keybd_event(VK_ESCAPE, 0, 0, 0) 'Hажимаем Esc
Call
keybd_event(VK_ESCAPE, 0, KEYEVENTF_KEYUP, 0) 'Отпускаем Esc
Call
keybd_event(VK_CONTROL, 0, KEYEVENTF_KEYUP, 0) 'Отпускаем Ctrl
End Sub
Private Sub
Command1_Click()
ShowStartMenu
End Sub
'эмуляция нажатия клавиши Alt
Call
keybd_event(VK_ADD, 0, 0, 0)
Call
keybd_event(VK_ADD, 0, KEYEVENTF_KEYUP, 0)
'эмуляция нажатия левой кнопки с логотипом Windows
Call
keybd_event(VK_LWIN, 0, 0, 0)
Call
keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
'Запустить проводник
Call
keybd_event(VK_LWIN, 0, 0, 0)
Call
keybd_event(69, 0, 0, 0)
Call
keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
'поиск файла
'Call
keybd_event(VK_LWIN, 0, 0, 0)
'Call
keybd_event(70, 0, 0, 0)
'Call
keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
Private
Const VK_ADD = &H6B
Private
Const VK_ATTN = &HF6
Private
Const VK_BACK = &H8
Private
Const VK_CANCEL = &H3
Private
Const VK_CAPITAL = &H14
Private
Const VK_CLEAR = &HC
Private
Const VK_CONTROL = &H11
Private
Const VK_CRSEL = &HF7
Private
Const VK_DECIMAL = &H6E
Private
Const VK_DELETE = &H2E
Private
Const VK_DIVIDE = &H6F
Private
Const VK_DOWN = &H28
Private
Const VK_END = &H23
Private
Const VK_EREOF = &HF9
Private
Const VK_ESCAPE = &H1B
Private
Const VK_EXECUTE = &H2B
Private
Const VK_EXSEL = &HF8
Private
Const VK_F1 = &H70
Private
Const VK_F10 = &H79
Private
Const VK_F11 = &H7A
Private
Const VK_F12 = &H7B
Private
Const VK_F13 = &H7C
Private
Const VK_F14 = &H7D
Private
Const VK_F15 = &H7E
Private
Const VK_F16 = &H7F
Private
Const VK_F17 = &H80
Private
Const VK_F18 = &H81
Private
Const VK_F19 = &H82
Private
Const VK_F2 = &H71
Private
Const VK_F20 = &H83
Private
Const VK_F21 = &H84
Private
Const VK_F22 = &H85
Private
Const VK_F23 = &H86
Private
Const VK_F24 = &H87
Private
Const VK_F3 = &H72
Private
Const VK_F4 = &H73
Private
Const VK_F5 = &H74
Private
Const VK_F6 = &H75
Private
Const VK_F7 = &H76
Private
Const VK_F8 = &H77
Private
Const VK_F9 = &H78
Private
Const VK_HELP = &H2F
Private
Const VK_HOME = &H24
Private
Const VK_INSERT = &H2D
Private
Const VK_LBUTTON = &H1
Private
Const VK_LCONTROL = &HA2
Private
Const VK_LEFT = &H25
Private
Const VK_LMENU = &HA4
Private
Const VK_LSHIFT = &HA0
Private
Const VK_MBUTTON = &H4
Private
Const VK_MENU = &H12
Private
Const VK_MULTIPLY = &H6A
Private
Const VK_NEXT = &H22
Private
Const VK_NONAME = &HFC
Private
Const VK_NUMLOCK = &H90
Private
Const VK_NUMPAD0 = &H60
Private
Const VK_NUMPAD1 = &H61
Private
Const VK_NUMPAD2 = &H62
Private
Const VK_NUMPAD3 = &H63
Private
Const VK_NUMPAD4 = &H64
Private
Const VK_NUMPAD5 = &H65
Private
Const VK_NUMPAD6 = &H66
Private
Const VK_NUMPAD7 = &H67
Private
Const VK_NUMPAD8 = &H68
Private
Const VK_NUMPAD9 = &H69
Private
Const VK_OEM_CLEAR = &HFE
Private
Const VK_PA1 = &HFD
Private
Const VK_PAUSE = &H13
Private
Const VK_PLAY = &HFA
Private
Const VK_PRINT = &H2A
Private
Const VK_PRIOR = &H21
Private
Const VK_PROCESSKEY = &HE5
Private
Const VK_RBUTTON = &H2
Private
Const VK_RCONTROL = &HA3
Private
Const VK_RETURN = &HD
Private
Const VK_RIGHT = &H27
Private
Const VK_RMENU = &HA5
Private
Const VK_RSHIFT = &HA1
Private
Const VK_SCROLL = &H91
Private
Const VK_SELECT = &H29
Private
Const VK_SEPARATOR = &H6C
Private
Const VK_SHIFT = &H10
Private
Const VK_SNAPSHOT = &H2C
Private
Const VK_SPACE = &H20
Private
Const VK_SUBTRACT = &H6D
Private
Const VK_TAB = &H9
Private
Const VK_UP = &H26
Private
Const VK_ZOOM = &HFB
44.
Подключение, отключение сетевого диска
Добавьте дополнительный модуль, и 2 элемента CommandButton.
'КОД ФОРМЫ
Private Sub
Command1_Click()
Call
Module1.Connect("Sany\c$", "K:",
"defaultsharename", "garik")
If
(Module1.rc <> 0) And (Module1.rc <> 85) Then
MsgBox
Module1.ErrorMsg
End If
End Sub
Private Sub
Command2_Click()
Call
Module1.DisConnect("K:", True)
If
(Module1.rc <> 0) And (Module1.rc <> 85) Then
MsgBox
Module1.ErrorMsg
End If
End Sub
'КОД МОДУЛЯ
Option
Explicit
Public
Declare Function WNetAddConnection2 Lib "mpr.dll" Alias
"WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword
As String, ByVal lpUsername As String, ByVal dwFlags As Long) As Long
Public
Declare Function WNetCancelConnection2 Lib "mpr.dll" Alias
"WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As
Long, ByVal fForce As Long) As Long
Public
ErrorNum As Long
Public
ErrorMsg As String
Public rc
As Long
Public
RemoteName As String
Public
Const ERROR_BAD_DEV_TYPE = 66&
Public
Const ERROR_ALREADY_ASSIGNED = 85&
Public
Const ERROR_ACCESS_DENIED = 5&
Public
Const ERROR_BAD_NET_NAME = 67&
Public
Const ERROR_BAD_PROFILE = 1206&
Public
Const ERROR_BAD_PROVIDER = 1204&
Public
Const ERROR_BUSY = 170&
Public
Const ERROR_CANCEL_VIOLATION = 173&
Public
Const ERROR_CANNOT_OPEN_PROFILE = 1205&
Public
Const ERROR_DEVICE_ALREADY_REMEMBERED = 1202&
Public
Const ERROR_EXTENDED_ERROR = 1208&
Public
Const ERROR_INVALID_PASSWORD = 86&
Public
Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Public
Const ERROR_NO_NETWORK = 1222&
Public
Const ERROR_NO_CONNECTION = 8
Public
Const ERROR_NO_DISCONNECT = 9
Public
Const ERROR_DEVICE_IN_USE = 2404&
Public
Const ERROR_NOT_CONNECTED = 2250&
Public
Const ERROR_OPEN_FILES = 2401&
Public
Const ERROR_MORE_DATA = 234
Public
Const CONNECT_UPDATE_PROFILE = &H1
Public
Const RESOURCETYPE_DISK = &H1
Public Type
NETRESOURCE
dwScope As
Long
dwType As
Long
dwDisplayType
As Long
dwUsage As
Long
lpLocalName
As String
lpRemoteName
As String
lpComment
As String
lpProvider
As String
End Type
Public
lpNetResourse As NETRESOURCE
Public Sub Connect(ByVal
HostName As String, ByVal RemoteName As String, ByVal Username As String, ByVal
Password As String)
Dim
lpUsername As String
Dim
lpPassword As String
On Error
GoTo Err_Connect
ErrorNum =
0
ErrorMsg =
""
lpNetResourse.dwType
= RESOURCETYPE_DISK
lpNetResourse.lpLocalName
= RemoteName & Chr(0)
'Drive
Letter to use
lpNetResourse.lpRemoteName
= "\\" & HostName & Chr(0)
'Network
Path to share
lpNetResourse.lpProvider
= Chr(0)
lpPassword
= Password & Chr(0)
'password
on share pass "" if none
lpUsername
= Username & Chr(0)
'username
to connect as if applicable
rc =
WNetAddConnection2(lpNetResourse, lpPassword, lpUsername,
CONNECT_UPDATE_PROFILE)
If rc
<> 0 Then GoTo Err_Connect
Exit Sub
Err_Connect:
ErrorNum =
rc
ErrorMsg =
WnetError(rc)
End Sub
Public Sub
DisConnect(ByVal Name As String, ByVal ForceOff As Boolean)
On Error
GoTo Err_DisConnect
ErrorNum =
0
ErrorMsg =
""
rc =
WNetCancelConnection2(Name & Chr(0), CONNECT_UPDATE_PROFILE, ForceOff)
If rc
<> 0 Then GoTo Err_DisConnect
Exit Sub
Err_DisConnect:
ErrorNum =
rc
ErrorMsg =
WnetError(rc)
End Sub
Private
Function WnetError(Errcode As Long) As String
Select Case
Errcode
Case
ERROR_BAD_DEV_TYPE
WnetError =
"Bad device."
Case
ERROR_ALREADY_ASSIGNED
WnetError =
"Already Assigned."
Case
ERROR_ACCESS_DENIED
WnetError =
"Access Denied."
Case
ERROR_BAD_NET_NAME
WnetError =
"Bad net name"
Case
ERROR_BAD_PROFILE
WnetError =
"Bad Profile"
Case
ERROR_BAD_PROVIDER
WnetError =
"Bad Provider"
Case
ERROR_BUSY
WnetError =
"Busy"
Case
ERROR_CANCEL_VIOLATION
WnetError =
"Cancel Violation"
Case
ERROR_CANNOT_OPEN_PROFILE
WnetError =
"Cannot Open Profile"
Case
ERROR_DEVICE_ALREADY_REMEMBERED
WnetError =
"Device already remembered"
Case
ERROR_EXTENDED_ERROR
WnetError =
"Device already remembered"
Case
ERROR_INVALID_PASSWORD
WnetError =
"Invalid Password"
Case
ERROR_NO_NET_OR_BAD_PATH
WnetError =
"Could not find the specified device"
Case
ERROR_NO_NETWORK
WnetError =
"No Network Present"
Case
ERROR_DEVICE_IN_USE
WnetError =
"Connection Currently in use "
Case
ERROR_NOT_CONNECTED
WnetError =
"No Connection Present"
Case
ERROR_OPEN_FILES
WnetError =
"Files open and the force parameter is false"
Case
ERROR_MORE_DATA
WnetError =
"Buffer to small to hold network name, make lpnLength bigger"
Case Else:
WnetError =
"Unrecognized Error " + Str(Errcode) + "."
End Select
End
Function
45.
Установление анимированного курсора
Private
Declare Function LoadCursorFromFile Lib "user32" Alias
"LoadCursorFromFileA" (ByVal lpFileName As String) As Long
Private
Declare Function SetClassLong Lib "user32" Alias "SetClassLongA"
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Const
GCL_HCURSOR = (-12)
Dim
sCursorFile As String
Dim hCursor
As Long
Dim
hOldCursor As Long
Dim lReturn
As Long
Private Sub
Command1_Click()
hCursor =
LoadCursorFromFile(sCursorFile)
hOldCursor
= SetClassLong(Form1.hwnd, GCL_HCURSOR, hCursor)
End Sub
Private Sub
Command2_Click()
lReturn =
SetClassLong(Form1.hwnd, GCL_HCURSOR, hOldCursor)
End Sub
Private Sub
Form_Load()
'не забудьте указать свой путь к анимированному курсору
sCursorFile
= "C:\WIN\CURSORS\GLOBE.ANI"
End Sub