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 

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

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