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 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
'Win API позволяющая задать прозрачность окна
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, _
ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
' Layered - степень прозрачности 0-255
' Примечание: форма должна быть всплывающей
Public Sub TransparentForm(hwnd As Long, Layered As Byte)
Dim ret As Long
ret = GetWindowLong(hwnd, GWL_EXSTYLE)
ret = ret Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, ret
SetLayeredWindowAttributes hwnd, 0, Layered, LWA_ALPHA
End Sub
'вызывается
TransparentForm Me.hwnd, 230