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 бит и т.д.

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

Top

Поместите на форму PictureBox с названием picNotifier.

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

Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206

Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MBUTTONDBLCLK = &H209
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

Использование:

Private Sub picNotifier_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Обработка событий
Static Rec As Boolean, Msg As Long
    Msg = X / Screen.TwipsPerPixelX
    If Rec = False Then ' Чтоб не повторять Запуск 
        Rec = True
        Select Case Msg
           ' Если DoubleClick
            Case WM_LBUTTONDBLCLK:
                Me.Show
           ' Если левая Кнопка нажата
            Case WM_LBUTTONDOWN:

           ' Если левая Кнопка Отжата
            Case WM_LBUTTONUP:

           ' Правая кнопка Click
            Case WM_RBUTTONDBLCLK:

           ' Если Правая Кнопка нажата
            Case WM_RBUTTONDOWN:

           ' Если Правая Кнопка Отжата
            Case WM_RBUTTONUP:
                ' Здесь вы можете вызвать PoPup-меню:
                ' PopupMenu mnuPopMenu
        End Select
        Rec = False
    End If

End Sub


' Добавить иконку формы в 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&, ""

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:\WINDOWS\SYSTEM"
nSize = GetTempPath(255, sTemp): sDir = Left(sTemp, nSize)
' sDir = "C:\WINDOWS\TEMP\"

Примечание: Последняя функция, в отличие от первых двух, возвращает путь с завершающим слэшем на конце.

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

'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, "Software\Microsoft\Windows\CurrentVersion", "RegisteredOwner")
RegSetValue HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows\CurrentVersion", "RegisteredOwner", "Darth Vader"

Примечание: Эти функции работают только с текстовыми ключами (те, что в RegEdit'e помечены символом 'ab').

Declare Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" (ByVal lpszSrc As String, ByVal lpszDst As String, ByVal cchDstLength As Long) As Long
Declare Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" (ByVal lpszSrc As String, ByVal lpszDst As String, ByVal cchDstLength As Long) As Long

Public Function ToAnsi(s As String) As String
  Dim Buffer As String
  Buffer = Space(Len(s) + 1)
  OemToCharBuff s, Buffer, Len(s)
  ToAnsi = Left(Buffer, Len(s))
End Function

Public Function ToOEM(s As String) As String
  Dim Buffer As String
  Buffer = Space(Len(s) + 1)
  CharToOemBuff s, Buffer, Len(s)
  ToOEM = Left(Buffer, Len(s))
End Function

Использование:

sAnsi = ToAnsi("Дарт Вейдер")   ' Из DOS в Windows
sDos = ToOEM("Дарт Вейдер")    ' Из Windows в Dos

Примечание: Данные функции работают корректно только на русской Windows или на корректно русифицированной паневропейской.

Option Explicit

Const INFINITE = &HFFFF
'StartupInfo constants
Public Const STARTF_FORCEOFFFEEDBACK = &H80
Public Const STARTF_FORCEONFEEDBACK = &H40
Public Const STARTF_RUNFULLSCREEN = &H20
Public Const STARTF_USECOUNTCHARS = &H8
Public Const STARTF_USEFILLATTRIBUTE = &H10
Public Const STARTF_USEPOSITION = &H4
Public Const STARTF_USESHOWWINDOW = &H1
Public Const STARTF_USESIZE = &H2
Public Const STARTF_USESTDHANDLES = &H100
'ShowWindow constants
Public Const SW_HIDE = 0
Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_MAXIMIZE = 3
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOW = 5
Public Const SW_MINIMIZE = 6
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_RESTORE = 9
Public Const SW_SHOWDEFAULT = 10

Public Type PROCESS_INFORMATION
  hProcess As Long
  hThread As Long
  dwProcessId As Long
  dwThreadId As Long
End Type

Public Type STARTUPINFO
  cb As Long
  lpReserved As String
  lpDesktop As String
  lpTitle As String
  dwX As Long
  dwY As Long
  dwXSize As Long
  dwYSize As Long
  dwXCountChars As Long
  dwYCountChars As Long
  dwFillAttribute As Long
  dwFlags As Long
  wShowWindow As Integer
  cbReserved2 As Integer
  lpReserved2 As Long
  hStdInput As Long
  hStdOutput As Long
  hStdError As Long
End Type

Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

'
Public Function RunAndWait(ComLine As String, DefaultDir As String, ShowFlag As VbAppWinStyle) As Boolean
  Dim si As STARTUPINFO
  Dim pi As PROCESS_INFORMATION
  si.wShowWindow = ShowFlag
  si.dwFlags = STARTF_USESHOWWINDOW
  If CreateProcess(vbNullString, ComLine, ByVal 0&, ByVal 0&, False, 0, ByVal 0&, DefaultDir, si, pi) Then
    WaitForSingleObject pi.hProcess, INFINITE
    CloseHandle pi.hProcess
    RunAndWait = True
    Exit Function
  End If
  RunAndWait = False
End Function

Использование:

If RunAndWait("rar.exe a regbackup system.dat user.dat", "c:\windows", vbNormalFocus) Then
  MsgBox "Registry backuped!"
End If

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_GETMINMAXINFO = &H24
Public Type POINTAPI
  x As Long
  y As Long
End Type
Public Type MINMAXINFO
  ptReserved As POINTAPI
  ptMaxSize As POINTAPI
  ptMaxPosition As POINTAPI
  ptMinTrackSize As POINTAPI
  ptMaxTrackSize As POINTAPI
End Type

Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)

Использование: Для работы данного примера вам понадобится специальный контрол, Message Hooker. Взять его можно здесь: msghoo32.zip. Бросьте его на форму и вставьте следующий код:

В Form_Load:

Msghook1.HwndHook = Me.hwnd
Msghook1.Message(WM_GETMINMAXINFO) = True

В Msghook1_Message:

Dim mmi As MINMAXINFO
CopyMem mmi, ByVal lp, Len(mmi)
mmi.ptMinTrackSize.x = 100      ' Минимальный размер по горизонтали, в пикселях
mmi.ptMinTrackSize.y = 100   ' Минимальный размер по вертикали, в пикселях
CopyMem ByVal lp, mmi, Len(mmi)

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