ВАМ ВСЕМ ПРИГОДИТСЯ.
Полупрозрачные окна !!!!!!!!!!!!!!!!!!!!!NEW!!!!!!!!!! см в
конце
Определение разрешения и количества цветов
дисплея
Как изменить текущее разрешение экрана
Поместить
свою иконку в traybar
Узнать, в какой каталог была
проинсталлирована Windows
Определение версии операционной
системы (Win95/Win98/NT)
Прочитать/записать ключ в
системный реестр (registry)
Рисование линий на
десктопе
Закрываем окно по заголовку
Определение
координат курсора мыши
Программная перезагрузка
Windows
Как узнать, куда установлен Windows?
Как
изменить обои (wallpapers) Windows?
Открытие/закрытие
CD-ROM
Приостановить выполнение программы на определенное
время
'Плавающее' окно (Always On Top)
Как из программы
открыть веб-страничку
Как нарисовать прозрачную
картинку
Просмотр AVI-файлов
Скрыть/показать кнопку
"ПУСК"
Скрыть/показать все панель (system
tray)
Скрыть/показать Alt+Ctrl+Del
Невидимая при
Alt+Ctrl+Del
Вывести окно About системы Windows
Создание
нестандартных окон
1. Определение разрешения и количества цветов дисплея
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
Использование:
Dim Height As Long, Width As Long, Depth As
Long
GetVideoMode Width, Height, Depth
Примечание: В
переменной Depth возвращается не количество цветов, а
количество битов на один
пиксель. Т.е. 16 цветам
соответствует 4 бита на пиксель, 256 - 8 бит, 65536 - 16 бит и
т.д.
2. Как изменить текущее разрешение экрана
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
Использование:
SetVideoMode 1024, 768, 8 ' Устанавливает видеорежим
1024x768x256
3. Поместить свою иконку в traybar
Declare Function Shell_NotifyIconA Lib "SHELL32" (ByVal
dwMessage As Long, lpData As NOTIFYICONDATA) As Integer
Public Const NIM_ADD = 0
Public Const NIM_MODIFY =
1
Public Const NIM_DELETE = 2
Public Const NIF_MESSAGE =
1
Public Const NIF_ICON = 2
Public Const NIF_TIP = 4
Type NOTIFYICONDATA
cbSize As Long
hWnd As
Long
uID As Long
uFlags As Long
uCallbackMessage As
Long
hIcon As Long
szTip As String * 64
End Type
Public Function SetTrayIcon(Mode As Long, hWnd As Long,
Icon As Long, tip As String) As Long
Dim nidTemp As
NOTIFYICONDATA
nidTemp.cbSize =
Len(nidTemp)
nidTemp.hWnd = hWnd
nidTemp.uID =
0&
nidTemp.uFlags = NIF_ICON Or
NIF_TIP
nidTemp.uCallbackMessage = 0&
nidTemp.hIcon
= Icon
nidTemp.szTip = tip & Chr$(0)
SetTrayIcon =
Shell_NotifyIconA(Mode, nidTemp)
End
Function
Использование:
' Добавить иконку формы в traybar
SetTrayIcon NIM_ADD,
Me.hWnd, Me.Icon, "Test"
' Изменить иконку и
tooltip
SetTrayIcon NIM_MODIFY, Me.hWnd, Me.Icon, "It
works!"
' Удалить иконку из traybar'a
SetTrayIcon
NIM_DELETE, Me.hWnd, 0&, ""
4. Узнать, в какой каталог была проинсталлирована Windows
Declare Function GetTempPath Lib "kernel32" Alias
"GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer
_
As String) As Long
Declare Function GetSystemDirectory
Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As
String, ByVal nSize _
As Long) As Long
Declare Function
GetWindowsDirectory Lib "kernel32" Alias
"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize
_
As Long) As Long
Использование:
Dim sDir As String, sTemp As String * 256
nSize =
GetWindowsDirectory(sTemp, 255): sDir = Left(sTemp,
nSize)
' sDir = "C:WINDOWS"
nSize =
GetSystemDirectory(sTemp, 255): sDir = Left(sTemp, nSize)
'
sDir = "C:WINDOWSSYSTEM"
nSize = GetTempPath(255, sTemp):
sDir = Left(sTemp, nSize)
' sDir =
"C:WINDOWSTEMP"
Примечание: Последняя функция, в отличие от
первых двух, возвращает путь с завершающим слэшем на
конце.
5. Определение версии операционной системы (Win95/Win98/NT)
Public Type OSVERSIONINFO
dwOSVersionInfoSize As
Long
dwMajorVersion As Long
dwMinorVersion As
Long
dwBuildNumber As Long
dwPlatformId As
Long
szCSDVersion As String * 128
End Type
Public Const VER_PLATFORM_WIN32s = 0
Public Const
VER_PLATFORM_WIN32_WINDOWS = 1
Public Const
VER_PLATFORM_WIN32_NT = 2
Declare Function GetVersionEx Lib "kernel32" Alias
"GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As
Long
Public Function IsWindowsNT() As Boolean
Dim osvi As
OSVERSIONINFO
osvi.dwOSVersionInfoSize =
Len(osvi)
GetVersionEx osvi
IsWindowsNT =
(osvi.dwPlatformId = VER_PLATFORM_WIN32_NT)
End
Function
Public Function IsWindows98() As Boolean
Dim osvi As
OSVERSIONINFO
osvi.dwOSVersionInfoSize =
Len(osvi)
GetVersionEx osvi
IsWindows98 =
(osvi.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS And
osvi.dwMinorVersion >= 10 And osvi.dwMajorVersion =
4)
End Function
Использование:
bWindowsNT = IsWindowsNT() ' True, если установлена
NT
bWindows98 = IsWindows98() ' True, если установлена
Windows98
6. Прочитать/записать ключ в системный реестр (registry)
'Registry keys
Public Const HKEY_CLASSES_ROOT =
&H80000000
Public Const HKEY_CURRENT_USER =
&H80000001
Public Const HKEY_LOCAL_MACHINE =
&H80000002
Public Const HKEY_USERS =
&H80000003
Public Const HKEY_PERFORMANCE_DATA =
&H80000004
Public Const HKEY_CURRENT_CONFIG =
&H80000005
Public Const HKEY_DYN_DATA =
&H80000006
'Registry access constants
Public Const KEY_QUERY_VALUE
= &H1 'Permission to query subkey data.
Public Const
KEY_SET_VALUE = &H2 'Permission to set subkey
data.
Public Const KEY_CREATE_SUB_KEY = &H4
Public
Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const
KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK =
&H20
Public Const KEY_READ = KEY_QUERY_VALUE Or
KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
Public Const KEY_WRITE
= KEY_SET_VALUE Or KEY_CREATE_SUB_KEY
Public Const
KEY_ALL_ACCESS = KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or
_
KEY_NOTIFY Or KEY_CREATE_SUB_KEY Or KEY_CREATE_LINK Or
KEY_SET_VALUE
Public Const REG_OPTION_NON_VOLATILE = 0&
Public
Const REG_OPTION_VOLATILE = &H1
Public Type SECURITY_ATTRIBUTES
nLength As
Long
lpSecurityDescriptor As Long
bInheritHandle As
Long
End Type
Public Enum RegTypes
RegNonee = 0
RegSZ =
1
RegExpandSz = 2
RegBinary = 3
RegDword =
4
RegDwordLittleEndian = 4
RegDwordBigEndian =
5
RegLink = 6
RegMultiSz = 7
RegResourceList =
8
RegFulResourceDesc = 9
End Enum
Declare Function RegOpenKeyEx Lib "advapi32" Alias
"RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String,
ByVal ulOptions As Long, ByVal samDesired As Long,
phkResult As Long) As Long
Declare Function RegSetValueEx
Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long,
ByVal lpValueName As String,
ByVal Reserved As Long, ByVal
dwType As Long, ByVal szData As String, ByVal cbData As Long)
As Long
Declare Function RegCloseKey Lib "advapi32" (ByVal
hKey As Long) As Long
Declare Function RegQueryValueEx Lib
"advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal
lpValueName As String,
ByVal lpReserved As Long, ByRef
lpType As Long, ByVal szData As String, ByRef lpcbData As
Long) As Long
Declare Function RegCreateKeyEx Lib
"advapi32" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal
lpSubKey As String,
ByVal Reserved As Long, ByVal lpClass
As String, ByVal dwOptions As Long, ByVal samDesired As Long,
ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES,
phkResult As Long, lpdwDisposition As Long) As Long
Public Function RegGetValue(Root As Long, SubKey As String,
Key As String) As String
Dim Buffer As String, hKey As
Long, nType As Long, nSize As Long
RegGetValue = ""
If
Not RegOpenKeyEx(Root, SubKey, 0, KEY_READ, hKey)
Then
nSize = 0
RegQueryValueEx hKey, Key, 0, nType,
Buffer, nSize
If hKey And nSize > 0 And nType = RegSZ
Then
Buffer = Space(nSize + 1)
RegQueryValueEx hKey,
Key, 0, nType, Buffer, nSize
RegGetValue = Left(Buffer,
nSize - 1)
RegCloseKey hKey
End If
End If
End
Function
Public Sub RegSetValue(Root As Long, SubKey As String, Key
As String, value As String)
Dim hKey As Long, sa As
SECURITY_ATTRIBUTES, nDisp As Long
If Not
RegCreateKeyEx(Root, SubKey, 0, vbNull,
REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, sa, hKey, nDisp)
Then
RegSetValueEx hKey, Key, 0, RegSZ, value, Len(value) +
1
RegCloseKey hKey
End If
End Sub
Использование:
sUser = RegGetValue(HKEY_LOCAL_MACHINE,
"SoftwareMicrosoftWindowsCurrentVersion",
"RegisteredOwner")
RegSetValue HKEY_LOCAL_MACHINE,
"SoftwareMicrosoftWindowsCurrentVersion", "RegisteredOwner",
"Darth Vader"
Примечание: Эти функции работают только с текстовыми
ключами (те, что в RegEdit'e помечены символом 'ab').
7. Рисование линий на десктопе
Type POINTAPI
x As Long
y As Long
End
Type
Declare Function GetDesktopWindow Lib "user32" () As
Long
Declare Function GetWindowDC Lib "user32" (ByVal hwnd
As Long) As Long
Declare Function CreatePen Lib "gdi32"
(ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor
As Long) As Long
Declare Function SelectObject Lib "gdi32"
(ByVal hdc As Long, ByVal hObject As Long) As Long
Declare
Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As
Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Declare
Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As
Long, ByVal y As Long) As Long
Public Sub DrawLine(StartX As Long, StartY As Long, EndX As
Long, EndY As Long, LineStyle As Long, LineWidth As Long,
LineColor As Long)
Dim Pnt As POINTAPI, y As Boolean,
PenHND As Long, z As Long
DeskTopDc =
GetWindowDC(GetDesktopWindow)
PenHND = CreatePen(LineStyle,
LineWidth, LineColor)
z = SelectObject(DeskTopDc,
PenHND)
y = MoveToEx(DeskTopDc, StartX, StartY, Pnt)
y =
LineTo(DeskTopDc, EndX, EndY)
End Sub
Использование:
DrawLine 100, 100, 300, 300, vbSolid, 1, vbRed
8. Закрываем окно по заголовку
Option Explicit
Private Declare Function PostMessage Lib
"user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg
As Long,
ByVal wParam As Long, lParam As Any) As
Long
Private Declare Function FindWindow Lib "user32" Alias
"FindWindowA" (ByVal lpClassName As String,
ByVal
lpWindowName As String) As Long
Const WM_CLOSE =
&H10
Использование:
Dim hW&
hW& =
FindWindow(vbNullString, "Заголовок" &
Chr(0))
PostMessage hW&, WM_CLOSE, 0&, 0&
9. Определение координат курсора мыши
Option Explicit
Private Declare Function GetCursorPos
Lib "user32" (lpPoint As POINTAPI) As Long
Private Type
POINTAPI
X As Long
Y As Long
End
Type
Использование:
Dim c As POINTAPI
GetCursorPos
c
MsgBox "x= " & c.X & vbCr & "y= " &
c.Y
10. Программная перезагрузка Windows
Public Declare Function ExitWindowsEx Lib "user32" (ByVal
uFlags As Long, ByVal dwReserved As Long) As Long
Public
Const EWX_FORCE = 4
Public Const EWX_LOGOFF = 0
Public
Const EWX_REBOOT = 2
Public Const EWX_SHUTDOWN =
1
Использование:
ExitWindowsEx EWX_FORCE + EWX_REBOOT, 0
11. Как
узнать, куда установлен Windows?
Private Declare Function GetWindowsDirectory Lib "kernel32"
Alias _
"GetWindowsDirectoryA" (ByVal lpBuffer As String,
ByVal nSize As Long) As Long
Private Function GetWinDir()
As String
Dim s As String
s = String$(255, vbNullChar)
GetWindowsDirectory s, Len(s)
GetWinDir = Left$(s,
InStr(s, vbNullChar) - 1)
End Function
Использование:
MsgBox GetWinDir
12. Как изменить обои (wallpapers)
Windows?
Declare Function SystemParametersInfo Lib "user32" Alias
"SystemParametersInfoA" (ByVal uAction As Long,
ByVal
uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As
Long
Public Const SPI_SETDESKWALLPAPER = 20
Public Sub
SetWallpaper(File As String)
SystemParametersInfo
SPI_SETDESKWALLPAPER, 0, ByVal File, True
End
Sub
Использование:
SetWallpaper "clouds.bmp"
13. Открытие/закрытие 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)
14. Приостановить выполнение программы на определенное
время
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As
Long)
Использование:
Sleep 10000 ' Пауза на 10 секунд
15. 'Плавающее' окно (Always On Top)
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_TOPMOST = -1
Public
Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE =
&H1
Использование:
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE
+ SWP_NOSIZE
16. Как из программы открыть веб-страничку
Declare Function ShellExecute Lib "shell32.dll" Alias
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As
String,
ByVal lpFile As String, ByVal lpParameters As
String, ByVal lpDirectory As String, ByVal nShowCmd As Long)
As Long
Public Const SW_SHOW = 5
Public Sub Navigate(frm
As Form, ByVal NavTo As String)
Dim hBrowse As
Long
hBrowse = ShellExecute(frm.hwnd, "open", NavTo, "",
"", SW_SHOW)
End Sub
Использование:
Navigate Me, "http://vb.astral.kiev.ua/"
17. Как нарисовать прозрачную картинку
Option Explicit
Public 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
Public Declare Function SetBkColor Lib "gdi32" (ByVal
hdc As Long, ByVal crColor As Long) As Long
Public Declare
Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As
Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal
hdc As Long) As Long
Public Declare Function
CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal
nWidth As Long, ByVal nHeight As Long) _
As Long
Public
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long,
ByVal hObject As Long) As Long
Public Declare Function
DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd
As Long) As Long
Public Declare Function GetBkColor Lib
"gdi32" (ByVal hdc As Long) As Long
Public Declare Function
GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Public
Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long,
ByVal crColor As Long) As Long
Public Declare Function
CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight
As Long, ByVal nPlanes As Long,
ByVal nBitCount As Long,
lpBits As Any) As Long
Public Declare Function
SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette
As Long, ByVal bForceBackground As Long)
As Long
Public
Declare Function RealizePalette Lib "gdi32" (ByVal hdc As
Long) As Long
Public Declare Function ReleaseDC Lib
"user32" (ByVal hwnd As Long, ByVal hdc As Long) As
Long
Public Declare Function CreateHalftonePalette Lib
"gdi32" (ByVal hdc As Long) As Long
Public Declare Function
OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long,
ByVal lHPalette As Long,
lColorRef As Long) As Long
'Raster Operation Codes
Public Const DSna = &H220326
'0x00220326
Public Sub PaintTransparentDC(ByVal hdcDest As Long,
_
ByVal xDest As Long, _
ByVal yDest As Long, _
ByVal
Width As Long, _
ByVal Height As Long, _
ByVal hdcSrc As
Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long,
_
ByVal clrMask As OLE_COLOR, _
Optional ByVal hPal As
Long = 0)
Dim hdcMask As Long 'HDC для изображения
маски
Dim hdcColor As Long 'HDC для цветного
изображения
Dim hbmMask As Long 'Дескриптор маски
Dim
hbmColor As Long 'Дескриптор цветного изображения
Dim
hbmColorOld As Long
Dim hbmMaskOld As Long
Dim hPalOld
As Long
Dim hdcScreen As Long
Dim hdcScnBuffer As Long
'Основной буфер
Dim hbmScnBuffer As Long
Dim
hbmScnBufferOld As Long
Dim hPalBufferOld As Long
Dim
lMaskColor As Long
Dim m_hpalHalftone As Long
'Halftone-палитра, используется по умолчанию
hdcScreen
= GetDC(0&)
m_hpalHalftone =
CreateHalftonePalette(hdcScreen)
'Проверяем палитру
If
hPal = 0 Then
hPal = m_hpalHalftone
End
If
OleTranslateColor clrMask, hPal,
lMaskColor
'Создаем в памяти цветную битмапу и копируем
в нее содержимое Destination
'Все операции будут
производится именно в этом буфере, а затем
'готовое
изображение будет скопировано в destination
hbmScnBuffer =
CreateCompatibleBitmap(hdcScreen, Width, Height)
'Создаем
контекст устройства (DC) для буфера экрана
hdcScnBuffer =
CreateCompatibleDC(hdcScreen)
hbmScnBufferOld =
SelectObject(hdcScnBuffer, hbmScnBuffer)
hPalBufferOld =
SelectPalette(hdcScnBuffer, hPal, True)
RealizePalette
hdcScnBuffer
'Копируем изображение из destination в буфер
экрана
BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcDest,
xDest, yDest, vbSrcCopy
'Создаем цветную битмапу для
копии исходного изображения
hbmColor =
CreateCompatibleBitmap(hdcScreen, Width, Height)
'Создаем
черно-белую битмапу для маски
hbmMask = CreateBitmap(Width,
Height, 1, 1, ByVal 0&)
'Создаем копию исходного
изображения в hdcColor
'В дальнейшем будем его использовать
вместо source
hdcColor =
CreateCompatibleDC(hdcScreen)
hbmColorOld =
SelectObject(hdcColor, hbmColor)
hPalOld =
SelectPalette(hdcColor, hPal, True)
RealizePalette
hdcColor
SetBkColor hdcColor,
GetBkColor(hdcSrc)
SetTextColor hdcColor,
GetTextColor(hdcSrc)
BitBlt hdcColor, 0, 0, Width, Height,
hdcSrc, xSrc, ySrc, vbSrcCopy
'Рисуем маску. Нам требуется
получить черно-белое изображение, в котором
'точки белого
цвета соответствуют прозрачным точкам исходного
изображения,
'а черные - всему остальному.
hdcMask =
CreateCompatibleDC(hdcScreen)
hbmMaskOld =
SelectObject(hdcMask, hbmMask)
'Когда происходит BitBlt цветного изображения в
черно-белое, Windows
'устанавливает в 1 все пикели,
совпадающие с цветом фона исходного
'изображения. Остальные
пиксели устанавливаются в 0.
SetBkColor hdcColor,
lMaskColor
SetTextColor hdcColor, vbWhite
BitBlt
hdcMask, 0, 0, Width, Height, hdcColor, 0, 0,
vbSrcCopy
'Рисуем оставшуюся часть изображения.
'
'На
данном этапе мы хотим окрасить в черный цвет точки,
соответствующие
'прозрачным пикселям исходного изображения.
Для этого сначала скопируем
'оригинальное изображение в
буфер (это мы уже сделали), а затем применим
'к нему
операцию AND с инвертированной маской (код DSna, означающий
в
'обратной польской записи "(not SRC) and
DEST").
'
'Когда происходит BitBlt из черно-белого
изображения в цветное, Windows
'преобразует все белые точки
в цвет фона destination hDC. Все черные
'точки
преобразуются в цвет переднего плане (foreground
color)
SetTextColor hdcColor, vbBlack
SetBkColor
hdcColor, vbWhite
BitBlt hdcColor, 0, 0, Width, Height,
hdcMask, 0, 0, DSna
'Накладываем маску на буфер
экрана
BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcMask,
0, 0, vbSrcAnd
'Объединяем содержимое буфера и
hdcColor
BitBlt hdcScnBuffer, 0, 0, Width, Height,
hdcColor, 0, 0, vbSrcPaint
'Копируем изображение из буфера
на экран
BitBlt hdcDest, xDest, yDest, Width, Height,
hdcScnBuffer, 0, 0, vbSrcCopy
'Готово!
DeleteObject
SelectObject(hdcColor, hbmColorOld)
SelectPalette hdcColor,
hPalOld, True
RealizePalette hdcColor
DeleteDC
hdcColor
DeleteObject SelectObject(hdcScnBuffer,
hbmScnBufferOld)
SelectPalette hdcScnBuffer, hPalBufferOld,
True
RealizePalette hdcScnBuffer
DeleteDC
hdcScnBuffer
DeleteObject SelectObject(hdcMask,
hbmMaskOld)
DeleteDC hdcMask
ReleaseDC 0&,
hdcScreen
DeleteObject m_hpalHalftone
End
Sub
Использование: Кидаем на форму PictureBox, в него
загружаем произвольную картинку. Устанавливаем у него и у
формы свойство .AutoRedraw = True. Далее вставляем код:
Picture1.ScaleMode = vbPixels
PaintTransparentDC Me.hdc,
0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hdc,
0, 0, vbWhite
Все белые точки изображения должны стать
прозрачными.
18. Просмотр AVI-файлов
'If Win32 Then
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
'Else
Private Declare Function mciSendString Lib "mmsystem"
(ByVal lpstrCommand As String, ByVal lpstrReturnStr As
Any
, ByVal wReturnLen As Integer, ByVal hCallBack As
Integer) As Long
'End If
Использование:
' Открыть в окне
CmdStr$ =
"play d:winntclock.avi"
ReturnVal& =
mciSendString(CmdStr$, 0&, 0, 0&)
' Открыть на полном экране
CmdStr$ = "play
d:winntclock.avi fullscreen "
ReturnVal& =
mciSendString(CmdStr$, 0&, 0, 0&)
19. Скрыть/показать кнопку "ПУСК"
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 'скрывает "ПУСК"
20. Скрыть/показать все панель (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)
21. Скрыть/показать Alt+Ctrl+Del
Private Declare Function SystemParametersInfo Lib "user32"
Alias "SystemParametersInfoA" (ByVal uAction As Long,
ByVal
uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long)
As Long
Sub DisableCtrlAltDelete(bDisabled As
Boolean)
Dim X As Long
X = SystemParametersInfo(97,
bDisabled, CStr(1), 0)
End Sub
Скрыть List:
Call DisableCtrlAltDelete(True)
Показать List:
Call DisableCtrlAltDelete(False)
22. Невидимая при Alt+Ctrl+Del
Option Explicit
Private Declare Function
RegisterServiceProcess Lib "kernel32.dll" (ByVal dwProcessId
As Long, ByVal dwType As Long) As Long
Private Declare
Function GetCurrentProcessId Lib "kernel32.dll" () As
Long
Показать событие:
Call
RegisterServiceProcess(GetCurrentProcessId, 0)
Скрыть событие:
Call
RegisterServiceProcess(GetCurrentProcessId, 1)
23. Вывести
окно About системы Windows
Private Declare Function ShellAbout Lib "shell32.dll" Alias
"ShellAboutA" (ByVal hWnd As Long, ByVal szApp As
String,
ByVal szOtherStuff As String, ByVal hIcon As Long)
As Long
Использование:
Dim sApp$, sNote$
sApp = "My Application"
sNote = "My
Description"
Call ShellAbout(hWnd, sApp, sNote,
Icon)
End Sub
24. Создание нестандартных окон
В Visual Basic очень легко создавать простые виндосовские
окна! Но ведь они такие прямоугольные серые и некрасивые... К
сожалению в VB нет интегрированных методов решения этой
проблемы и нам приходится прибегать к помощи API-функций. В
этой статье я покажу почти все возможности использования
регионов: регионы любой формы, регионы с загруглёнными углами
и комбинирование регионов! Итак, начнём! [Окна любых форм]
1.Конечно же нужно создать стандартный EXE-проект. Теперь
создайте единственный на форме объект Image. Назовём его
stern. 2.Так, начнём с создания регионов любой формы. Мне
кажется красивее будет если на форме будет рисунок, вокруг
которого мы и "отрежем" лишнее. Поэтому запустим Paint,
аттрибуты рисунка установим 249 по высоте и 313 по ширине.
Теперь нарисуем самый угловатый рисунок - звёздочку (как у
октябрят :)) Кто очень талантливый может посерёдке нарисовать
вoждя мирового пролетариата - на регионы это никак не повлияет
:)))! 3.Сохраните рисунок. Теперь объекту image по имени stern
присвоим этот рисунок. 4.Присвоили? Теперь сдвиньте его
подальше вниз за пределы формы, чтобы он не мешался, а размеры
формы установите равными: Width = 4710, Height = 3780. В
свойстве BorderStyle установите флажок 0-None. Свойство
AutoRedraw установите равным True. Готово! Теперь приступим к
созданию! 5.Сделайте двойной клик по форме и впишите в раздел
General Declarations: Private Declare Function SetWindowRgn
Lib "user32" (ByVal hwnd _ As Long, ByVal hRgn As Long, ByVal
bRedraw As Boolean) As Long Private Declare Function
CreatePolygonRgn Lib "gdi32" (lpPoint _ As POINTAPI, ByVal
nCount As Long, ByVal nPolyFillMode As Long) As Long Private
Type POINTAPI X As Long Y As Long End Type Dim P(10) As
POINTAPI Теперь объясню зачем это. Первая API-функция
SetWindowRgn так сказать накладывает созданный регион на окно.
Те части которые остались за пределами региона исчезают.
Знаете с чем это можно сравнить? Есть такие специальные
жестянные формочки для выпечки печения. Они все в форме всяких
цветков, звёздочек, колокольчиков и т.д. Так вот я видел пару
раз как ими работают: лежит, например, на столе кусок теста и
человек просто ложит эти острые формочки на него и выдавлевает
формы этих самых цветков, звёздочек, колокольчиков!!! По
такому же принципу и взамодействует окно с регионом. Наша же
задача - это именно создание "формочки" для формы ;)
Передаваемые значения это: hwnd - идентификатор окна, на
котором нужно "выдавить" форму hRgn - "формочка" для окна
bRedraw - перерисовывать ли окно после "выдавления"? Для того,
чтобы создать регион-"формочку" нам нужна вторая вторая
API-функция CreatePolygonRgn. Состоит регион из n-ого
количества точек, которое Вы и должны задать! Т.е., например,
что бы описать звезду, нам нужны все её точки, как внутрение,
так и наружние. Как их всех найти мы рассмотрим позже, а
сейчас посмотрим на параметры: lpPoint - первая точка региона.
nCount - количество точек nPolyFillMode - описание метода
заливки полигона Каждая точка на форме, как известно, имеет
свои координаты - по иксу и по игреку. Поэтому каждая точка
должна содержаться в переменной-ящичке POINTAPI. Всего точек у
звезды десять (5 внутренних и пять наружних), но регион это
замкнутая форма, поэтому какaя-то точка будет подсчитана
дважды, как первая и как последняя. Итак нам нужны одиннадцать
точек и каждая имеет свои координаты. Для этого-то мы и
объявили массив P по типу POINTAPI. В скобках стоит десять,
но, т.к. счёт идёт у Бэйсика с нуля, то и значений в нём
одиннадцать. 6.А теперь в событие Form_Load впишем: Picture =
stern Строка выглядит немного странновато, да. Зато короче уже
не придумаешь. Это значит: Me.Picture = stern.Picture Умный VB
определил, что свойству формы Picture ничего не нужно, как
такого же вида свойство. Это можно делать со строковыми
свойствами: Label1 = "ABCVB" Но это не относится к теме.
Теперь при загрузки формы на ней будет появляться звезда. 7.А
вот теперь нам надо найти все точки, вокруг которых будет
описан регион. Снова кликаем на форме и в окне Code в раздел
General Declarations временно объявляем переменную-счётчик m,
которая будет подсчитывать и подставлять точки региона: Dim m
As Integer Теперь выбираем событие Form_MouseDown и вписываем:
Private Sub Form_MouseDown(Button As Integer, Shift As
Integer, _ X As Single, Y As Single) Debug.Print "P(" & m
& ").X=" & X / Screen.TwipsPerPixelX _ & ":" &
"P(" & m & ").Y=" & Y / Screen.TwipsPerPixelY m =
m + 1 End Sub Что делает эта процедура? Нет, сначала объясню,
что должны сделать Вы. Вам нужно запустить проект и клинуть на
каждой из одиннадцати кнопок звёздочки, а процедура Mouse_Down
будет в свою очередь генерировать код присвоения каждой точкe
её координат в пикселах. Код потом можно будет прямо вставить
в программу. Появляться будут строки примерно следующего
содержания: P(0).X = 132: P(0).Y = 6 P(1).X = 173: P(1).Y = 64
P(2).X = 303: P(2).Y = 71 P(3).X = 213: P(3).Y = 123 P(4).X =
291: P(4).Y = 241 P(5).X = 157: P(5).Y = 154 P(6).X = 5:
P(6).Y = 239 P(7).X = 78: P(7).Y = 103 P(8).X = 10: P(8).Y =
58 P(9).X = 100: P(9).Y = 60 Так было у меня. Теперь вырежте
этот код в событие Form_Load и уже вручную допишите код
первой-последней точки с координатами точно, как у первой
точки: P(10).X = 132: P(10).Y = 6 8.Теперь строку Dim m As
Integer и событие Form_MouseDown удалите вообще - они нам
больше не нужны - координаты точек у нас есть. Тепeрь осталось
всего-то создать регион и выдавить его на форме! В событие
Form_Load допишем под присвоением координaт точек: Dim Rgn As
Long Эта переменная будет содержать регион. Теперь чуть ниже
впишем строку создания региона: Rgn = CreatePolygonRgn(P(0),
10, 0) и ещё чуть ниже выдавливем форму: Call
SetWindowRgn(hwnd, Rgn, True) Готово! Теперь просто запускаем.
Любуемся! По этому ёе принципу можно создавать окна
немысленных форм!!! Конечно, чем больше задано точек, тем
красивее и точнее будет форма. Так же можно создавать точки во
время передвижения мыши по форме. Точек будет конечно же
много, но Вам ведь нужно просто их переставить в другое окно и
всё! Сделать это надо так: В разделе General Declarations
объявляем переменную Dim IfMove As Boolean Dim m As Integer
Теперь вставьте три следующих события чуть ниже: Private Sub
Form_MouseUp(Button As Integer, Shift As _ Integer, X As
Single, Y As Single) IfMove = False End Sub Private Sub
Form_MouseDown(Button As Integer, Shift _ As Integer, X As
Single, Y As Single) IfMove = True End Sub Private Sub
Form_MouseMove(Button As Integer, Shift As _ Integer, X As
Single, Y As Single) If IfMove Then Debug.Print "P(" & m
& ").X=" & X / Screen.TwipsPerPixelX _ & ":" &
"P(" & m & ").Y=" & Y / Screen.TwipsPerPixelY m =
m + 1 End If End Sub А теперь последняя проблемка -
передвижение формы по экрану! Объявим переменную, проверяющую
двигается ли мышь и две переменные для значений положения
мышки во время нажатия и добавим три процедуры: Dim IfMove As
Boolean Dim X1 As Integer Dim Y1 As Integer Private Sub
Form_MouseDown(Button As Integer, Shift _ As Integer, X As
Single, Y As Single) IfMove = True X1 = X Y1 = Y End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As _
Integer, X As Single, Y As Single) IfMove = False End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As _
Integer, X As Single, Y As Single) If IfMove Then Move Left +
X - X1, Top + Y - Y1 End If End Sub А вот второй способ
осуществим при помощи API функции SendMessage. В раздел
General Declarations допишем следующие API-функции: 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 Sub
ReleaseCapture Lib "user32" () Добавим процедуру передвижения
иышки: Private Sub Form_MouseMove(Button As Integer, Shift As
_ Integer, X As Single, Y As Single) 'если была нажата левая
кнопка вызываем процедуры If Button = 1 Then Call
ReleaseCapture Call SendMessage(hwnd, &HA1, 2, 0&) End
If End Sub [Окна c закругленными углами] А вот это ещё проще!
А всё-таки тоже необычно - часто Вы встречаете окна с
закругленными углами??? 1.В раздел General Declarations
допишем следующую API-функцию: Private Declare Function
CreateRoundRectRgn Lib "gdi32" _ (ByVal X1 As Long, ByVal Y1
As Long, ByVal X2 As Long, _ ByVal Y2 As Long, ByVal X3 As
Long, ByVal Y3 As Long) As Long Её параметры: X1,Y1 -
координаты верхней левой точки прямоугольника, углы которого
надо закруглить X2,Y2 - координаты нижней правой точки X3 -
ширина овала, применяемого для закругления углов Y3 - его
высота 2.Теперь попробуем создать такой. В событии Form_Load
закомментируйте строку Picture = stern, чтобы картинка больше
не появлялась. А под строкой Dim Rgn As Long объявите ещё одну
переменную для региона: Dim Rgn2 As Long Теперь создадим
второй регион: Rgn2 = CreateRoundRectRgn(0, 0, Width /
Screen.TwipsPerPixelX, _ Height / Screen.TwipsPerPixelY, 50,
50) В качестве аргументов мы передаём координаты формы в
пикселах а высоту и ширину овала задаём одинаковой, тем самым
углы будут именно закруглены, а не "заовалены" :). Теперь чуть
ниже вставьте эту строку, окраски формы в красный цвет:
BackColor = QBColor(12) И строку Call SetWindowRgn(hwnd, Rgn,
True) исправьте на Call SetWindowRgn(hwnd, Rgn2, True)
Запускайте! Потрясающе, неправда ли !? Но вот если бы была ещё
рамка, было бы просто неотразимо. Но ведь это тоже
осуществимо! Правда совсем не такая, как у стандарного окна,
но всё-таки! 3.Для этого можно применить API-функцию FrameRgn.
Итак, под все остальные API-функции допишем ещё одну: Private
Declare Function FrameRgn Lib "gdi32" (ByVal hDC As Long, _
ByVal hRgn As Long, ByVal hBrush As Long, ByVal nWidth As
Long, _ ByVal nHeight As Long) As Long Передаваемые параметры:
hDC - handle Device Context (я не понимаю что это, но что-то
на подобии hWnd - может идентификатор какой?...) hRgn -
регион, который надо "обрамить" hBrush - что это за "щётка" не
понимаю тоже, но её надо прежде тоже создать (!) скорее всего
это вид рисования рамки. nWidth, nHeight - толшина рамки по
высоте и ширине И, как я уже сказал, нам нужна ещё одна
API-функция для создания "щётки" (дописываем под первую):
Private Declare Function CreateSolidBrush Lib "gdi32" _ (ByVal
crColor As Long) As Long Внимание! Для FrameRgn тоже нужен
регион! Ведь рамку можно нарисовать и на квадратном окне и
выглядеть она будет в зависимости от региона. Теперь в событие
Form_Load перед строкой Call SetWindowRgn ... вставьте строку
Call FrameRgn(hDC, Rgn, CreateSolidBrush(QBColor(0)), 3, 3)
Запускайте! [Комбинирование регионов] А ещё регионы можно
комбинировать! Нужно это правда не так часто но, когда вам
нужна форма с одной стороны полукруглая, а с другой выперающие
углы, штыри и т.д., то без комбинирования регионов Вам уже не
обойтись! Прежде чем начать введите в Genral Declarations:
Private Declare Function CombineRgn Lib "gdi32" (ByVal
hDestRgn _ As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As
Long, ByVal _ nCombineMode As Long) As Long Параметры:
hDestRgn - регион, которому возвращается полученный результат
из двух регионов hSrcRgn1 - первый регион hSrcRgn2 - второй
регион nCombineMode - методы комбинирования Сами методы (есть
ещё несколько, но эти самые основные): 'отображаются только те
точки, которые принадлежат 'одному И второму региону Const
RGN_AND = 1 'отображаются только те точки, которые принадлежат
'к хотябы одному региону Const RGN_OR = 2 'отображаются только
те точки, которые принадлежат 'ТОЛЬКО одному из двух регионов
Const RGN_XOR = 3 'отображается разница регионов, "остатки"
одного от другого Const RGN_DIFF = 4 Так, теперь можно было бы
скомбинировать регионы и для эффективности они должны быть
разные по размерам, т.к. звезда полностью умещается в форме с
закругленными углами. Поэтому исправьте строку: Rgn2 =
CreateRoundRectRgn(0, 0, Width / Screen.TwipsPerPixelX, _
Height / Screen.TwipsPerPixelY, 50, 50) на Rgn2 =
CreateRoundRectRgn(0, 0, (Width / Screen.TwipsPerPixelX) -
100, _ (Height / Screen.TwipsPerPixelY) - 100, 50, 50) Т.е.
регион был уменьшен на сто никселов. Всё, осталось теперь
только поместить следующую строку в тоже событие Form_Load, но
перед строкой Call SetWindowRgn...: Call CombineRgn(Rgn2, Rgn,
Rgn2, RGN_OR) В этом случае регион, в который будет помещён
результат мы взяли формы с круглыми углами и метод
комбинирования выбрали RGN_OR, т.е. будут отображены все
точки, которые принадлежат к хотябы одному из регионов. А
создание круглых и овальных регионов я уже рассматривал в
примере изменения контуров формы и это ещё проще.
25.
<<<<<<<<<<<<<<<<<<Полупррозрачные
окна>>>>>>>>>>>>>>>
Option Explicit
'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
Private Sub Form_load()
Dim TRANS As Long
TRANS = 10
'(10 до 255)
SetWindowLong hWnd, GWL_EXSTYLE,
GetWindowLong(hWnd, GWL_EXSTYLE) Or
WS_EX_LAYERED
SetLayeredWindowAttributes hWnd, 0, TRANS,
LWA_ALPHA
End Sub
Прога тем рульней, чем быстрее она пашет и чем меньше она
занимает.(народнопрограмистская мудрость).
Edited by - ALX_2002 on 01/12/2002 17:56:15
Edited by - ALX_2002 on 01/12/2002 21:07:24
Edited by - ALX_2002 on 03/12/2002
20:52:47
СМОТРИТЕ СКОРЕЕ ! ! ! ( САМЫЕ НУЖНЫЕ API) ! ! !
Posted - 01/12/2002 :
17:10:46 
.gif){kind=small}
.gif){kind=small}
