WinAPI Samples

11.

Получить содержимое N-й строки в Multiline Textbox

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 Const EM_LINEINDEX = &HBB
Public Const EM_LINELENGTH = &HC1
Public Const EM_GETLINE = &HC4

Public Function GetLine(hWnd As Long, Line As Long) As String
  Dim sBuf As String, nLen As Long, nIndex As Long
  nIndex = SendMessage(hWnd, EM_LINEINDEX, Line - 1, ByVal 0&)
  If nIndex < 0 Or Line <= 0 Then Exit Function
  nLen = SendMessage(hWnd, EM_LINELENGTH, nIndex, ByVal 0&)
  sBuf = Space(nLen + 1)
  Mid$(sBuf, 1, 1) = Chr$(nLen And &HFF) ' First byte is the low 8 bits
  Mid$(sBuf, 2, 1) = Chr$(nLen \ 256)    ' Second byte is the high 8 bits
  SendMessage hWnd, EM_GETLINE, Line - 1, ByVal sBuf
  GetLine = Left$(sBuf, nLen)
End Function

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

MsgBox GetLine(Text1.hWnd, 2)      ' Показывает вторую строчку (начиная с 1)

Примечание: Для работы примера у поля Text1 необходимо поставить свойство .Multiline = True.

12.

Как изменить обои (wallpapers) Windows?

Top

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.

Как сделать toolbar в стиле Office'97?

Top

Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildWindow As Long, ByVal lpClassName As String, ByVal lpsWindowName As String) As Long
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 Const WM_USER As Long = &H400
Public Const TB_SETSTYLE = WM_USER + 56
Public Const TB_GETSTYLE = WM_USER + 57
Public Const TBSTYLE_FLAT = &H800

Public Sub SetTBar97(hwnd As Long)
  Dim lTBarStyle As Long, lTBarHwnd As Long
  lTBarHwnd = FindWindowEx(hwnd, 0&, "ToolbarWindow32", vbNullString)
  lTBarStyle = SendMessage(lTBarHwnd, TB_GETSTYLE, 0&, ByVal 0&)
  lTBarStyle = lTBarStyle Or TBSTYLE_FLAT
  SendMessage lTBarHwnd, TB_SETSTYLE, 0, ByVal lTBarStyle
End Sub

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

SetTBar97 Toolbar1.hwnd
Toolbar1.Refresh

14.

Приостановить выполнение программы на определенное время

Top

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

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

Sleep 10000        ' Пауза на 10 секунд

15.

'Плавающее' окно (Always On Top)

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.

Как из программы открыть веб-страничку

Top

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.

Как нарисовать прозрачную картинку

Top

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.

Как определить наличие файла на диске

Top

Public Const OF_EXIST = &H4000
Public Const OFS_MAXPATHNAME = 128
Public Type OFSTRUCT
  cBytes As Byte
  fFixedDisk As Byte
  nErrCode As Integer
  Reserved1 As Integer
  Reserved2 As Integer
  szPathName(OFS_MAXPATHNAME) As Byte
End Type
Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long

Public Function IsFileExists(FileName As String) As Boolean
  Dim ofs As OFSTRUCT, nRes As Long
  nRes = OpenFile(FileName, ofs, OF_EXIST)
  IsFileExists = (nRes = 1)
End Function

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

bExists = IsFileExists("C:\AUTOEXEC.BAT")

19.

Как вызвать стандартное диалоговое окно Свойства системы для определённого файла/папки/диска.

Top

Declare Function ShellExecuteEX Lib "shell32.dll" _
  Alias "ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long


'  CLASSKEY перекрывает CLASSNAME
Public Const SEE_MASK_CLASSNAME = &H1
Public Const SEE_MASK_CLASSKEY = &H3

'  INVOKEIDLIST перекрывает IDLIST
Public Const SEE_MASK_IDLIST = &H4
Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_ICON = &H10
Public Const SEE_MASK_HOTKEY = &H20
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_CONNECTNETDRV = &H80
Public Const SEE_MASK_FLAG_DDEWAIT = &H100
Public Const SEE_MASK_DOENVSUBST = &H200
Public Const SEE_MASK_FLAG_NO_UI = &H400

Type SHELLEXECUTEINFO
    cbSize        As Long
    fMask         As Long
    hwnd          As Long
    lpVerb        As String
    lpFile        As String
    lpParameters  As String
    lpDirectory   As String
    nShow         As Long
    hInstApp      As Long
   ' Необязательные поля
    lpIDList      As Long
    lpClass       As String
    hkeyClass     As Long
    dwHotKey      As Long
    hIcon         As Long
    hProcess      As Long
End Type

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

  Dim SEI As SHELLEXECUTEINFO
  Dim r As Long
 ' Заполнение структуры SHELLEXECUTEINFO
 ' и вызов функции API ShellExecuteEX
  With SEI
    .cbSize = Len(SEI)
    .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
    .hwnd = Me.hwnd
    .lpVerb = "properties"      ' Показать стандартное диалоговое окно
                                ' "Свойства" Проводника Windows
    .lpFile = "C:\Мои документы"
    .lpParameters = vbNullChar
    .lpDirectory = vbNullChar
    .nShow = 0
    .hInstApp = App.hInstance '0
    .lpIDList = 0
  End With
 ' Вызов функции API
  r = ShellExecuteEX(SEI)

20.

Как определить когда появляется и изымается компакт-диск из устройства CD-ROM?

Top

Public Declare Function CallWindowProc Lib "user32" _
  Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
                           ByVal hwnd As Long, _
                           ByVal Msg As Long, _
                           ByVal wParam As Long, _
                           ByVal lParam As Long) As Long

Public Declare Function GetWindowLong Lib "user32" _
  Alias "GetWindowLongA" (ByVal hwnd As Long, _
                          ByVal nIndex As Long) As Long

Public Declare Function SetWindowLong Lib "user32" _
  Alias "SetWindowLongA" (ByVal hwnd As Long, _
                          ByVal nIndex As Long, _
                          ByVal dwNewLong As Long) As Long

Public Const GWL_WNDPROC = (-4)
Public Const WM_DEVICECHANGE = &H219

Public glngPrevWndProc As Long


 
 
Public Function MyWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  If Msg = WM_DEVICECHANGE Then
    Select Case wParam
     
     ' If device (CD-ROM) arrive...
     ' Событие возникает при появлении нового диска в CD-ROM'е.
      Case &H8000&
        Call Form1.DeviceArrival
     
     ' If CD-ROM has ejected...
     ' Событие возникает при изъятии диска из CD-ROM'а
      Case &H8004&
        Call Form1.DeviceRemoveComplete
    End Select
    MyWindowProc = 0
    Exit Function
  End If
 
 ' pass the rest messages onto VB's own Window Procedure
 ' остальные сообщения передаются для обработки стандартной
 ' процедуре окна
  MyWindowProc = CallWindowProc(glngPrevWndProc, hwnd, Msg, wParam, lParam)
End Function

Использование: Создайте форму и поместите в неё следующий код:

Private Sub Form_Load()
 ' Перенаправление сообщений Windows от формы к собственной
 ' процедуре обработки сообщений Module1.MyWindowProc
  glngPrevWndProc = GetWindowLong(hwnd, GWL_WNDPROC)
  SetWindowLong hwnd, GWL_WNDPROC, AddressOf MyWindowProc
End Sub

Private Sub Form_Unload(Cancel As Integer)
 ' Возвращение управления форме
  SetWindowLong hwnd, GWL_WNDPROC, glngPrevWndProc
End Sub

Sub DeviceArrival()
 ' Здесь вы можете поместить код, который будет выполнятся при
 ' появление компакт-диска в устройстве CD-ROM
  Label2.Caption = "Появилось устройство"
End Sub

 
Sub DeviceRemoveComplete()
 ' Здесь вы можете поместить код, который будет выполнятся при
 ' удалении компакт-диска из устройства CD-ROM
  Label2.Caption = "Устройство исчезло"
End Sub