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