Option Compare Database
Option Explicit

 '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. А вот как таскать форму не за заголовок, а за любое место?
'#########################

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://vkontakte.ru"

 '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()
    dKeyboardLayout "00000419", KLF_ACTIVATE
End Sub

Private Sub Command2_Click()
    adKeyboardLayout "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" Alias "WSACleanup" () As Long

Public Declare Function GetHostName Lib "wsock32.dll" Alias "gethostname" (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" _
(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()
    ult = 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

 '46. Загрузка разных курсоров
'#########################

' Константы из API интерфейса
Const IDC_ARROW =  32512 & 'Стрелка
Const IDC_IBEAM =  32513 & 'Тип - I
Const IDC_WAIT =  32514 & 'Часы
Const IDC_CROSS =  32515 & 'Перекрестие
Const IDC_UPARROW =  32516 & 'Верх
Const IDC_SIZE =  32640 & 'Размер
Const IDC_ICON =  32641 &
Const IDC_SIZENWSE =  32642 & 'Стрелки размеров
Const IDC_SIZENESW =  32643 &
Const IDC_SIZEWE =  32644 &
Const IDC_SIZENS =  32645 &
Const IDC_SIZEALL =  32646 &
Const IDC_NO =  32648 & 'Стоп курсор
Const IDC_APPSTARTING =  32650 & 'Стрелка и часы
Const IDC_HAND =  32649 &

' Загружает курсор из ресурса
Private Declare Function apiLoadCursorBynum Lib "user32" Alias "LoadCursorA" _
     (ByVal hInstance As Long, _
     ByVal lpCursorName As Long) _
     As Long

' Устанавливает курсор
Private Declare Function apiSetCursor Lib "user32" Alias "SetCursor" _
     (ByVal hCursor As Long) _
     As Long

' Загружает курсор из файла
Private Declare Function apiLoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" _
     (ByVal lpFileName As String) _
     As Long

'Указатель на курсор
Dim hCursor As Long

'    Загружаем курсор
Private Sub Объекты_AfterUpdate()
     On Error GoTo  999 
     Select Case Me.Объекты
         Case  1 : 'Указатель
             hCursor = apiLoadCursorBynum( 0 , IDC_ARROW)
         Case  2 : 'Редактор
             hCursor = apiLoadCursorBynum( 0 , IDC_IBEAM)
         Case  3 : 'Часы
             hCursor = apiLoadCursorBynum( 0 , IDC_WAIT)
         Case  4  'Перекрестие
             hCursor = apiLoadCursorBynum( 0 , IDC_CROSS)
         Case  5 : 'Стрелка вверх
             hCursor = apiLoadCursorBynum( 0 , IDC_UPARROW)
         Case  6 : 'Размер
             hCursor = apiLoadCursorBynum( 0 , IDC_SIZE)
         Case  7 : 'Иконка
             hCursor = apiLoadCursorBynum( 0 , IDC_ICON)
         Case  8 : 'Стрелка
             hCursor = apiLoadCursorBynum( 0 , IDC_SIZENWSE)
         Case  9  'Стрелка
             hCursor = apiLoadCursorBynum( 0 , IDC_SIZENESW)
         Case  10  'Стрелка
             hCursor = apiLoadCursorBynum( 0 , IDC_SIZEWE)
         Case  11  'Стрелка
             hCursor = apiLoadCursorBynum( 0 , IDC_SIZENS)
         Case  12  'Стрелка
             hCursor = apiLoadCursorBynum( 0 , IDC_SIZEALL)
         Case  13  'Стоп курсор
             hCursor = apiLoadCursorBynum( 0 , IDC_NO)
         Case  14  'Старт приложения
             hCursor = apiLoadCursorBynum( 0 , IDC_APPSTARTING)
         Case  15  'Загрузить из файла
             hCursor = apiLoadCursorFromFile( _
             Application.CurrentProject.path & _
             "\la_api.cur")
         Case  16  'Рука курсор
             hCursor = apiLoadCursorBynum( 0 , IDC_HAND)
     End Select
     Exit Sub
 999 :
     MsgBox Err.Description  'Ошибка
     Err.Clear
End Sub

'  Изменяем курсор
Private Sub Пример_01_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Call apiSetCursor(hCursor)
End Sub

 '47. Отображение/скрытие окна приложения
'#########################

' Константы отображения
Private Const SW_HIDE =  0 
Private Const SW_SHOWNORMAL =  1 
Private Const SW_NORMAL =  1 
Private Const SW_SHOWMINIMIZED =  2 
Private Const SW_SHOWMAXIMIZED =  3 
Private Const SW_MAXIMIZE =  3 
Private Const SW_SHOWNOACTIVATE =  4 
Private Const SW_SHOW =  5 
Private Const SW_MINIMIZE =  6 
Private Const SW_SHOWMINNOACTIVE =  7 
Private Const SW_SHOWNA =  8 
Private Const SW_RESTORE =  9 
Private Const SW_SHOWDEFAULT =  10 
Private Const SW_MAX =  10 

' Функция управляет отображением окна
Private Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" _
     (ByVal hwnd As Long, _
      ByVal nCmdShow As Long) As Long

' Команды в котором создаются приложения
Dim appAcc As Access.Application

'  Отобразить окно
Private Sub butON_Click()
Dim s As String
     On Error Resume Next
     ' Выход из приложения
     Form_Close
     
     ' Открываем окно
     Set appAcc = New Access.Application
     s = Application.CurrentProject.path & "\" & "la_form.mdb"
     appAcc.OpenCurrentDatabase (s)
     appAcc.Visible = True
     apiShowWindow appAcc.hWndAccessApp, Me.grShow
End Sub

'  Окно базы данных
Private Sub butWinDataBase_Click()
     DoCmd.SelectObject acForm, "Пример 05", True
     If Me.butWinDataBase = False Then
         DoCmd.RunCommand acCmdWindowHide
     End If
     DoCmd.SelectObject acForm, "Пример 05", False
End Sub

' Выход из системы
Private Sub Form_Close()
     On Error Resume Next
     appAcc.Quit acQuitSaveNone
     Err.Clear
End Sub

 '48. Общая информация о Windows
'#########################

' Структура с информацией о версии Windows
Private Type OSVERSIONINFO
         dwOSVersionInfoSize As Long
         dwMajorVersion As Long
         dwMinorVersion As Long
         dwBuildNumber As Long
         dwPlatformId As Long
         szCSDVersion As String *  128 
End Type

' Api константы платформы Windows
Const VER_PLATFORM_WIN32s =  0 
Const VER_PLATFORM_WIN32_WINDOWS =  1 
Const VER_PLATFORM_WIN32_NT =  2 

' Получаем информацию о версии
Private Declare Function apiGetVersionEx Lib "kernel32" Alias "GetVersionExA" _
     (lpVersionInformation As OSVERSIONINFO) As Long

'  Загрузка данных
Private Sub Form_Load()
Dim myVer As OSVERSIONINFO
Dim s As String

         ' Инициализируем строку
         s = ""
         ' Определяем размер структуры
         myVer.dwOSVersionInfoSize =  148 
         
         ' Получаем информацию о версии
         Call apiGetVersionEx(myVer)
         If myVer.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
             s = s & "Платформа: Windows 95;"
         ElseIf myVer.dwPlatformId = VER_PLATFORM_WIN32_NT Then
             s = s & "Платформа: Windows NT;"
         End If
         s = s & "Версия: " & myVer.dwMajorVersion & "." & myVer.dwMinorVersion & ";"
         s = s & "Построение: " & (myVer.dwBuildNumber And &HFFFF&) & ";"
         
         ' Устанавливаем список
         Me.myList.RowSource = s
End Sub

 '50. Использование функции timeGetTime
'#########################

' Функция времени в миллисекундах с момента запуска Windows
Private Declare Function apiTimeGetTime Lib "winmm.dll" Alias "timeGetTime" () As Long
Dim T0 As Long, T1 As Long

Private Sub Form_Open(Cancel As Integer)
     ' Устанавливаем начальное значение
     T0 = apiTimeGetTime()
     ' Определяем список
     Me.myList.RowSource = Me.myList.RowSource & ";Form_Open: " & ";" & T0 & ";" &  0 
End Sub
Private Sub Form_Activate()
     T1 = apiTimeGetTime()
     Me.myList.RowSource = Me.myList.RowSource & ";Form_Activate: " & ";" & T1 & ";" & T1 - T0
End Sub
Private Sub Form_Current()
     T1 = apiTimeGetTime()
     Me.myList.RowSource = Me.myList.RowSource & ";Form_Current: " & ";" & T1 & ";" & T1 - T0
End Sub
Private Sub Form_Load()
     T1 = apiTimeGetTime()
     Me.myList.RowSource = Me.myList.RowSource & ";Form_Load: " & ";" & T1 & ";" & T1 - T0
End Sub
Private Sub Form_Resize()
     T1 = apiTimeGetTime()
     Me.myList.RowSource = Me.myList.RowSource & ";Form_Resize: " & ";" & T1 & ";" & T1 - T0
End Sub

 '51. Вызов таймера с применением AddressOf
'#########################

Private hTimer As Long ' Указатель на запущенный процесс

Private Const TIME_ONESHOT =  0  ' Событие случается однажды
Private Const TIME_PERIODIC =  1  ' Событие случается через uDelay миллисекунд

' Запуск процесса
Private Declare Function apiTimeSetEvent Lib "winmm.dll" Alias "timeSetEvent" _
  (ByVal uDelay As Long, _
   ByVal uResolution As Long, _
   ByVal lpFunction As Long, _
   ByVal dwUser As Long, _
   ByVal uFlags As Long) As Long

' Уничтожение процесса
Private Declare Function apiTimeKillEvent Lib "winmm.dll" Alias "timeKillEvent" _
  (ByVal uID As Long) As Long


' Функция запуска событий
Private Sub butExec_Click()
Dim uDelay As Long
Dim uResolution As Long
Dim dwUser As Long
Dim fuEvent As Long

    uDelay = Me.uDelay *  1000  ' Число секунд
    uResolution = Me.uResolution
    dwUser = Me.dwUser
    uFlags = Me.uFlags ' uFlags = TIME_PERIODIC
    hTimer = apiTimeSetEvent(uDelay, _
                            uResolution, _
                            AddressOf funTimerProc, _
                            dwUser, _
                            uFlags)
End Sub

' Программа для выполнения процесса таймера
Public Function funTimerProc(ByVal uID As Long, _
                           ByVal uMsg As Long, _
                           ByVal dwUser As Long, _
                           ByVal dw1 As Long, _
                           ByVal dw2 As Long) As Long
Dim frm As Form
     Set frm = Forms("Example 07")
     frm.Msg = "Время: " & Format(Time, "hh:nn:ss") & _
         ", ID= " & uID & _
         ", Msg=" & uMsg & _
         ", User=" & dwUser & _
         ", dw1=" & dw1 & _
         ", dw2=" & dw2 & vbNewLine & frm.Msg
     funTimerProc =  0 
'    Debug.Print uID, uMsg, dwUser, dw1, dw2
End Function

 '52. Системная информация о дисках
'#########################

' Запрашиваем информацию о диске
Private Declare Function apiGetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" _
     (ByVal lpRootPathName As String, _
         lpSectorsPerCluster As Long, _
         lpBytesPerSector As Long, _
         lpNumberOfFreeClusters As Long, _
         lpTotalNumberOfClusters As Long) As Long

'  Загрузка данных
Private Sub Form_Load()
     On Error Resume Next
     Me.myDrive.RowSource = funGetDrivers
     Me.myDrive = Me.myDrive.Column( 0 ,  0 )
     myDrive_AfterUpdate
     Err.Clear
End Sub

'  Получаем информацию о диске системы
Private Function funInformationDisk()
Dim fs, dc, D, s As String
On Error Resume Next
     s = ""
     ' 1. Получаем информацию из файловой системы
     Set fs = CreateObject("Scripting.FileSystemObject")
     Set dc = fs.Drives
     For Each D In dc
         If StrComp(D.DriveLetter, Left(myDrive,  1 ), vbTextCompare) =  0  Then
             s = s & "Серийный номер: " & D.SerialNumber & ";"
             s = s & "Емкость диска: " & Format(D.TotalSize, "#,0") & ";"
             s = s & "Доступный объем диска: " & Format(D.AvailableSpace, "#,0") & ";"
             s = s & "Свободное место на диске: " & Format(D.FreeSpace, "#,0") & ";"
             s = s & "Метка тома: " & D.VolumeName & ";"
             s = s & "Файловая система: " & D.FileSystem & ";"
             Exit For
         End If
         Err.Clear
     Next D
     ' 2. Получаем информацию из api интерфейса
     Dim SectorsPerCluster As Long ' Секторов на клястер
     Dim BytesPerSector As Long ' Байт на сектор
     Dim NumberOfFreeClustors As Long ' Свободных клястеров
     Dim TotalNumberOfClustors As Long ' Всего клястеров

     ' Запрашиваем свободное место
     Call apiGetDiskFreeSpace(Left(Me.myDrive,  2 ), _
         SectorsPerCluster, BytesPerSector, _
         NumberOfFreeClustors, TotalNumberOfClustors)
     s = s & "Число секторов на клястер: " & Format(SectorsPerCluster, "#,0") & ";"
     s = s & "Число байт на сектор: " & Format(BytesPerSector, "#,0") & ";"
     s = s & "Число свободных клястеров: " & Format(NumberOfFreeClustors, "#,0") & ";"
     s = s & "Всего клястеров: " & Format(TotalNumberOfClustors, "#,0") & ";"
     
     ' Используя клястеры Вы можете определить
     ' a) Емкость диска = TotalNumberOfClustors * SectorsPerCluster * BytesPerSector
     ' b) Свободное место = NumberOfFreeClustors * SectorsPerCluster * BytesPerSector
     
     ' 3. Присваиваем источник данных
     Me.myList.RowSource = s
     Exit Function
End Function

'  Заполняем список с информацией о дисках
Private Function funGetDrivers() As String
Dim fs, dc, D
Dim s As String
On Error GoTo  999 
     Err.Clear
     funGetDrivers = ""
     Set fs = CreateObject("Scripting.FileSystemObject")
     Set dc = fs.Drives
     For Each D In dc
         Select Case D.driveType
           Case  0 : s = "Неизвестная БД"
           Case  1 : s = "Дискета"
           Case  2 : s = "Жесткий диск"
           Case  3 : s = "Сетевой диск"
           Case  4 : s = "CD-ROM"
           Case  5 : s = "RAM диск"
         End Select
         If D.IsReady Then
            funGetDrivers = funGetDrivers & D.DriveLetter & ":\ - " & s & ";"
         End If
     Next
     Exit Function
 999 :
     MsgBox Err.Description
     Err.Clear
     funGetDrivers = ""
End Function

'  Обновляем информацию
Private Sub myDrive_AfterUpdate()
     funInformationDisk
End Sub

 '53. Управление текстовым буфером
'#########################

' Функции управления буфером
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
     (ByVal uFormat As Integer) As Integer
Private Declare Function apiOpenClipboard Lib "user32" Alias "OpenClipboard" _
     (ByVal hwnd As Long) As Integer
Private Declare Function apiSetClipboardData Lib "user32" Alias "SetClipboardData" _
     (ByVal uFormat As Integer, _
      ByVal hData As Long) As Long
Private Declare Function apiGetClipboardData Lib "user32" Alias "GetClipboardData" _
     (ByVal uFormat As Integer) As Long
Private Declare Function apiCloseClipboard Lib "user32" Alias "CloseClipboard" _
     () As Integer
Private Declare Function apiEmptyClipboard Lib "user32" Alias "EmptyClipboard" _
     () As Integer

' Функции управления памятью
Private Declare Function apiGlobalAlloc Lib "kernel32" Alias "GlobalAlloc" _
     (ByVal uFlags As Integer, _
      ByVal dwBytes As Long) As Long
Private Declare Function apiGlobalSize Lib "kernel32" Alias "GlobalSize" _
     (ByVal hMem As Long) As Integer
Private Declare Function apiGlobalLock Lib "kernel32" Alias "GlobalLock" _
     (ByVal hMem As Long) As Long
Private Declare Sub apiMoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
     (ByVal strDest As Any, _
      ByVal lpSource As Any, _
      ByVal Length As Long)
Private Declare Function apiGlobalUnlock Lib "kernel32" Alias "GlobalUnlock" _
     (ByVal hMem As Long) As Integer
Private Declare Function apiGlobalFree Lib "kernel32" Alias "GlobalFree" _
     (ByVal hMem As Long) As Long

' api-Константы памяти
Private Const GMEM_FIXED = &H0
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_NOCOMPACT = &H10
Private Const GMEM_NODISCARD = &H20
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MODIFY = &H80
Private Const GMEM_DISCARDABLE = &H100
Private Const GMEM_NOT_BANKED = &H1000
Private Const GMEM_SHARE = &H2000
Private Const GMEM_DDESHARE = &H2000
Private Const GMEM_NOTIFY = &H4000
Private Const GMEM_LOWER = GMEM_NOT_BANKED
Private Const GMEM_VALID_FLAGS = &H7F72
Private Const GMEM_INVALID_HANDLE = &H8000
Private Const GMEM_TEXT = (GMEM_MOVEABLE Or GMEM_DDESHARE)

' api-Форматы буфера
Private Const CF_TEXT =  1 
Private Const CF_BITMAP =  2 
Private Const CF_METAFILEPICT =  3 
Private Const CF_SYLK =  4 
Private Const CF_DIF =  5 
Private Const CF_TIFF =  6 
Private Const CF_OEMTEXT =  7 
Private Const CF_DIB =  8 
Private Const CF_PALETTE =  9 
Private Const CF_PENDATA =  10 
Private Const CF_RIFF =  11 
Private Const CF_WAVE =  12 
Private Const CF_UNICODETEXT =  13 
Private Const CF_ENHMETAFILE =  14 

'==============================================================
'  Копируем текст в буфер
'
Function CopyText(strText As String) As Variant
Dim hMem As Long
Dim lpMem As Long
Dim l As Long

     ' Выделение памяти
     l = Len(strText) +  1  ' Длина строки с учетом символа \0 (c++)
     hMem = apiGlobalAlloc(GMEM_TEXT, l) ' Память для буфера
     
     ' Управление памятью
     lpMem = apiGlobalLock(hMem) ' Блокируем часть памяти
     Call apiMoveMemory(lpMem, strText, l) ' Копируем строку в память
     Call apiGlobalUnlock(hMem) ' Разблокируем память
     
     ' Управление буфером
     Call apiOpenClipboard( 0 &) ' Открываем буфер
     Call apiEmptyClipboard ' Очищаем буфер
     Call apiSetClipboardData(CF_TEXT, hMem) ' Загружаем текст
     Call apiCloseClipboard ' Закрываем буфер
     
     ' Освобождаем память
     Call apiGlobalFree(hMem)
End Function

'==============================================================
'  Получаем текст из буфера
'
Public Function GetText() As Variant
Dim hMem As Long
Dim lpMem As Long
Dim s As String
Dim l As Long

     ' Проверяем формат буфера
     If Not CBool(IsClipboardFormatAvailable(CF_TEXT)) Then
         Exit Function
     End If
    
     ' Работаем с буфером и памятью
     Call apiOpenClipboard( 0 &) ' Открываем буфер
     hMem = apiGetClipboardData(CF_TEXT) ' Получаем заголовок данных в буфере
     l = apiGlobalSize(hMem) ' Определяем размер строки
     s = Space$(l) ' Выделение памяти для строки
     lpMem = apiGlobalLock(hMem) ' Блокируем память
     Call apiMoveMemory(s, lpMem, l) ' Копируем информацию из буфера в строку
     Call apiGlobalUnlock(hMem) ' Разблокирование памяти
     Call apiCloseClipboard ' Закрываем буфер
     
     ' Возвращаем результат
     GetText = Left$(s, InStr( 1 , s, Chr$( 0 )) -  1 )
     
End Function

 '54. Получение сетевого имени пользователя
'#########################

Private Declare Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
 (ByVal lpBuffer As String, nSize As Long) As Long


' Возвращает сетевое имя пользователя
Function funGetUserName() As String
Dim BufSize As Long, strUserName As String *  255 , Status As Long
     On Error GoTo  999 
         BufSize =  255 
         Status = apiGetUserName(strUserName, BufSize)
         If Status =  1  Then
             funGetUserName = Left$(strUserName, InStr(strUserName, Chr( 0 )) -  1 )
         Else
             funGetUserName = ""
         End If
     Exit Function
 999 :
     MsgBox Err.Description
End Function

' Функция запуска событий
Private Sub butExec_Click()
     Me.Msg = "Локальное имя: " & funGetUserName & vbNewLine & _
              "Сетевое имя: " & NetUserID
End Sub

 '54. Работа с FTP протоколом
'#########################

Private Declare Function FtpGetFile _
   Lib "wininet.dll" Alias "FtpGetFileA" ( _
   ByVal hFtpSession As Long, _
   ByVal lpszRemoteFile As String, _
   ByVal lpszNewFile As String, _
   ByVal fFailIfExists As Boolean, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Boolean

Private Declare Function InternetOpen _
   Lib "wininet.dll" Alias "InternetOpenA" ( _
   ByVal sAgent As String, _
   ByVal nAccessType As Long, _
   ByVal sProxyName As String, _
   ByVal sProxyBypass As String, _
   ByVal nFlags As Long) As Long

Private Declare Function InternetConnect _
   Lib "wininet.dll" Alias "InternetConnectA" ( _
   ByVal hInternetSession As Long, _
   ByVal sServerName As String, _
   ByVal nServerPort As Integer, _
   ByVal sUserName As String, _
   ByVal sPassword As String, _
   ByVal nService As Long, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Long

hINetSession = InternetOpen("MyFTPClient",  0 , vbNullString, vbNullString,  0 )


hSession = InternetConnect(hINetSession, "ftp.microsoft.com", _
   "21", "anonymous", "guest", INTERNET_SERVICE_FTP,  0 ,  0 )
    
Private Const INTERNET_SERVICE_FTP =  1 
Private Const INTERNET_SERVICE_GOPHER =  2 
Private Const INTERNET_SERVICE_HTTP =  3 

Private Declare Function FtpGetFile _
   Lib "wininet.dll" Alias "FtpGetFileA" ( _
   ByVal hFtpSession As Long, _
   ByVal lpszRemoteFile As String, _
   ByVal lpszNewFile As String, _
   ByVal fFailIfExists As Boolean, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Boolean

If FtpGetFile(hSession, "dirmap.htm", "c:\dirmap.htm", False,  0 ,  1 ,  0 ) = False Then
   MsgBox "Call to FtpGetFile Failed!"
End If

Пункт четвертый, заключительный: закрываем Хендлы

Private Declare Function InternetCloseHandle _
   Lib "wininet.dll" (ByVal hInet As Long) As Integer

Call InternetCloseHandle(hSession)
Call InternetCloseHandle(hINetSession)

Private Declare Function FtpPutFile _
   Lib "wininet.dll" Alias "FtpPutFileA" ( _
   ByVal hFtpSession As Long, _
   ByVal lpszLocalFile As String, _
   ByVal lpszRemoteFile As String, _
   ByVal dwFlags As Long, _
   ByVal dwContext As Long) As Boolean
If FtpPutFile(hSession, "c:\MyFile.txt", "shared.txt",  1 ,  0 ) = False Then
   MsgBox "The call to FtpPutFile failed."
End If

Private Declare Function FtpDeleteFile _
   Lib "wininet.dll" Alias "FtpDeleteFileA" ( _
   ByVal hFtpSession As Long, _
   ByVal lpszFileName As String) As Boolean

ПЕРЕИМЕНОВАНИЕ
Private Declare Function FtpRenameFile _
   Lib "wininet.dll" Alias "FtpRenameFileA" ( _
   ByVal hFtpSession As Long, _
   ByVal lpszExisting As String, _
   ByVal lpszNewName As String) As Boolean

Private Declare Function FtpFindFirstFile _
   Lib "wininet.dll" Alias "FtpFindFirstFileA" ( _
   ByVal hFtpSession As Long, _
   ByVal lpszSearchFile As String, _
   ByRef lpFindFileData As WIN32_FIND_DATA, _
   ByVal dwFlags As Long, _
   ByVal dwContent As Long) As Long
   
Private Declare Function InternetFindNextFile _
   Lib "wininet.dll" Alias "InternetFindNextFileA" ( _
   ByVal hFind As Long, _
   ByRef lpvFindData As WIN32_FIND_DATA) As Long

Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String *  260 
   cAlternate As String *  14 
End Type

Подструктура FileName:
Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type

Private Sub ListFiles()
    Dim hFile As Long ' This is a file handle
    Dim fd As WIN32_FIND_DATA
    hFile = FtpFindFirstFile(hSession, "*.*", fd,  0 ,  0 )
        If hFile =  0  Then
            If Err.LastDllError = ERROR_NO_MORE_FILES Then
                MsgBox "No files found"
                Exit Sub
            Else
                MsgBox "Some error occurred"
                Exit Sub
            End If
        End If
    Do
        List1.AddItem fd.cFileName
    Loop While InternetNextFile(hFile, fd) <>  0 
    'Close the file handle
    Call InternetCloseHandle(hFile)
End Sub

 '55. Получ MAC адрес сетевой карты.
'#########################

Option Explicit
Public Const NCBASTAT As Long = &H33
Public Const NCBNAMSZ As Long =  16 
Public Const HEAP_ZERO_MEMORY As Long = &H8
Public Const HEAP_GENERATE_EXCEPTIONS As Long = &H4
Public Const NCBRESET As Long = &H32

Public Type NET_CONTROL_BLOCK  'NCB
   ncb_command    As Byte
   ncb_retcode    As Byte
   ncb_lsn        As Byte
   ncb_num        As Byte
   ncb_buffer     As Long
   ncb_length     As Integer
   ncb_callname   As String * NCBNAMSZ
   ncb_name       As String * NCBNAMSZ
   ncb_rto        As Byte
   ncb_sto        As Byte
   ncb_post       As Long
   ncb_lana_num   As Byte
   ncb_cmd_cplt   As Byte
   ncb_reserve( 9 ) As Byte ' Reserved, must be 0
   ncb_event      As Long
End Type

Public Type ADAPTER_STATUS
   adapter_address( 5 ) As Byte
   rev_major         As Byte
   reserved0         As Byte
   adapter_type      As Byte
   rev_minor         As Byte
   duration          As Integer
   frmr_recv         As Integer
   frmr_xmit         As Integer
   iframe_recv_err   As Integer
   xmit_aborts       As Integer
   xmit_success      As Long
   recv_success      As Long
   iframe_xmit_err   As Integer
   recv_buff_unavail As Integer
   t1_timeouts       As Integer
   ti_timeouts       As Integer
   Reserved1         As Long
   free_ncbs         As Integer
   max_cfg_ncbs      As Integer
   max_ncbs          As Integer
   xmit_buf_unavail  As Integer
   max_dgram_size    As Integer
   pending_sess      As Integer
   max_cfg_sess      As Integer
   max_sess          As Integer
   max_sess_pkt_size As Integer
   name_count        As Integer
End Type
   
Public Type NAME_BUFFER
   name        As String * NCBNAMSZ
   name_num    As Integer
   name_flags  As Integer
End Type

Public Type ASTAT
   adapt          As ADAPTER_STATUS
   NameBuff( 30 )   As NAME_BUFFER
End Type

Public Declare Function Netbios Lib "netapi32.dll" _
   (pncb As NET_CONTROL_BLOCK) As Byte
     
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (hpvDest As Any, ByVal _
    hpvSource As Long, ByVal _
    cbCopy As Long)
     
Public Declare Function GetProcessHeap Lib "kernel32" () As Long

Public Declare Function HeapAlloc Lib "kernel32" _
    (ByVal hHeap As Long, ByVal dwFlags As Long, _
     ByVal dwBytes As Long) As Long
     
Public Declare Function HeapFree Lib "kernel32" _
    (ByVal hHeap As Long, _
     ByVal dwFlags As Long, _
     lpMem As Any) As Long


Public Function GetMACAddress() As String

  'запрашиваем MAC Адрес для сетевой карты
  'возвращаем форматированную строку
   
   Dim tmp As String
   Dim pASTAT As Long
   Dim NCB As NET_CONTROL_BLOCK
   Dim AST As ASTAT

   NCB.ncb_command = NCBRESET
   Call Netbios(NCB)
   
  'Для получения Media Access Control (MAC) адреса для сетевой карты
  'программным путём, используется команда Netbios() -
  'NCBASTAT с именем "*" в поле NCB.ncb_CallName (в 16-символьной строке).
   NCB.ncb_callname = "*               "
   NCB.ncb_command = NCBASTAT
   
  'Для машин с несколькими сетевыми картами Вам необходимо использовать
  'номер LANA и выполнять команду NCBASTAT для каждого. LANA номер 0 всегда
  'соответствует первому сетевому адаптеру. Конечно можно использовать LANA
  'номер и для одного сетевого адаптера, но это будет считаться как
  'неэффективное  программирование.
   NCB.ncb_lana_num =  0 
   NCB.ncb_length = Len(AST)
   
   pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS _
            Or HEAP_ZERO_MEMORY, NCB.ncb_length)
            
   If pASTAT =  0  Then
      Debug.Print "memory allocation failed!"
      Exit Function
   End If
   
   NCB.ncb_buffer = pASTAT
   Call Netbios(NCB)
   
   CopyMemory AST, NCB.ncb_buffer, Len(AST)
   
   tmp = Format$(Hex(AST.adapt.adapter_address( 0 )), "00") & " " & _
         Format$(Hex(AST.adapt.adapter_address( 1 )), "00") & " " & _
         Format$(Hex(AST.adapt.adapter_address( 2 )), "00") & " " & _
         Format$(Hex(AST.adapt.adapter_address( 3 )), "00") & " " & _
         Format$(Hex(AST.adapt.adapter_address( 4 )), "00") & " " & _
         Format$(Hex(AST.adapt.adapter_address( 5 )), "00")
           
   
   HeapFree GetProcessHeap(),  0 , pASTAT
   
   GetMACAddress = tmp

End Function

'Код формы.
'Добавьте в форму кнопку (Command1), и текстовое поле (Text1). Метки и фреймы не обязательны. Добавьте в событие кнопки следующий код:
Option Explicit

Private Sub Command1_Click()
   Text1 = GetMACAddress()
End Sub


 '56. Реестр и Windows API
'#########################

'В ранних версиях Windows, все её приложения хранили необходимую для запуска и работы информацию в файлах инициализации. С развитием ОС информации, необходимой для сохранения стало так много, что возникла необходимость в новом способе её хранения - реестре. Реестр, - это своеобразная база данных для приложений Windows. Его структура напоминает файловую систему. (не верите посмотрите через regedit.exe только ничего не меняйте). Вообще реестр считают несомненной альтернативой INI-файлам, но я думаю, что эти две технологии имеют наибольшую мощность только при их совмещении.
'В Visual Basic есть функции для работы с реестром( GetSetting,SaveSetting) но их возможности ограничены. Они могут работать с реестром только в разделе HKEY_CURRENT_USER\Software\VB and VBA Programms, и способны только читать и записывать. Для начинающего программиста это неплохо, даже хорошо - меньше возможностей навредить.На самом деле Windows может намного больше. Расширить возможности VB, позволяет Windows API.
'Windows обладает большим набором функций для работы с реестром, сами по себе GetSetting и SaveSetting тоже вызывают их. С помощью этих функций, вы можете создавать разделы, в любой части реестра, а затем удалять их :), подключать реестр через сеть, сохранять разделы в файле и т.д.
'В качестве примера, мы создадим класс, для работы с реестром через Windows API (насколько я знаю в Borland Delphi, нечто подобное уже есть, и один знакомый программист очень этим гордится :) ). Этот класс может работать только со строковыми данными. Я посчитал, что если Вам понадобится больше, Вы сможете сделать это сами. Кроме того класс даёт возможность удалять лишние разделы, и параметры. Работу с реестром через сеть, и остальные возможности я исключил, так как этот класс задуман как расширение Basic'овских функций для работы с реестром. Остальные операции будут заключены в другой класс, который должен будет реализовать все возможности Windows API в работе с реестром.
'Итак, хватит лирики, приступим к работе. Создадим новый модуль класса и назовём его RegistryExClass(совсем как в API, RegSetValue,RegSetValueEx). После этого приступим к объявлению необходимых функций.Я рассмотрю только особенные, остальные найдёте в API Text Viewer. (RegOpenKey, RegDeleteValue, RegDeleteKey, RegCloseKey, RegCreateKey)
Private Declare Function RegQueryValueExS Lib "advapi32.dll" _
 Alias "RegQueryValueExA" ( _
 ByVal hkey As Long, _
 ByVal lpValueName As String, _
 ByVal lpReserved As Long, _
 lpType As Long, _
 ByVal lpData As String, _
 lpcbData As Long) As Long

Private Declare Function RegSetValueExS Lib "advapi32.dll" _
 Alias "RegSetValueExA" ( _
 ByVal hkey As Long, _
 ByVal lpValueName As String, _
 ByVal Reserved As Long, _
 ByVal dwType As Long, _
 ByVal lpData As String, _
 ByVal cbData As Long) As Long
'
'Что здесь особенного, спросите Вы. Объясняю: Как я уже сказал мой класс работает только со строками. Приведённые выше функции, в оригинальном объявлении не имеют чётко определённого типа данных(lpData As Any). При попытке использовать такое объявление, я получал ошибку "Out Of Memory". Как видно в листинге, я объявил lpData как строку, хотя имею возможность присвоить любой тип. Беда в том, что VB не поймёт Вас при попытке объявить две функции. Чтобы обойти это, я и объявил функции с оконаниями "-S". И теперь в класс можно будет добавить ещё функции для работы с различными типами.
'Ещё по той же теме. Некоторые функции для работы с реестром имеют параметры типа SECURITY_ATTRIBUTES. Если эти параметры Вам не нужны, то объявите их как Long, и передавайте ноль.
'Теперь объявим константы.
'Объявив эти константы таким способом, Вы дадите
'пользователю класса возможность выбирать из списка
'значение параметра
Public Enum HKEY_CONSTANTS
 HKEY_CLASSES_ROOT = &H80000000
 HKEY_CURRENT_CONFIG = &H80000005
 HKEY_CURRENT_USER = &H80000001
 HKEY_DYN_DATA = &H80000006
 HKEY_LOCAL_MACHINE = &H80000002
 HKEY_PERFORMANCE_DATA = &H80000004
 HKEY_USERS = &H80000003
End Enum

'Ну ещё константа, для строкового типа
Private Const REG_SZ =  1 

'Теперь создадим методы для чтения/записи параметров
'~~~~~~.GetString Функция
Public Function GetString( _
   ByVal HomeKey As HKEY_CONSTANTS, _
   ByVal KeyName As String, _
   ByVal ValueName As String) As String

'Handle раздела реестра
Dim hkey As Long
'переменная для хранения значения
Dim sData As String
'Результат работы API функций
Dim lres As Long
'Тип возвращаемого значения
Dim lDataType As Long
'переменная для хранения длины строки
Dim lDlen As Long
'Открываем Раздел
lres = RegOpenKey(HomeKey, KeyName, hkey)
'Если вернулся не ноль - ошибка, выходим
If lres <>  0  Then GetRegString = vbNullString: Exit Function
'Продолжаем, заполняем строку пробелами.
sData = String$( 64 ,  32 ) & Chr$( 0 )
lDlen = Len(sData)
'Читаем значение
lres = RegQueryValueExS(hkey, ValueName,  0 , lDataType, sData, lDlen)
'опять проверка на ошибку
If lres <>  0  Then GetRegString = vbNullString: Exit Function
'проверяем тип полученных данных
If lDataType = REG_SZ Then
GetString = Left$(sData, lDlen -  1 )
Else
GetString = vbNullString
End If
'и закрываем раздел
lres = RegCloseKey(hkey)
End Function

'~~~~~.SaveString  Метод
Public Sub SaveString( _
    ByVal HomeKey As HKEY_CONSTANTS, _
    ByVal KeyName As String, _
    ByVal ValueName As String, _
    ByVal Data As String)

'Handle для корневого раздела
Dim hkey As Long
'Handle для изменяемого раздела
Dim hSubKey  As Long
'Результат работы функции
Dim lres As Long
'Открываем корневой раздел
lres = RegOpenKey(HomeKey, vbNullString, hkey)
'Создаём(если есть открываем) нужный раздел
lres = RegCreateKey(HomeKey, KeyName, hSubKey)
'Пишем данные
lres = RegSetValueExS(hSubKey, ValueName,  0 , _
   REG_SZ, Data + Chr$( 0 ), Len(Data) +  1 )

'и закрываем всё открытое
lres = RegCloseKey(hSubKey)
lres = RegCloseKey(hkey)
End Sub

'Метод GetString всего лишь читает параметр из реестра. SaveString - имеет больше возможностей. С его помощью Вы можете создать пустой раздел. Для этого вызовите его, установив значение ValueName и Data равное пустой строке. Если хотите установить для раздела значение по умолчанию присвойте Data нужное значение, при нулевом(vbNullString) ValueName.
'Теперь поработаем с удалением.

'~~~~~~.DeleteValue Метод
Public Sub DeleteValue( _
    ByVal HomeKey As HKEY_CONSTANTS, _
    ByVal KeyName As String, _
    ByVal ValueName As String)

'Handle для изменяемого раздела
Dim hkey As Long
'Результат API функции
Dim lres As Long
'открываем нужные раздел
lres = RegOpenKey(HomeKey, KeyName, hkey)
'проверяем на ошибку
If lres <>  0  Then Exit Sub
'удаляем параметр
lres = RegDeleteValue(hkey, ValueName)
'закрываем
lres = RegCloseKey(hkey)
End Sub

'~~~~~~.DeleteKey
Public Sub DeleteKey( _
   ByVal HomeKey As HKEY_CONSTANTS, _
   ByVal KeyName As String)
'результат APi функции
Dim lres As Long
'Удаляем раздел из корневого
lres = RegDeleteKey(HomeKey, KeyName)
End Sub

 '57. способ получения скриншота
'#########################

'Способ основан на симуляции нажатия клавиши Print Screen (Const vbKeySnapshot = 44 (&H2C)), - для копирования изображения экрана, и методе Clipboard.GetData(vbCFBitmap), - для дальнейшего получения изображения в Picture (Picture Box).
'Объявляем в General Form1:
Private Declare Sub keybd_event Lib "user32" _
(ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)
Dim A As Integer
'в Properties Form1 устанавливаем BorderStyle в 0-None, для того, чтобы в
'момент получения <фотографии> экрана, детали формы не попали в "кадр"
Private Sub Form_Load()
   'делаем форму невидимой, но при этом оставляем активными все 'компоненты
   Form1.height =  0 
   Timer1.Interval =  1 
   'очищаем Clipboard
   Clipboard.Clear
   'копируем изображение экрана
   keybd_event vbKeySnapshot,  1 ,  0 &,  0 &
End Sub

Private Sub Timer1_Timer()
   A = A +  1 
   If A =  2  Then
      'вклеиваем изображение в картинку
      Picture1.Picture = Clipboard.GetData(vbCFBitmap)
      'задаём размеры формы и картинки
      Form1.Width = Screen.Width *  0 . 8 
      Form1.height = Screen.height *  0 . 8 
      Form1.Left = (Screen.Width - Width) /  2 
      Form1.Top = (Screen.height - height) /  2 
      Picture1.height = Form1.ScaleHeight *  1 
      Picture1.Width = Form1.ScaleWidth *  1 
      Picture1.Left = (Form1.Width - Picture1.Width) /  2 
      Picture1.Top = (Form1.height - Picture1.height) /  2 
   End If
   If A =  2  Then
      'очищаем Clipboard
      Clipboard.Clear
      'выключаем Timer1
      Timer1.Enabled = False
   End If
End Sub

'для выхода из программы
Private Sub Picture1_Click()
   End
End Sub

 '58. Техника программирования сложных окон в Visual Basic
'#########################

'Многие из Вас наверняка видели в Windows программах окна нестандартной формы (круглые, треугольные и т.д.) и задавали себе вопрос: как мне сделать такое окно? Если прочитать документацию по Visual Basic, то можно сделать вывод, что стандартные средства языка не предоставляют такой возможности. А что же делать, если очень хочется? Тогда следует вспомнить, что в распоряжении программиста на VB есть еще и Windows API, который должен нам в этом помочь.
'Теоретические основы
'
'Для начала давайте разберемся, как это можно сделать теоретически. Из документации Windows видно, что каждое окно в системе описывается множеством параметров, из которых нас с Вами интересует <видимая область окна>. Видимая область окна в системе, создаваемое Visual Basic <по умолчанию> имеет вид прямоугольника, но, в принципе, ничто не мешает изменить форму этой области. Данная область окна описывается с помощью специального объекта, который называется Region. Регион можно представить в виде поверхности, ограниченной координатами, описываемыми угловые точки этой области. Проще говоря, можно описать область любой формы, затем создать из неё, с помощью специальных функций, регион и <прикрепить> его к нужому нам окну.
'
'Существует несколько функций Windows API для создания регионов, основными из которых являются следующие:
'CombineRgn - Комбинирует два региона между собой
'CreateEllipticRgn - Создает регион в виде эллипса или окружности
'CreatePolygonRgn - Создает регион в виде многоугольника
'CreateRectRgn - Создает прямоугольный регион
'CreateRoundRectRgn - Создает регион со скругленными краями из прямоугольной области
'SetWindowRgn - Прикрепляет регион к указанному окну
'
'Я не буду приводить подробное описание этих функций, так как его можно найти в описании Win32 API. Кроме этих функций существуют ещё несколько функций для работы с регионами, но нам они не потребуются.
'Создание простых нестандартных окон
'
'Теперь, когда нам известны основные функции, для создания регионов, мы можем применить полученные знания на практике. Загрузите проект pTestRgn и внимательно изучите его код. В этом проете, для изменения формы окна на овальную, используется всего три строки кода и три функции Win32 API. Вначале с помощью CreateEllipticRgn создается регион, затем он прикрепляется к окну и, наконец, завершающая фаза удаление, ставшего ненужным, созданного нами региона. Если же Вы не удалите ненужный Вам больше объект, то Windows, создав регион для Вас будет хранить его в своих <недрах> и ждать дальнейших указаний по его использованию. В общем, нехорошо <захламлять> выделенную память, и настигнет Вас кара небесная, и затянется небо тучами синими, и будет страшный суд над всеми неверующими: Короче код выглядит так:
Private Sub cmbCreateOval_Click()
   Dim lRgn As Long
   lRgn = CreateEllipticRgn( 0 ,  0 , Me.ScaleWidth / Screen.TwipsPerPixelX, _
   Me.ScaleHeight / Screen.TwipsPerPixelY)
   SetWindowRgn Me.hwnd, lRgn, True
   DeleteObject lRgn
End Sub

'Так же всё просто, скажете Вы? Да, на первый взгляд всё очень просто, но это только кажется. Тот пример, который Вы только что видели, почти не имеет практического применения в настоящих приложениях Windows. Кому же нужно просто овальное окно, которое к тому же жестко задается на этапе программирования? А вот окно, которое свободно могло бы менять свою форму вполне может потребоваться. Примеры? Пожалуйста, WinAmp, Помощник в Microsoft Office и другие программы. Как же там всё это реализовано? Давайте разберемся с таким применением регионов.
'Создание сложных нестандартных окон
'
'Допустим, что у нас есть рисунок в BMP формате, из которого нужно сделать форму, а белый цвет (например) на нём означает <пустоту>. Как же сделать форму? Очень просто, нужно взять все <не белые> пиксели на рисунке, создать из их координат регион и прикрепить его к нужному нам окну. Анализировать пиксели можно GetPixel, эта функция по координатам возвращает его цвет. Давайте теперь напишем такой алгоритм для анализа BMP матрицы. Я думаю, что такой алгоритм Вам известен, и мы не будем его подробно разбирать, отмечу только, что анализ производится построчно и Pixel-и добавляются в регион не по одному, а группами построчно. Такой подход сильно экономит ресурсы процессора, выигрыш в производительности достигает 100%.
Public Function lGetRegion(pic As PictureBox, lBackColor As Long) As Long
   Dim lRgn As Long
   Dim lSkinRgn As Long
   Dim lStart As Long
   Dim lX As Long
   Dim lY As Long
   Dim lHeight As Long
   Dim lWidth As Long

   'создаем пустой регион, с которого начнем работу
   lSkinRgn = CreateRectRgn( 0 ,  0 ,  0 ,  0 )
   With pic
      'подсчитаем размеры рисунка в Pixel
      lHeight = .height / Screen.TwipsPerPixelY
      lWidth = .Width / Screen.TwipsPerPixelX
      For lX =  0  To lHeight -  1 
         lY =  0 
         Do While lY < lWidth
            'ищем нужный Pixel
            Do While lY < lWidth And GetPixel(.hdc, lY, lX) = lBackColor
               lY = lY +  1 
            Loop
            If lY < lWidth Then
               lStart = lY
            Do While lY < lWidth And GetPixel(.hdc, lY, lX) <> lBackColor
               lY = lY +  1 
            Loop
            If lY > lWidth Then lY = lWidth
               'нужный Pixel найден, добавим его в регион
               lRgn = CreateRectRgn(lStart, lX, lY, lX +  1 )
               CombineRgn lSkinRgn, lSkinRgn, lRgn, RGN_OR
               DeleteObject lRgn
            End If
         Loop
      Next
   End With
   lGetRegion = lSkinRgn
End Function

'Итак, для проверки на практике этого алгоритма загрузите пример pTestRgnSkin и внимательно изучите его код. В этом проекте нужный нам рисунок, для удобства, <зашит> в файле ресурсов, кроме того проект запускается процедурой Main, в которой и происходят все преобразования. Вначале загружается форма, затем в PictureBox из ресурсов загружается нужный нам рисунок, далее вызывается функция, которая создает регион и, наконец, завершающий этап - прикрепление региона к нужному нам окну. Для удобства здесь же вызывается функция, помещающая окно <поверх всех>, чтобы оно <не потерялось> у Вас на рабочем столе Windows. Кроме того, для нормальной работы программы необходимо, чтобы для PictureBox свойство AutoRedraw было установленно в True, иначе ничего не получится.
Sub Main()
   Dim lRgn As Long
   Load frmTestRgnSkin
   frmTestRgnSkin.pic.Picture = LoadResPicture( 101 , vbResBitmap)
   lRgn = lGetRegion(frmTestRgnSkin.pic, vbWhite)
   SetWindowRgn frmTestRgnSkin.hwnd, lRgn, True
   DeleteObject lRgn
   frmTestRgnSkin.Show
   SetFormPosition frmTestRgnSkin.hwnd, True
End Sub

'Теперь можно запускать проект... О, знакомое лицо, скажите Вы, это же <Скрепыш> из Microsoft Office. Да, похож, но не совсем, <Скрепыш> двигается, а этот нет. Что же нужно сделать, чтобы это окно динамически изменяло свою форму по рисунку, отображаемому в данный момент времени в PictureBox?
'Динамическое изменение формы окна
'
'Существуют программы в которых необходимо динамически во время работы изменять форму окна (например анимированный персонаж из Microsoft Office). Все это не очень сложно реализовать, нужно в событие PictureBox.Change добавить следующий код:
lRgn = lGetRegion(frmTestRgnSkin.pic, vbWhite)
SetWindowRgn frmTestRgnSkin.hwnd, lRgn, True
DeleteObject lRgn
SetFormPosition frmTestRgnSkin.hwnd, True

'В принципе всё готово, осталось только добавить код для изменения картинки на форме, и <Скрепыш> оживёт. В нашем примере изменять рисунок будем в Timer циклически, т.е. анимация будет непрерывна, так проще. Итак, добавим на форму Timer и поместим <в него> небольшой код, отвечающий за изменения рисунка в PictureBox. Рисунков в файле ресурсов десять штук, поэтому I должно изменяться от 101 до 110. Код изменения выглядит так:
Static i As Long
If i <  101  Then i =  101 
If i >  110  Then i =  101 
frmAnimateForm.pic.Picture = LoadResPicture(i, vbResBitmap)
i = i +  1 

'Готово, можно запускать проект, и если Вы счастливый обладатель Pentium III или Athlon, то Вам улыбнется удача, так как <Скрепыш> будет двигаться. Но если Ваш процессор Pentium II и ниже, то компьютер не сможет выполнять необходимые расчеты за нужное нам время, так как для плавной анимации необходимо (для нашего случая) показывать порядка 15 кадров в секунду, а точнее каждые 80 милисекунд по кадру и ещё оставлять время для других задач компьютера. Как мы видим наши алгоритмы явно не тянут для таких задач и предназначены для <работ> не требующих таких быстрых изменений формы окна, так как, например на Celeron 333 один кадр формируется около 100 милисекунд. Что же делать?
'Оптимизация алгоритма для быстрой анимации
'
'Анализ работы алгоритма показывает, что наибольшие затраты времени приходятся на функцию GetPixel. Это происходит потому, что анализ картинки идет непосредственно на экране. Единственный путь увеличения быстродействия алгоритма, это перенос анализа в память компьютера и использование при этом Win 32 API. Такие алгоритмы существуют, но это тема отдельного разговора, скажу только, что для оптимизации работы алгоритм пишется отдельно для каждой глубины цвета и при применении такой схемы быстродействие увеличивается почти в четыре раза и позволяет делать практически любую анимацию.


 '58. Хранитель Экрана на Visual Basic
'#########################

'Хорош Visual Basic тем, что он позволяет создавать хранители экрана. Для этого нужно всего лишь создать проект с одной или несколькими формами, простым кодом, и откомпилировать его в файл с расширением *.Scr в рабочий каталог Windows.
'
'Как я думаю уже понятно, весь фокус состоит в коде. Его мы сейчас разберём, но сначала создадим форму. Разместим на ней таймер, и установим некоторые cвойства. (BorderStyle = None, WindowState = Maximized,Name = frmSSaver).Теперь приступаем к созданию кода. Сначала, как и всегда нам нужно объявить все необходимые переменные:
Option Explicit
Private DDC As Long 'Переменная для хранения хэндла Рабочего стола
Private BlockX As Long 'Размер закрашиваемого кусочка по горизонтали
Private BlockY As Long 'Размер закрашиваемого кусочка по вертикали
Private Quit As Boolean 'Флаг завершения

Private OldX As Single 'переменные для хранения
Private OldY As Single 'координат мыши
Const AppName = "VB Screen Saver" 'Имя программы в реестре

'Так как вся работа выполняется в цикле таймера, для выхода используется флаг Quit. Кстати о самой работе. Весь основной код Хранителя экрана прост как всё гениальное(какой я скромный правда?):
Private Sub Timer1_Timer()
'Код работы Хранителя экрана
Dim X As Long, Y As Long
X = (Rnd * Screen.Width) / Screen.TwipsPerPixelX
Y = (Rnd * Screen.height) / Screen.TwipsPerPixelY
Me.Line (X, Y)-Step(BlockX, BlockY), Me.BackColor, BF
If Quit Then
'Если Выход то...
Form_Unload  0 
End If
End Sub

'Таймер обеспечивает рисование на форме и выход если флаг Quit установлен, но перед тем как рисовать необходимо сохранить изображение экрана на форме и "спрятать" мышь:
Private Sub Form_Load()
'Гашение курсора
ShowCursor False
'Чтение установок
If CLng(GetSetting(AppName, Chr$( 0 ), "BackColor", "-1")) = - 1  Then
Me.BackColor = GetSysColor(COLOR_BACKGROUND)
Else
Me.BackColor = CLng(GetSetting(AppName, Chr$( 0 ), "BackColor", "0"))
End If
BlockX = CLng(GetSetting(AppName, Chr$( 0 ), "XSize",  16 ))
BlockY = CLng(GetSetting(AppName, Chr$( 0 ), "YSize",  8 ))
Timer1.Interval = CLng(GetSetting(AppName, Chr$( 0 ), "Time", "100"))
'Получение описателя рабочего стола
DDC = GetWindowDC(GetDesktopWindow)
'Сохранение экрана на форме
BitBlt Me.hdc,  0 ,  0 , XtoP(Screen.Width), YtoP(Screen.height), DDC,  0 ,  0 , vbSrcCopy
End Sub
'
'При загрузке формы, программа читает из реестра параметры с помощью функций VB и, с помощью Windows API, убирает с экрана курсор мыши(мышь всё равно активна) и сохраняет экран на форме. Все объявления функций API, я разместил в отдельном модуле . Кстати этот модуль отвечает ещё за кое-какие операции, но об этом позже.
'
'Итак у нас есть код для подготовки формы, и код цикла рисования. Но если не установить флаг выхода цикл будет бесконечен. Поэтому используятся события формы MouseMove и KeyDown.
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
        X As Single, Y As Single)
'Выход если двигалась мышь
If OldX =  0  Or OldY =  0  Then OldX = X: OldY = Y
If OldX <> X Or OldY <> Y Then Quit = True
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Quit = True 'Выход если нажата клавиша
End Sub

'Я думаю особо сложного в этом коде ничего нет. Вот только переменные OldX и OldY я объявил как доступные по всему модулю. Но чтобы эти переменные не сбрасывались при завершении процедуры обработки MouseMove, можно объявить их внутри неё с помощью оператора Static я не использовал его просто потому что он мне не очень нравиться.
'
'Продолжим: флаг Quit у нас устанавливается. Как Вы, надеюсь, помните при этом в цикле таймера вызывается процедура Form_Unload. В этой процедуре, отменяются все установки сделанные при загрузке формы.
Private Sub Form_Unload(Cancel As Integer)
ShowCursor True 'Восстановление курсора
ReleaseDC GetDesktopWindow, DDC 'Освобожление Хэндла экрана
End 'Собственно выход
End Sub

'В итоге получили работающий (во всяком случае у меня) код простенького Хранителя экрана. Но если его сейчас откомпилировать в *.scr файл, получим суррогат, который будет сложно использовать(Если хотите попробуйте выбрать такой "Хранитель" в окне свойств Рабочего стола.
'
'Особенность в том, что при запуске Хранителя экрана Windows передаёт ему параметры запуска в командной строке.
'
'Параметры командной строки передаваемые Windows
'/p - Хранитель экрана выбран в окне свойств рабочего стола. (На "мониторе" в окне должна демонстрироваться заставка)
'/c - Пользователь щёлкнул кнопку настройки параметров Хранителя экрана
'/s - Стандартный запуск, или щелчок по кнопке "Просмотр"
'/a - Пользователь хочет установить пароль.
'
'Именно для того чтобы разбирать тип запуска Хранителя экрана и существует модуль SSaver. (API-функции можно поместить и в код формы.)
Public Sub Main()
If App.PrevInstance Then Exit Sub
Select Case Left(LCase(Trim(Command$)),  2 )
Case "/s": frmSSaver.Show
Case "/c": frmProperties.Show
Case Else: End
End Select
End Sub

'В процедуре Main(не забудьте сделать её стартовой) как раз и разбираются эти параметры. Я использовал функцию Left, тем самым проигнорировав оставшиеся символы командной строки. На самом деле эти символы имеют важное значение. К примеру с параметром /p передаётся манипулятор(handle) "монитора" на окне свойств, что позволяет выводить изображение на него.


 '59. Печать RTF
'#########################

'Как вам должно быть известно, то при выводе на печать RTF текста, печать начинается с начала страницы. И ничего с этим не поделаешь? Нет, кое что сделать можно:

в модуль
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
                              ByVal nIndex As Long) As Long

Public Declare Function SendMessage Lib "user32" _
                                    Alias "SendMessageA" (ByVal hwnd As Long, _
                                    ByVal Msg As Long, ByVal wp As Long, _
                                    lp As Any) As Long

Public Declare Function CreateDC Lib "gdi32" _
                                 Alias "CreateDCA" (ByVal _
                                 lpDriverName As String, _
                                 ByVal lpDeviceName As String, _
                                 ByVal lpOutput As Long, _
                                 ByVal lpInitData As Long) As Long

Public Const WM_USER As Long = &H400
Public Const EM_FORMATRANGE As Long = WM_USER +  57 
Public Const EM_SETTARGETDEVICE As Long = WM_USER +  72 
Public Const PHYSICALOFFSETX As Long =  112 
Public Const PHYSICALOFFSETY As Long =  113 

Public Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Type CharRange
cpMin As Long
cpMax As Long
End Type

Public Type FormatRange
hdc As Long
hdcTarget As Long
rc As Rect
rcPage As Rect
chrg As CharRange
End Type

Public Function PrintRichText(RTF As RichTextBox, LeftMarginWidth As Long, _
                              TopMarginHeight, RightMarginWidth, _
                              BottomMarginHeight, Prn)
Dim LeftOffset As Long, TopOffset As Long
Dim LeftMargin As Long, TopMargin As Long
Dim RightMargin As Long, BottomMargin As Long
Dim fr As FormatRange
Dim rcDrawTo As Rect
Dim rcPage As Rect
Dim TextLength As Long
Dim NextCharPosition As Long
Dim r As Long


Prn.Print Space( 1 )
Prn.ScaleMode = vbTwips


LeftOffset = Prn.ScaleX(GetDeviceCaps(Prn.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
TopOffset = Prn.ScaleY(GetDeviceCaps(Prn.hdc, _
PHYSICALOFFSETY), vbPixels, vbTwips)


LeftMargin = LeftMarginWidth - LeftOffset
TopMargin = TopMarginHeight - TopOffset
RightMargin = (Prn.Width - RightMarginWidth) - LeftOffset
BottomMargin = (Prn.height - BottomMarginHeight) - TopOffset


rcPage.Left =  0 
rcPage.Top =  0 
rcPage.Right = Prn.ScaleWidth
rcPage.Bottom = Prn.ScaleHeight


rcDrawTo.Left = LeftMargin
rcDrawTo.Top = TopMargin
rcDrawTo.Right = RightMargin
rcDrawTo.Bottom = BottomMargin


fr.hdc = Prn.hdc ' Use the same DC for measuring and rendering
fr.hdcTarget = Prn.hdc ' Point at printer hDC
fr.rc = rcDrawTo ' Indicate the area on page to drawto
fr.rcPage = rcPage ' Indicate entire size of page
fr.chrg.cpMin =  0  ' Indicate start of text through
fr.chrg.cpMax = - 1  ' end of the text


TextLength = Len(RTF.Text)


Do
NextCharPosition = SendMessage(RTF.hwnd, EM_FORMATRANGE, True, fr)
If NextCharPosition >= TextLength Then Exit Do 'If done thenexit
fr.chrg.cpMin = NextCharPosition ' Starting position for next Page
Prn.NewPage ' Move on to next page
Prn.Print Space( 1 ) ' Re-initialize hDC
fr.hdc = Prn.hdc
fr.hdcTarget = Prn.hdc
Loop

Prn.EndDoc

r = SendMessage(RTF.hwnd, EM_FORMATRANGE, False, ByVal CLng( 0 ))

End Function


'В форму (Печать текста)
sPrinter = "INSTALLED_Printer_NAME"
'Установленый принтер принтер например: \\GMSVB\PRINTER1 (это у меня)

For i =  0  To Printers.Count -  1 
If UCase(Printers(i).Port) = UCase(sPrinter) Then
Set Printer = Printers(i)
PrintRichText RichTexBox,  500 ,  500 ,  500 ,  500 , Printer inch. ' В дюймах
Printer.EndDoc
Exit For
End If
Next i

 '60. Печать RTF
'#########################

'Одна из проблематичных частей разработки профессиональнальных приложений в Visual Basic, это добавление в программу возможности печати. С появлением Visual Basic 4 у разработчиков появилась возможность пользоваться новым объектом Printer. Однако, у этого объекта есть серьёзнае недостатки, а именно, невозможно узнать готов принтер к печати или занят, вставлена в него бумага или нет и т.д. Поэтому для получения такой информации можно воспользоваться API функцией GetPrinter.
Private Declare Function GetPrinterApi Lib "winspool.drv" Alias _
       "GetPrinterA" (ByVal hPrinter As Long, _
         ByVal Level As Long, _
         buffer As Long, _
         ByVal pbSize As Long, _
         pbSizeNeeded As Long) As Long

'Используя дескриптор принтера hPrinter она заполняет буфер информацией из драйвера принтера. Чтобы получить дескриптор из объекта Printer, нам необходимо воспользоваться API функцией OpenPrinter.
'Как только мы закончим использовать этот дескриптор, его необходимо освободить при помощи API функции ClosePrinter.
Private Type PRINTER_DEFAULTS
  pDatatype As String
  pDevMode As DEVMODE
  DesiredAccess As Long
End Type

Private Declare Function OpenPrinter Lib "winspool.drv" _
    Alias "OpenPrinterA" (ByVal pPrinterName As String, _
    phPrinter As Long, pDefault As PRINTER_DEFAULTS) As Long

Private Declare Function ClosePrinter Lib "winspool.drv" _
    (ByVal hPrinter As Long) As Long

'А вот как выглядит код получения дескриптора принтера.
Dim lret As Long
Dim pDef As PRINTER_DEFAULTS

lret = OpenPrinter(Printer.DeviceName, mhPrinter, pDef)
' Различные состояния принтера
'
'Драйвер принтера может вернуть различные стандартные состояния принтера.
Public Enum Printer_Status
   PRINTER_STATUS_READY = &H0
   PRINTER_STATUS_PAUSED = &H1
   PRINTER_STATUS_ERROR = &H2
   PRINTER_STATUS_PENDING_DELETION = &H4
   PRINTER_STATUS_PAPER_JAM = &H8
   PRINTER_STATUS_PAPER_OUT = &H10
   PRINTER_STATUS_MANUAL_FEED = &H20
   PRINTER_STATUS_PAPER_PROBLEM = &H40
   PRINTER_STATUS_OFFLINE = &H80
   PRINTER_STATUS_IO_ACTIVE = &H100
   PRINTER_STATUS_BUSY = &H200
   PRINTER_STATUS_PRINTING = &H400
   PRINTER_STATUS_OUTPUT_BIN_FULL = &H800
   PRINTER_STATUS_NOT_AVAILABLE = &H1000
   PRINTER_STATUS_WAITING = &H2000
   PRINTER_STATUS_PROCESSING = &H4000
   PRINTER_STATUS_INITIALIZING = &H8000
   PRINTER_STATUS_WARMING_UP = &H10000
   PRINTER_STATUS_TONER_LOW = &H20000
   PRINTER_STATUS_NO_TONER = &H40000
   PRINTER_STATUS_PAGE_PUNT = &H80000
   PRINTER_STATUS_USER_INTERVENTION = &H100000
   PRINTER_STATUS_OUT_OF_MEMORY = &H200000
   PRINTER_STATUS_DOOR_OPEN = &H400000
   PRINTER_STATUS_SERVER_UNKNOWN = &H800000
   PRINTER_STATUS_POWER_SAVE = &H1000000
End Enum

'Существуют несколько разных структур данных, которые возвращает драйвер принтера (в Windows 2000, например, их девять штук), однако только две первые являются наиболее универсальными и подходят для всех версий Windows. Из них вторая является наиболее интересной для нас (PRINTER_INFO_2)
Private Type PRINTER_INFO_2
   pServerName As String
   pPrinterName As String
   pShareName As String
   pPortName As String
   pDriverName As String
   pComment As String
   pLocation As String
   pDevMode As Long
   pSepFile As String
   pPrintProcessor As String
   pDatatype As String
   pParameters As String
   pSecurityDescriptor As Long
   Attributes As Long
   Priority As Long
   DefaultPriority As Long
   StartTime As Long
   UntilTime As Long
   Status As Long
   JobsCount As Long
   AveragePPM As Long
End Type

'Однако, не достаточно просто передать эту структуру в API функцию GetPrinter, так как принтер может вернуть больше информации, чем размер структуры. Поэтому, если не зарезервировать достаточного буфера для неё, программа может "выполнить недопустимую оперцию".
'К счастью, сама функция GetPrinter позволяет узнать необходимый объём буфера для структуры. Для этого достаточно передать ноль в параметре pbSize, тогда функция вернёт размер требуемого буфера в pbSizeNeeded.
'Таким образом, получение информации из драйвера принтера состоит из двух этапов:
  Dim lret As Long
  Dim SizeNeeded As Long

  Dim buffer() As Long

  ReDim Preserve buffer( 0  To  1 ) As Long
  lret = GetPrinterApi(mhPrinter, Index, buffer( 0 ), UBound(buffer), SizeNeeded)
  ReDim Preserve buffer( 0  To (SizeNeeded /  4 ) +  3 ) As Long
  lret = GetPrinterApi(mhPrinter, Index, buffer( 0 ), UBound(buffer) *  4 , SizeNeeded)

'Однако, мы выделили буфер значений Long, а некоторые значения в структуре PRINTER_INFO_2 имеют тип данных String. Поэтому, необходимо получить эти строковые данные из соответствущих адресов буфера.
'Для получения строки по указанному адресу, используется API функция CopyMemory. Текже существует API функция IsBadStringPtr, которая используется для проверки того, что по указанному адресу содержится допустимая строка.
' Функции работы с памятью
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
' Проверка указателя в StringFromPointer
Private Declare Function IsBadStringPtrByLong Lib "kernel32" Alias "IsBadStringPtrA" (ByVal lpsz As Long, ByVal ucchMax As Long) As Long

'Получение строки по указателю, это обычная вещь, поэтому такую функцию нужно всегда иметь в своём арсенале.
Public Function StringFromPointer(lpString As Long, lMaxLength As Long) As String

  Dim sRet As String
  Dim lret As Long

  If lpString =  0  Then
    StringFromPointer = ""
    Exit Function
  End If

  If IsBadStringPtrByLong(lpString, lMaxLength) Then
    ' Ошибка - данный указатель нельзя использовать
      StringFromPointer = ""
    Exit Function
  End If

  ' Подготовка к получению строки...
  sRet = Space$(lMaxLength)
  CopyMemory ByVal sRet, ByVal lpString, ByVal Len(sRet)
  If Err.LastDllError =  0  Then
    If InStr(sRet, Chr$( 0 )) >  0  Then
      sRet = Left$(sRet, InStr(sRet, Chr$( 0 )) -  1 )
    End If
  End If

  StringFromPointer = sRet

End Function

'А теперь используем эту функцию, чтобы заполнить нашу переменную PRINTER_INFO_2:
With mPRINTER_INFO_2 ' Эта переменная типа PRINTER_INFO_2
   .pServerName = StringFromPointer(buffer( 0 ),  1024 )
   .pPrinterName = StringFromPointer(buffer( 1 ),  1024 )
   .pShareName = StringFromPointer(buffer( 2 ),  1024 )
   .pPortName = StringFromPointer(buffer( 3 ),  1024 )
   .pDriverName = StringFromPointer(buffer( 4 ),  1024 )
   .pComment = StringFromPointer(buffer( 5 ),  1024 )
   .pLocation = StringFromPointer(buffer( 6 ),  1024 )
   .pDevMode = buffer( 7 )
   .pSepFile = StringFromPointer(buffer( 8 ),  1024 )
   .pPrintProcessor = StringFromPointer(buffer( 9 ),  1024 )
   .pDatatype = StringFromPointer(buffer( 10 ),  1024 )
   .pParameters = StringFromPointer(buffer( 11 ),  1024 )
   .pSecurityDescriptor = buffer( 12 )
   .Attributes = buffer( 13 )
   .Priority = buffer( 14 )
   .DefaultPriority = buffer( 15 )
   .StartTime = buffer( 16 )
   .UntilTime = buffer( 17 )
   .Status = buffer( 18 )
   .JobsCount = buffer( 19 )
   .AveragePPM = buffer( 20 )
End With

 '61. Извлечение иконок
'#########################

'Нам Понадобятся:
Command Button - Command1
TextBox -Text1
PictureBox -Picture1
'А также для удобства брауза файлов CommonDialog - CD1
Option Explicit
Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias _
"ExtractAssociatedIconA" (ByVal hInst As Long, _
ByVal lpIconPath As String, lpiIcon As Long) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, _
ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Private Declare Function DestroyIcon Lib "user32" _
(ByVal hIcon As Long) As Long

Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

'Разные Функции
Private Declare Function BitBlt Lib "gdi32" _
  (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, _
   ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
   ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020
Private Declare Function CreateCompatibleDC Lib "gdi32" _
  (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
  (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
  (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
  (ByVal hObject As Long) As Long
Private Declare Function OpenClipboard Lib "user32" _
  (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" _
  () As Long
Private Declare Function SetClipboardData Lib "user32" _
  (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" _
  () As Long
Private Const CF_BITMAP =  2 

Private Sub Command1_Click()
CD1.ShowOpen 'Открываем Брауз
Text1.Text = CD1.FileName 'Присваеваем Тексту Путь и Имя Файла
Picture1.Cls 'Очищаем Картинку От Старой Иконки
Dim sPath As String, hIcon As Long, nIcon As Long 'Присваеваем Переменные
sPath = Text1.Text 'Берем путь из Текста
'Забираем Верхнюю Иконку
hIcon = ExtractAssociatedIcon(App.hInstance, sPath, nIcon)
DrawIcon Picture1.hdc,  0 &,  0 &, hIcon 'Вставляем иконку в PictureBox
DestroyIcon hIcon 'Берём Иконку
CopyEntirePicture Picture1 'Вставляем иконку в буфер обмена.

'Теперь Можно Вставлять Иконку Хоть Куда
End Sub

'Функция Тута (Копирование Рисунка)
Public Function CopyEntirePicture(ByRef objFrom As Object) As Boolean
Dim lhDC As Long
Dim lhBMP As Long
Dim lhBMPOld As Long
Dim lWidthPixels As Long
Dim lHeightPixels As Long
lhDC = CreateCompatibleDC(objFrom.hdc)
If (lhDC <>  0 ) Then
lWidthPixels = objFrom.ScaleX(objFrom.ScaleWidth, objFrom.ScaleMode, vbPixels)
lHeightPixels = objFrom.ScaleY(objFrom.ScaleHeight, objFrom.ScaleMode, vbPixels)
lhBMP = CreateCompatibleBitmap(objFrom.hdc, lWidthPixels, lHeightPixels)
If (lhBMP <>  0 ) Then
lhBMPOld = SelectObject(lhDC, lhBMP)
BitBlt lhDC,  0 ,  0 , lWidthPixels, lHeightPixels, objFrom.hdc,  0 ,  0 , SRCCOPY
SelectObject lhDC, lhBMPOld
OpenClipboard  0 
EmptyClipboard
SetClipboardData CF_BITMAP, lhBMP
CloseClipboard
End If

DeleteObject lhDC
End If
End Function


 '61. смениа системных параметров: десятичный разделитель и разделитель в дате
'#########################

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
 
 Const WM_WININICHANGE = &H1A
 Const HWND_BROADCAST = &HFFFF

' Обычными файловыми операциями ищешь в win.ini (раздел [intl]) строки:

' sDate=.
' sDecimal=.

' Меняешь точки на что надобно, потом запускаешь:
 r = SendMessage(HWND_BROADCAST, WM_WININICHANGE,  0 , ByVal "windows")


 '62. Сохранить картинку в буфере в файл.
'#########################

' Checks the clipboard for a bitmap
' If found, creates a standard Picture object from the
' clipboard contetnts and saves it to a file

' The code requires a reference to the "OLE Automation" type library

' The code in this module has been derived primarily from _
' the PatsePicture sample on Stephen Bullen's Excel Page _
' - http://www.bmsltd.ie/Excel/Default.htm

'Windows API Function Declarations
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle _
As Long, IPic As IPicture) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, _
ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, _
ByVal un2 As Long) As Long

'The API format types we need
Const CF_BITMAP =  2 
Const IMAGE_BITMAP =  0 
Const LR_COPYRETURNORG = &H4


'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4( 0  To  7 ) As Byte
End Type

'Declare a UDT to store the bitmap information
Private Type uPicDesc
  Size As Long
  Type As Long
  hPic As Long
  hPal As Long
End Type

Public Function Clip2File()
  
  Dim strOutputPath As String, oPic As IPictureDisp
  
  'Get the filename to save the bitmap to
  strOutputPath = Environ("TEMP") & "\temp.bmp"
  
  'Retrieve the picture from the clipboard...
  Set oPic = GetClipPicture()
  
  '... and save it to the file
  If Not oPic Is Nothing Then
    SavePicture oPic, strOutputPath
    Clip2File = strOutputPath
  Else
    Clip2File = ""
    MsgBox "Unable to retrieve bitmap from clipboard"
  End If
End Function

Function GetClipPicture() As IPicture
  
  Dim h As Long, hPicAvail As Long, hPtr As Long, _
  hPal As Long, hCopy As Long
  
  'Check if the clipboard contains a bitmap
  hPicAvail = IsClipboardFormatAvailable(CF_BITMAP)
  
  If hPicAvail <>  0  Then
    'Get access to the clipboard
    h = OpenClipboard( 0 &)
    If h >  0  Then
      'Get a handle to the image data
      hPtr = GetClipboardData(CF_BITMAP)
      hCopy = CopyImage(hPtr, IMAGE_BITMAP,  0 ,  0 , LR_COPYRETURNORG)
      'Release the clipboard to other programs
      h = CloseClipboard
      'If we got a handle to the image, convert it into _
      'a Picture object and return it
      If hPtr <>  0  Then Set GetClipPicture = CreatePicture(hCopy, _
         0 , CF_BITMAP)
    End If
  End If
  
End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, _
ByVal lPicType) As IPicture
  
  ' IPicture requires a reference to "OLE Automation"
  Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, _
  IPic As IPicture
  
  'OLE Picture types
  Const PICTYPE_BITMAP =  1 
  
  ' Create the Interface GUID (for the IPicture interface)
  With IID_IDispatch
    .Data1 = &H7BF80980
    .Data2 = &HBF32
    .Data3 = &H101A
    .Data4( 0 ) = &H8B
    .Data4( 1 ) = &HBB
    .Data4( 2 ) = &H0
    .Data4( 3 ) = &HAA
    .Data4( 4 ) = &H0
    .Data4( 5 ) = &H30
    .Data4( 6 ) = &HC
    .Data4( 7 ) = &HAB
  End With
  
  ' Fill uPicInfo with necessary parts.
  With uPicInfo
    .Size = Len(uPicInfo) ' Length of structure.
    .Type = PICTYPE_BITMAP ' Type of Picture
    .hPic = hPic ' Handle to image.
    .hPal =  0  ' Handle to palette (if bitmap).
  End With
  
  ' Create the Picture object.
  r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
  
  ' Return the new Picture object.
  Set CreatePicture = IPic
  
End Function