vbrus.narod.ru

Последнее обновление: 4 Ноября 2007 г.

На главную страницу
 

Полезные статьи - программирование на Visual Basic

    00. Знакомимся с историей языка Бэйсик - Visual Basic
    01. Как перезагрузить или выключить компьютер в Windows XP? - Visual Basic
    02. Узнаем путь к Windows и о функции Environ - Visual Basic
    03. Работа с файлами - Visual Basic
    04. Работа с папками - Visual Basic
    05. Как узнать имя компьютера и имя пользователя? - Visual Basic
    06. Как изменить имя компьютера? - Visual Basic
    07. Работа с числами, шрифтом, текстом, TextBox'om и RichTextBox'om - Visual Basic
    08. Интернет - Visual Basic
    09. Использование Winsock контрола - Visual Basic
    10. Как заставить Winsock работать с несколькими соединениями? - Visual Basic
    11. Узнаем свой IP адрес - Visual Basic
    12. Определение имени или IP-адреса удаленного компьютера - Visual Basic
    13. Как заполнить ComboBox всеми шрифтами, которые установленны в системе? - Visual Basic
    14. Как заполнить ComboBox буквами доступных дисков? - Visual Basic
    15. Изменение высоты ниспадающей части элемента ComboBox - Visual Basic
    16. Cкриншот экрана, формы или контрола - Visual Basic
    17. Выделить кусок картинки - Visual Basic
    18. Изменение фона рабочего стола Windows - Visual Basic
    19. Скопировать содержимое PictureBox в буфер обмена - Visual Basic
    20. Преобразование и форматирования данных (функции) - Visual Basic
    21. Программно переключить клавиатуру с русского на английский и обратно - Visual Basic
    22. Работа с системным треем - Visual Basic
    23. Как извлечь иконку из файла? - Visual Basic
    24. Как сменить курсор на "песочные часы" и обратно? - Visual Basic
    25. Как узнать количество свободной оперативной памяти? - Visual Basic
    26. Как узнать сколько процессоров в компьютере? - Visual Basic
    27. Как узнать сколько работает ваш компьютер? - Visual Basic
    28. Как управлять консолью под Visual Basic 6?
    29. Пишем трейнер на Visual Basic
    30. Зашифрованные пароли - Visual Basic
    31. Как завершить указанный процесс - Visual Basic
    32. Управление событиями в комбоксе - Visual Basic
    33. Как содержимое формы или Picture выкинуть на принтер? - Visual Basic
    34. Ошибки при замене десятичного разделителя - Visual Basic
    35. Как определить длину файла (все версии Visual Basic)
    36. Управление длиной элемента списка ComboBox - Visual Basic
    37. Увеличение и уменьшение даты с помощью клавиш [+] и [-] - Visual Basic
    38. Как перетащить элементы из одного списка в другой - Visual Basic
    39. Создание нового контекстного меню - Visual Basic
    40. Для тех, кто занимается геометрическими расчетами - Visual Basic
    41. Копирование областей памяти в DOS - Visual Basic
    42. Сортировка содержимого ListView - Visual Basic
    43. Быстрый поиск в массивах, листбоксах и комбобоксах - Visual Basic
    44. Сделать картинку светлей или темней - Visual Basic
    45. Как загрузить текст из файла в ListBox? - Visual Basic
    46. Формы в виде текста! - Visual Basic
    47. Как выполнять код пока кнопка нажата - Visual Basic
    48. КАК работать с Ресурсами, файлы ресурсов (*.RES) - Visual Basic
    49. Как узнать полный путь к программе, зная её h, именно hWnd - Visual Basic
    50. Форма сверху всех - Visual Basic
    51. Как перетаскивать окно не за заголовок - Visual Basic
    52. Как ловить нажатия на клавиши вне вашей программы - Visual Basic
    53. Форматирование и копирование дискет через функции API - Visual Basic
    54. Ярылык для загрузки последнего рабочего проекта в Visual Basic
    55. Постоянно возникающий вопрос у тех, кто пишет блокнот. Функция Command - Visual Basic
    56. Создание временных файлов - Visual Basic
    57. Быстрый поиск а базе данных - Visual Basic
    58. Заперетить юзеру закрывать форму - Visual Basic
    59. Как просто отформатировать и округлить число - Visual Basic
    60. Перевод денежных сумм из цифp в 'прописью' - Visual Basic
    61. Как запретить запуск второй копии программы - Visual Basic
    62. Работа с Дисководом. Открыть/закрыть дверцу CD/DVD-ROM. Узнать инфо о CD-ROM и.т.д.
    63. Работа с Word. Создание, открытие, форматирование, закрытие и сохранение - Visual Basic
    64. Работа с Word. Добавление текста в документ Word - Visual Basic
    65. Работа с Word. Добавление текста в документ Word (Продолжение) - Visual Basic
    66. Работа с Word. Работа с таблицами в Word (часть 1) - Visual Basic
    67. Работа с Word. Работа с таблицами в Word (часть 2) - Visual Basic
    68. Работа с Word. Работа с таблицами в Word (часть 3) - Visual Basic
    69. Сортировка методом Шелла - Visual Basic
    70. Работа с Word. Работа с графическими объектами в Word (часть 1) - Visual Basic
    71. Работа с Word. Работа с графическими объектами в Word (часть 2) - Visual Basic
    72. Использование Visual Basic 6.0 для управления внешними устройствами и приём внешней информации (температура, давление, напряжение, ток и т.п.) через LPT порт
    73. Как написать игру на Visual Basic
    74. Как расшарить программно ресурс (несколько способов) - Visual Basic
    75. Как узнать сколько памяти жрет указанный процесс? - Visual Basic
    76. Создание плагина для Winamp - Visual Basic
    77. Проигрыватель файлов AVI и WAV - Visual Basic
    78. Как защитить свою программу от взломщиков - Visual Basic
    79. Как запустить Screen saver? - Visual Basic
    80. Использование специальной клавиши клавиатуры - Visual Basic
    81. Работа с Мышью и Клавиатурой - Visual Basic
    82. Работа с десктопом/окнами - Visual Basic
    83. Как сделать форму прозрачной? - Visual Basic
    84. Как сделать сканер портов? - Visual Basic
    85. Получить список запущенных приложений/процессов - Visual Basic
    86. Коды функциональных клавиш - Visual Basic
    87. Получить описание любого файла: exe, dll или… - Visual Basic
    88. Получение списка расширений, зарегистрированных в системе файлов - Visual Basic
    89. Получение сведений о зарегистрированных типах файлов в системе - Visual Basic
    90. Запуск сервисов Панели Управления - Visual Basic
    91. Возвращение путей различных каталогов(рабочий стол, папка шрифтов, меню кнопки ПУСК и т.д) - Visual Basic
    92. Добавить ссылку или удалить все ссылки в меню Пуск>Документы - Visual Basic
    93. Получить адрес переменной в памяти - Visual Basic
    94. Получение информации о Windows, используя GetSystemInfo - Visual Basic
    95. Очистить/показать содержимое корзины - Visual Basic
    96. Как воспроизвести звук и видео - Visual Basic
    97. Проиграть Avi-файл в Picture Box - Visual Basic
    98. Поиск окна - Visual Basic
    99. Создание своего контрола - Visual Basic
    100. Как создать ActiveX Control за 21 минуту на Microsoft Visual Basic - Visual Basic
    101. WithEvents - добавление новых свойств к стандартным контролам - Visual Basic
    102. 88 советов по оптимизации приложения - Visual Basic
    103. Как проиграть MP3 из VB - Visual Basic
    104. Работа с Excel - Visual Basic
    105. Типы диаграмм VBA - Visual Basic
    106. Как сделать паузу в ВБ - Visual Basic
    107. Как программно создать Button или другой элемент управления - Visual Basic
    108. Как сделать паузу без использования API и Таймера - Visual Basic
    109. Опять запрещаем диспетчер задач :) - Visual Basic
    110. Как сделать ProgressBar с процентами? - Visual Basic
    111. Ограничить переменную до определенного количества символов - Visual Basic
    112. Узнаем имя своей программы - Visual Basic
    113. Как сделать вдавленную кнопку? - Visual Basic
    114. Как сделать название кнопки не по центру - Visual Basic
    115. Извращаемся над кнопкой пуск - Visual Basic
    116. Установить дату и время на компьютере - Visual Basic
    117. Получить список пользователей Windows - Visual Basic
    118. Полезные материалы - Visual Basic

 

11. Узнаем свой IP адрес - Visual Basic

    'Вставьте следующий код в событие формы
    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" () As Long
    Public Declare Function gethostname Lib "WSOCK32.DLL" (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

    Наверх

12. Определение имени или IP-адреса удаленного компьютера - Visual Basic

    'Добавьте модуль, и CommandButton.
    'Вначале вы должны инициализировать winsock
    WinsockInit
    'Определение имени машины, зная ее IP-адрес
    MsgBox HostByAddress("10.244.6.165")
    'Определение IP-адреса машины, зная ее имя

    MsgBox HostByName("STUART")
    'В конце работы вы должны использовать функцию WSACleanUp
    WSACleanUp

    'КОД МОДУЛЯ
    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" Alias "gethostbyname" (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

    Наверх

13. Как заполнить ComboBox всеми шрифтами, которые установленны в системе? - Visual Basic

    'киньте 1 ComboBox на форму
    Private Sub Form_Load()
    Dim I As Integer
    For I = 0 To Screen.FontCount - 1
    Combo1.AddItem Screen.Fonts(I)
    Next
    End Sub

    Наверх

14. Как заполнить ComboBox буквами доступных дисков? в VB

    Чтобы создать выпадающий список используемых и неиспользуемых дисков, поместите на форму два ComboBox с именами Combo1 и Combo2, и добавьте следующий код в инициализацию списков:

    Private Declare Function GetLogicalDrives Lib "kernel32" () As Long

    Private Sub Form_Load()
    FillCombo Combo1, True
    FillCombo Combo2, False
    End Sub

    Private Sub FillCombo(cbo As ComboBox, ByVal bUsed As Boolean)
    Dim DriveNum As Long
    cbo.Clear
    For DriveNum = 0 To 25
    If CBool(GetLogicalDrives And (2 ^ DriveNum)) = bUsed Then
    cbo.AddItem Chr$(Asc("A") + DriveNum) & ":"
    End If
    Next DriveNum
    End Sub

    Наверх

15. Изменение высоты ниспадающей части элемента ComboBox в VB

    Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Function SetComboHeight(YourCombo As ComboBox, lDropDownHeight As Long)
    Dim oldscalemode As Integer
    If TypeOf YourCombo.Parent Is Frame Then Exit Function
    oldscalemode = YourCombo.Parent.ScaleMode
    YourCombo.Parent.ScaleMode = vbPixels
    MoveWindow YourCombo.hwnd, YourCombo.Left, YourCombo.Top, YourCombo.Width, lDropDownHeight, 1
    YourCombo.Parent.ScaleMode = oldscalemode
    End Function

    Private Sub Form_Load()
    'Замените значение '100' ниже на нужную вам высоту элемента ComboBox
    SetComboHeight Combo1, 100
    End Sub

    Наверх

16. Cкриншот экрана, формы или контрола - Visual Basic

    Данный пример покажет, как можно сделать скриншот всего экрана, формы, 2 разных контрола и сохранить их изображения в файл. Расположите на форме 4 элемента CommandButton и элемент DirListBox (или любой другой контрол).
    Не забудьте проверить, чтобы папка "C:\1\" существовала.

    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    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 Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long

    Private Const CCHDEVICENAME = 32
    Private Const CCHFORMNAME = 32

    Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    End Type

    Private 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

    Public Sub Capture(control_hWnd As Long, fNAME As String, Optional OnlyToClipBoard As Boolean = False)
    On Error GoTo ErrorCapture
    Dim sp As RECT, x As Long
    If fNAME <> "" Then
    x = GetWindowRect(control_hWnd, sp)
    ScrnCap sp.Left, sp.Top, sp.Right, sp.Bottom
    If OnlyToClipBoard = False Then
    SavePicture Clipboard.GetData, fNAME
    End If
    End If
    Exit Sub
    ErrorCapture:
    MsgBox Err & ":Error in Caputre(). Error Message:" & Err.Description, vbCritical, "Warning"
    Exit Sub
    End Sub

    Private Sub ScrnCap(Lt, Top, Rt, Bot)
    On Error GoTo ErrorScrnCap
    Dim rWIDTH As Long, rHEIGHT As Long
    Dim SourceDC As Long, DestDC As Long, bHANDLE As Long, Wnd As Long
    Dim dHANDLE As Long, dm As DEVMODE
    rWIDTH = Rt - Lt
    rHEIGHT = Bot - Top
    SourceDC = CreateDC("DISPLAY", 0&, 0&, dm)
    DestDC = CreateCompatibleDC(SourceDC)
    bHANDLE = CreateCompatibleBitmap(SourceDC, rWIDTH, rHEIGHT)
    SelectObject DestDC, bHANDLE
    BitBlt DestDC, 0, 0, rWIDTH, rHEIGHT, SourceDC, Lt, Top, &HCC0020
    Wnd = 0
    OpenClipboard Wnd
    EmptyClipboard
    SetClipboardData 2, bHANDLE
    CloseClipboard
    DeleteDC DestDC
    ReleaseDC dHANDLE, SourceDC
    Exit Sub
    ErrorScrnCap:
    MsgBox Err & ":Error in ScrnCap(). Error Message:" & Err.Description, vbCritical, "Warning"
    Exit Sub
    End Sub

    Public Sub CaptureDesktop()
    On Error GoTo ErrorCaptureDesktop
    Dim dhWND As Long, sp As RECT, x As Long
    dhWND = GetDesktopWindow
    If dhWND <> 0 Then
    x = GetWindowRect(dhWND, sp)
    ScrnCap sp.Left, sp.Top, sp.Right, sp.Bottom
    End If
    Exit Sub
    ErrorCaptureDesktop:
    MsgBox Err & ":Error in CaptureDesktop. Error Message: " & Err.Description, vbCritical, "Warning"
    Exit Sub
    End Sub

    Private Sub Form_Load()
    Command1.Caption = "Экран"
    Command2.Caption = "Форма"
    Command3.Caption = "Кнопка"
    Command4.Caption = "Текстовое окно"
    End Sub

    Private Sub Command1_Click()
    On Error Resume Next
    Call CaptureDesktop
    SavePicture Clipboard.GetData, "C:\1\desktop.bmp"
    MsgBox "Картинка экрана сохранена в C:\1\desktop.bmp"
    End Sub

    Private Sub Command2_Click()
    On Error Resume Next
    Call Capture(Me.hwnd, "C:\1\form.bmp")
    MsgBox "Картинка формы сохранена в C:\1\form.bmp"
    End Sub

    Private Sub Command3_Click()
    On Error Resume Next
    Call Capture(Me.Command1.hwnd, "C:\1\button.bmp")
    MsgBox "Картинка кнопки сохранена в C:\1\button.bmp"
    End Sub

    Private Sub Command4_Click()
    On Error Resume Next
    Call Capture(Me.Dir1.hwnd, "C:\1\drv.bmp")
    MsgBox "Картинка DriveListBox сохранена в C:\1\drv.bmp"
    End Sub

    Наверх

17. Выделить кусок картинки в VB

    Добавьте PictureBox на форму.

    Dim X1 As Integer, X2 As Integer, Y1 As Integer, Y2 As Integer
    Dim SelectBox As Boolean

    Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Picture1.DrawMode = 6
    'Draw style to dots
    Picture1.DrawStyle = 2
    'Check if a Select Box is already drawn
    If X2 > 0 Then Picture1.Line (X1, Y1)-(X2, Y2), , B
    'Reset all the values to the current point
    X1 = X
    Y1 = Y
    X2 = X
    Y2 = Y
    End Sub

    Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'Проверить, нажата ли левая кнопка мыши
    If Button = 1 Then
    Picture1.Line (X1, Y1)-(X2, Y2), , B
    X2 = X
    Y2 = Y
    Picture1.Line (X1, Y1)-(X, Y), , B
    End If
    End Sub

    Наверх

18. Изменение фона рабочего стола Windows из VB

    'Добавьте к проекту Microsoft Common Dialog control
    'с именем Cdlg и одну кнопку

    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
    Const SPI_SETDESKWALLPAPER = 20
    Const SPIF_UPDATEINIFILE = &H1
    Private Sub Command1_Click()
    Cdlg.DialogTitle = "Choose a bitmap"
    Cdlg.Filter = "Windows Bitmaps (*.BMP)|*.bmp|All Files (*.*)|*.*"
    Cdlg.ShowOpen
    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, Cdlg.FileName, SPIF_UPDATEINIFILE
    End Sub

    Private Sub Form_Load()
    Command1.Caption = "Изменить Фон"
    End Sub

    Наверх

19. Скопировать содержимое PictureBox в буфер обмена - Visual Basic

    Расположите на форме элемент PictureBox и элемент CommandButton.
    Запустите проект, нажмите на кнопку.
    Затем откройте приложение Paint и нажмите сочетание клавиш Ctrl + V.

    Option Explicit
    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 GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CountClipboardFormats Lib "user32" () As Long
    Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

    Public Enum EPredefinedClipboardFormatConstants
    [_First] = 1
    CF_TEXT = 1
    CF_BITMAP = 2
    CF_METAFILEPICT = 3
    CF_SYLK = 4
    CF_DIF = 5
    CF_TIFF = 6
    CF_OEMTEXT = 7
    CF_DIB = 8
    CF_PALETTE = 9
    CF_PENDATA = 10
    CF_RIFF = 11
    CF_WAVE = 12
    CF_UNICODETEXT = 13
    CF_ENHMETAFILE = 14
    CF_HDROP = 15
    CF_LOCALE = 16
    CF_MAX = 17
    [_Last] = 17
    End Enum

    Public Function CopyEntirePictureToClipboard(ByRef objFrom As Object) As Boolean
    Dim lhDC As Long
    Dim lhBmp As Long
    Dim lhBmpOld As Long
    lhDC = CreateCompatibleDC(objFrom.hdc)
    If (lhDC <> 0) Then
    lhBmp = CreateCompatibleBitmap(objFrom.hdc, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY)
    If (lhBmp <> 0) Then
    lhBmpOld = SelectObject(lhDC, lhBmp)
    BitBlt lhDC, 0, 0, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY, objFrom.hdc, 0, 0, SRCCOPY
    SelectObject lhDC, lhBmpOld
    EmptyClipboard
    OpenClipboard 0
    SetClipboardData CF_BITMAP, lhBmp
    CloseClipboard
    End If
    DeleteObject lhDC
    CopyEntirePictureToClipboard = True
    Else
    CopyEntirePictureToClipboard = False
    End If
    End Function

    Private Sub Command1_Click()
    Call CopyEntirePictureToClipboard
    End Sub

    Наверх

20. Преобразование и форматирования данных (функции) - Visual Basic

     Функция 	   | Действия
    ----------------------------------------------------------
     Cbool    	   | преобразует выражение в тип Boolean
     ---------------------------------------------------------
     Cbyte   	   | преобразует выражение в тип Byte
     ---------------------------------------------------------
     Ccur     	   | преобразует выражение в тип Currency
     ---------------------------------------------------------
     CVdate   	   | преобразует выражение в тип Date
     ---------------------------------------------------------
     CDbl    	   | преобразует выражение в тип Double
     ---------------------------------------------------------
     Cint    	   | преобразует выражение в тип Integer
     ---------------------------------------------------------
     Clng    	   | преобразует выражение в тип Long
     ---------------------------------------------------------
     CSng     	   | преобразует выражение в тип Single
     ---------------------------------------------------------
     Cstr     	   | преобразует выражение в тип String
     ---------------------------------------------------------
     Cvar    	   | преобразует выражение в тип Variant
     ---------------------------------------------------------
     CVErr   	   | Error   
     ---------------------------------------------------------
     CDec    	   | преобразует выражение в тип данных Decimal
     --------------------------------------------------------- 
     Chr     	   | Возвращает значение типа String, 
             	   | содержащее символ, соответствующий 
             	   | указанному коду символа.
     ---------------------------------------------------------
     Hex     	   | Возвращает значение типа String, 
    		   | задающее шестнадцатеричное 
     		   | представление указанного числа.
     ---------------------------------------------------------
     Oct     	   | Возвращает значение типа Variant (String), 
             	   | содержащее восьмеричное представление 
            	   | указанного числа.
     ----------------------------------------------------------
     Str    	   | позволяет перевести числовое значение в 
            	   | строковое. Делает почти то же самое, 
            	   | что и CStr(), но при этом вставляет 
            	   | пробел впереди для положительных чисел.
     ----------------------------------------------------------
     Val      	   | Ф-ия Val используется для преобразования 
             	   |  строк, содержащих числа, в число.
     ----------------------------------------------------------
     Format            | форматирует выражение
     ----------------------------------------------------------
     FormatPercent     | форматирует выражение в процентном формате 
     ----------------------------------------------------------
     FormatCurrency    | форматирует выражение в денежном формате
     ----------------------------------------------------------
     FormatDateTime    | форматирует дату или время
     ---------------------------------------------------------- 	
     FormatNumber      | форматирует числовые выражения
     ----------------------------------------------------------	
    
     
    Примеры
    
    Преобразовать из String в Integer и записать в переменную Integer
    Dim str As String
    Dim x As Integer
    str = "1"
    x = CInt(str)
    
    Преобразовать из ASCII кода в символ
    MsgBox Chr(65) 'Возвращает A
    
    Пример использования функции CVdate
    Dim A, retval
    A="Июль 1,1990" 'выбираем дату
    MsgBox = CVDate(A) 'преобразует результат в значение типа Date
    
    Пример использования функции Hex
    MsgBox Hex(2007) 'Возвращает 7D7
    
    Пример использования функции Oct
    MsgBox Oct(8) 'возвращает 10 
    
    Пример использования функции FormatPercent
    MsgBox FormatPercent(5) 'возвращает 500,00%
    
    Пример использования функции FormatNumber   
    MsgBox FormatNumber(200) 'возвращает 200,00
       
    Пример использования функции FormatCurrency
    MsgBox FormatCurrency(200) 'возвращает 200,00 р.
             
     

    Наверх

21. Программно переключить клавиатуру с русского на английский и обратно - Visual Basic

    Расположите на форме элемент CommandButton

    Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
    Private Sub Command1_Click()
    ActivateKeyboardLayout 0, 0
    End Sub

    Наверх

22. Работа с системным треем - Visual Basic

    22.1 Как скрыть показать часы в трее? - Visual Basic
    22.2 Как скрыть системный трей вместе с часами - Visual Basic
    22.3 Добавление иконки в SystemTray средствами Visual Basic
    22.4 Расширить/уменьшить системный трей - Visual Basic


    22.1 Как скрыть показать часы в трее? - Visual Basic
    ====================================================
    'Кинье на форму 2 кнопки
    'Вот код:

    Option Explicit
    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 Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

    Dim hnd As Long
    Private Sub Command1_Click()
    ShowWindow hnd, 0
    End Sub
    Private Sub Command2_Click()
    ShowWindow hnd, 1
    End Sub

    Private Sub Form_Load()
    hnd = FindWindow("Shell_TrayWnd", vbNullString)
    hnd = FindWindowEx(hnd, 0, "TrayNotifyWnd", vbNullString)
    hnd = FindWindowEx(hnd, 0, "TrayClockWClass", vbNullString)
    Command1.Caption = "Скрыть часы"
    Command2.Caption = "Показать часы"
    End Sub

    22.2 Как скрыть системный трей вместе с часами - Visual Basic
    ====================================================

    Option Explicit
    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 Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Dim hnd As Long
    Private Sub Command1_Click()
    ShowWindow hnd, 0
    End Sub
    Private Sub Command2_Click()
    ShowWindow hnd, 1
    End Sub
    Private Sub Form_Load()
    hnd = FindWindow("Shell_TrayWnd", vbNullString)
    hnd = FindWindowEx(hnd, 0, "TrayNotifyWnd", vbNullString)
    Command1.Caption = "Скрыть"
    Command2.Caption = "Показать"
    End Sub

    22.3 Добавление иконки в SystemTray средствами Visual Basic
    ====================================================
    Автор: Кирилл Головин

    Эта статья является самодостаточной, то есть в ней дана исчерпывающая информация по созданию иконки в SystemTray с помощью VB. Однако при этом она является компиляцией общедоступных источников, то есть заслуга автора состоит лишь в сборе этой информации в одном месте и пояснениях. Основы создания иконки изложены в FAQ Льва Серебрякова. Используется пример на VB от Alexander Shherbakov. Описания функций и констант из книги Daniel Applemana и API.TXT. Вопросы связанные с редактором ресурсов не рассматриваются. Единственная функция для работы с иконкой Shell_NotifyIcon. Ее описание на VB выглядит так:
    Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _
    (ByVal dwMessage As dwMess, lpData As NOTIFYICONDATA) As Long

    Возвращает ноль в случае ошибки
    Тип dwMess описывается так:

    Public Enum dwMess

    NIM_ADD = &H0 ' Добавление иконки
    NIM_DELETE = &H2 ' Удаление иконки
    NIM_MODIFY = &H1 ' Изменение параметров иконки
    End Enum

    Переменная dwMessage должна иметь одно из этих значений.

    Тип NOTIFYICONDATA имеет следующую структуру:

    Type NOTIFYICONDATA

    cbSize As Long ' Размер переменной типа NOTIFYICONDATA
    hwnd As Long ' Указатель окна создающего иконку
    uID As Long ' Указатель на иконку в пределах приложения
    uFlags As uF ' Маска для следующих параметров
    uCallbackMessage As CallMess ' Возвращаемое событие
    hIcon As Long ' Указатель на изображение для иконки
    szTip As String * 64 ' Всплывающий над иконкой текст
    End Type


    Где тип uF имеет вид:

    Public Enum uF

    NIF_MESSAGE = &H1 ' Значение имеет uCallbackMessage
    NIF_ICON = &H2 ' Значение имеет hIcon
    NIF_TIP = &H4 ' Значение имеет szTip

    End Enum


    Эти константы можно применять в любых сочетаниях, для определения какой из параметров имеет значение.

    Тип CallMess:

    Public Enum CallMess

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


    WM_MBUTTONDOWN = &H207
    WM_MBUTTONUP = &H208
    WM_MBUTTONDBLCLK = &H209
    WM_SETFOCUS = &H7
    WM_KEYDOWN = &H100
    WM_KEYFIRST = &H100
    WM_KEYLAST = &H108
    WM_KEYUP = &H101

    End Enum


    Эти константы обозначают, какое событие возвращается вызывающей форме. Буквально, все, что будет происходить с иконкой, будет вызывать у формы одно из перечисленных событий. Ясно, что самое частое событие самой иконки это MouseMove, но для формы оно будет выглядеть как событие заданное переменной uCallbackMessage. Как же узнать, что в действительности произошло с иконкой? Это можно узнать через переменные X и Y событий MouseMove, MouseDown и MouseUp вызывающей формы. При этом Y, если событие произошло с иконкой, а не формой, всегда будет равно нулю, а X несет информацию о событии с иконкой.

    О параметре X следует сказать отдельно. Действительно, он передает информацию о событиях с иконкой, однако эти значения зависят от масштабного коэффициента системного шрифта, но не напрямую, а через параметр свойства TwipsPerPixelX объекта Screen. То есть для одной и той же системы, при разных величинах системного шрифта, значения будут разными. Начальными значениями событий являются следующие:
    MouseMove – 512
    LeftButtonDown – 513
    LeftButtonUp - 514
    LeftButtonDblClick - 515
    RightButtonDown - 516
    RightButtonUp – 517
    RightButtonDblClick - 518

    Для того чтобы узнать действующие в данной системе значения их следует умножить на Screen.TwipsPerPixelX Как же узнать, что событие произошло с иконкой, а не с формой? Просто, по значению Y, равному нулю. Но есть и другой способ, если используется двухкнопочная мышь то параметр Button в событиях MouseDown и MouseUp формы, будет принимать значения 1 и 2, и при uCallbackMessage равно WM_MBUTTONDOWN=&H207 или WM_MBUTTONUP = &H208 Button равен 4, если событие с иконкой. Само собой разумеется, что возвращаемые X значения следуют одно за другим, как и события (Down->Up->DbClick),поэтому невозможно на одну кнопку мыши назначить два события, к примеру, Click и DbClick. События не связанные с мышью не несут практически ни какой информации, и обычно не используются, следует так же отметить, что количество констант uCallbackMessage намного больше и здесь приведена лишь небольшая часть Из описанного видно, что с иконкой можно совершить одно из следующих действий: добавить, модифицировать и удалить, при этом, модифицируя можно заменить возвращаемое событие, картинку (указатель при этом останется тем же) и всплывающую надпись (ToolTips). Следующий момент, который нужно осветить это получение hIcon (указателя на картинку). Предполагается, что иконка будет находится в исполняемом файле или в DLL с ресурсами, но ни в коем случае не валяется в виде ICO файла. Если иконка запакована в DLL, то нам понадобятся две функции:

    Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal _
    lpLibFileName As String) As Long


    Возвращающая hInstance библиотеки с именем lpLibFileName. Достаточно указать только имя файла с расширением, без пути. Возвращает ноль в случае ошибки

    Declare Function LoadIconA Lib "user32" (ByVal hInstance As Long, ByVal _
    lpIconName As String) As Long


    Возвращающая hIcon для иконки указанной параметром lpIconName в библиотеке. Этот параметр может быть String или Long, в зависимости от данного вами наименования в Res файле, соответственно надо изменить декларацию. Можно передать и число как строку, для этого перед числом ставится знак #, а все это берется в кавычки. Следует заметить, что использование срокового параметра не желательно из за значительно большего размера занимаемой памяти и соответственно, большего времени на передачу параметра. Функция возвращает ноль в случае ошибки
    Понадобится так же функция:

    Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long



    Выгружающая библиотеку из памяти. Параметр hLibModule это hInstanse, возвращаемое LoadLibrary. Возвращает ноль в случае ошибки. Обязательно надо не забыть выгрузить из памяти библиотеку, для освобождения памяти. Выгрузку можно произвести сразу же после добавления иконки в SystemTray. Обязательно надо не забыть выгрузить из памяти библиотеку, для освобождения памяти. Выгрузку можно произвести сразу же после добавления иконки в SystemTray.

    Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
    (ByVal lpModuleName As String) As Long


    Возвращающей hInstanse нашего приложения. В качестве lpModuleName передается имя EXE файла с расширением. Следует быть внимательным, так как имя процесса в TaskMenager не всегда соответствует имени процесса для Windows. Я использую для определения имени DLLView, можно воспользоваться, встроенным в VB System Information. Функция возвращает действительное значение только при работе скомпилированного приложения, а в режиме отладки возвращает ноль, ведь реального процесса при отладке не существует. Свойство hInstanse объекта App всегда возвращает действительное значение, однако при отладке из за отсутствия процесса LoadIcon возвращает 0, и создается "пустая" иконка, тем не менее годная для отладки (реагирующая на все события). Полученное hInstanse передаем LoadIconA, в качестве lpIconName указываем номер или имя иконки в Res файле, как и в случае с DLL. Выгружать в этом случае ничего не надо. Создание иконки можно проиллюстрировать следующим примером. Считается, что иконка с номером 101 находится в файле Project1.exe. Понятно, что пока мы его не скомпилировали, ее там нет (да и самого файла нет). Форма приложения называется Form1.
    Dim NID As NOTIFYICONDATA
    Sub AddIcon()
    Dim IDLib As Long ' Указатель на библиотеку
    Dim IDIcon As Long ' Указатель на иконку
    Const IDMyIcon = 101 ' Идентификатор иконки внутри приложения
    Dim AddResult As Long ' Результат добавления иконки

    IDLib = GetModuleHandle("Project1.exe") ' Получаем hInstanse
    IDIcon = LoadIcon(IDLib, "#101") ' Получаем hIcon

    ' Заполняем структуру NID типа NOTIFYICONDATA

    NID.cbSize = Len(NID) ' Размер структуры
    NID.hwnd = Form1.hWnd ' Указатель на форму
    NID.uID = IDMyIcon ' Идентификатор иконки
    NID.uFlags = NIF_MESSAGE + NIF_ICON + NIF_TIP 'Указываем, что действующими являются поля
    'uCallBackMessage, hIcon и szTip.
    NID.uCallbackMessage = WM_LBUTTONDOWN ' Указываем, что событием возвращаемым в форму
    'является MouseDown с параметром Button = 2
    NID.hIcon = IDIcon ' Указатель на иконку в файле
    NID.szTip = Left$("MyIcon", 63) & Chr(0) ' Передаем всплывающую фразу "MyIcon", при этом обрезаем
    'ее до 63 символов и добавляем 64-й символ с кодом ноль
    AddResult = Shell_NotifyIcon(NIM_ADD, NID) ' Вызываем функцию, через параметр dwMessage указываем,
    'что следует добавить иконку, и передаем заполненный NID

    End Sub


    Удаление созданной иконки можно сделать так:

    Sub DeleteIcon()

    Dim DeletResult As Long
    DeleteResult = Shell_NotifyIcon(NIM_DELETE, NID) ' Вызываем функцию, через dwMessage указываем,
    'что следует удалить иконку, при этом, раз переменная NID описана на уровне модуля, не следует
    'заполнять ее заново

    End Sub


    Размер структуры достаточно указывать один раз, так как за время жизни переменной он измениться не может, и в данном виде составляет 88 байт. Даже при изменении всплывающей строки ее длина (строки) не будет больше 64 байт. Для модификации иконки надо вызвать Shell_NotifyIcon с параметром dwMessage равным NIM_MODIFY и NID с внесенными изменениями, при этом параметр uFlags будет указывать, какие из параметров изменены. В форме Form1 для обработки, к примеру, DbClick левой кнопкой мыши по иконке можно применить следующий код:

    Private Sub Form_MouseDown(Button As Integer, Shift As Integer _
    X As Single, Y As Single) ' Событие MouseDown происходит не потому,
    'что пользователь нажал на кнопку мыши над иконкой, а из-за того,
    'что параметр uCallbackMessage имеет значение WM_LBUTTONDOWN

    If Y = 0 Then ' Y = 0 если событие с иконкой
    Select Case X
    Case 515*Screen.TwipsPerPixelX ' Значение X при LeftDblClick
    ' Код, выполняемый в случае LeftDblClick
    End Select
    End If

    End Sub

    22.4 Расширить/уменьшить системный трей - Visual Basic
    ====================================================
    источник: bbs.vbstreets.ru/viewtopic.php?p=71927#71927

    Option Explicit
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
    Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
    Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
    Private Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
    Private Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
    Private Declare Function VirtualAllocEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
    Private Declare Function VirtualFreeEx Lib "kernel32" (ByVal hProcess As Long, ByVal lpAddress As Long, ByRef dwSize As Long, ByVal dwFreeType As Long) As Long
    Private Declare Function CreateRemoteThread Lib "kernel32" (ByVal hProcess As Long, lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
    Private Declare Function OpenThread Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
    Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
    Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
    Private Const PROCESS_CREATE_THREAD = &H2&
    Private Const PROCESS_VM_OPERATION = &H8&
    Private Const PROCESS_VM_WRITE = &H20&
    Private Const SYNCHRONIZE = &H100000
    Private Const MEM_RESERVE = &H2000&
    Private Const MEM_COMMIT = &H1000&
    Private Const MEM_DECOMMIT = &H4000&
    Private Const MEM_RELEASE = &H8000&
    Private Const PAGE_EXECUTE_READWRITE = &H40&

    Private Sub Form_Load()
    Dim hWnd As Long, PID As Long, hProcess As Long
    Dim pStub As Long, TID As Long, hThread As Long
    hWnd = GetDlgItem(GetDlgItem(FindWindow("Shell_TrayWnd", vbNullString), &H12F&), &H12F&)
    GetWindowThreadProcessId hWnd, PID
    hProcess = OpenProcess(PROCESS_CREATE_THREAD Or PROCESS_VM_OPERATION Or PROCESS_VM_WRITE, 0, PID)
    pStub = VirtualAllocEx(hProcess, 0, 100, MEM_RESERVE Or MEM_COMMIT, PAGE_EXECUTE_READWRITE)
    WriteProcessMemory hProcess, pStub + 4, &HB8EC8B55, 4, 0 'push ebp; mov ebp,esp; mov eax,
    WriteProcessMemory hProcess, pStub + 8, GetProcAddress(GetModuleHandle("user32"), "SetWindowLongW"), 4, 0
    WriteProcessMemory hProcess, pStub + 12, &H68, 1, 0 'push
    WriteProcessMemory hProcess, pStub + 13, pStub + 35, 4, 0
    WriteProcessMemory hProcess, pStub + 17, &H68FC6A, 3, 0 'push GWL_WNDPROC; push
    WriteProcessMemory hProcess, pStub + 20, hWnd, 4, 0
    WriteProcessMemory hProcess, pStub + 24, &HA3D0FF, 3, 0 'call eax; mov [imm32],eax
    WriteProcessMemory hProcess, pStub + 27, pStub, 4, 0
    WriteProcessMemory hProcess, pStub + 31, &H4C2C9, 4, 0 'leave; ret 4
    WriteProcessMemory hProcess, pStub + 35, &H81EC8B55, 4, 0 'push ebp; mov ebp,esp; cmp
    WriteProcessMemory hProcess, pStub + 39, &H4640C7D, 4, 0 'dword ptr [ebp+0Ch],464h
    WriteProcessMemory hProcess, pStub + 43, &H9750000, 4, 0 'jnz $+0Bh

    WriteProcessMemory hProcess, pStub + 47, &HB8, 1, 0 'mov eax,
    WriteProcessMemory hProcess, pStub + 48, &H100060, 4, 0

    WriteProcessMemory hProcess, pStub + 52, &H10C2C9, 4, 0 'leave; ret 10h
    WriteProcessMemory hProcess, pStub + 56, &HFF1475FF, 4, 0 'push dword ptr [ebp+14h]; push
    WriteProcessMemory hProcess, pStub + 60, &H75FF1075, 4, 0 'dword ptr [ebp+10h]; push dword ptr
    WriteProcessMemory hProcess, pStub + 64, &H875FF0C, 4, 0 '[ebp+0Ch]; push dword ptr [ebp+8]
    WriteProcessMemory hProcess, pStub + 68, &HA1, 1, 0 'mov eax,[imm32]
    WriteProcessMemory hProcess, pStub + 69, pStub, 4, 0
    WriteProcessMemory hProcess, pStub + 73, &HE7EBD0FF, 4, 0 'call eax; jmp $-17h

    CreateRemoteThread hProcess, ByVal 0&, 0, pStub + 4, 0, 0, TID
    hThread = OpenThread(SYNCHRONIZE, 0, TID)
    WaitForSingleObject hThread, -1
    CloseHandle hThread
    VirtualFreeEx hProcess, pStub, 100, MEM_DECOMMIT Or MEM_RESERVE
    CloseHandle hProcess
    End Sub

    '------
    'Для того чтобы регулировать размер нужно изменить вот эту строчку:

    'WriteProcessMemory hProcess, pStub + 48, &H100060, 4, 0

    'попробуйте вместо &H100060 написать &H100010 и запустить программу

    Наверх

23. Как извлечь иконку из файла? - Visual Basic

    Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex 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 Sub Command1_Click()
    Dim hIcon As Long
    Dim i As Long
    Dim n As Long
    AutoRedraw = True
    ' Получаем число иконок в файле
    n = ExtractIcon(App.hInstance, "c:\windows\system\shell32.dll", -1)
    ' Рисуем каждую иконку на форме
    For i = 0 To n - 1
    hIcon = ExtractIcon(App.hInstance, "c:\windows\system\shell32.dll", i)
    DrawIcon hdc, i * 32, 0, hIcon
    Next
    ' Освобождаем ресурсы
    DestroyIcon hIcon
    Refresh
    End Sub

    Наверх

24. Как сменить курсор на "песочные часы" и обратно? - Visual Basic

    Me.MousePointer=11
    Восстановление обычного курсора: Me.MousePointer=0

    Наверх

25. Как узнать количество свободной оперативной памяти?

    Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As TMemoryStatus)

    Private Type TMemoryStatus
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
    End Type

    Dim ms As TMemoryStatus

    Private Sub Form_Load

    ms.dwLength = Len(ms)
    Call GlobalMemoryStatus(ms)
    MsgBox "Всего:" & ms.dwTotalPhys & vbCr & "Свободно:" & ms.dwAvailPhys & vbCr & "Загружено:" & ms.dwMemoryLoad
    End Sub

    Наверх

26. Как узнать сколько процессоров в компьютере? - Visual Basic

    Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As TSystemInfo)

    Private Type TSystemInfo
    dwOemID As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    dwReserved As Long
    End Type

    Public Function NumberOfProcessors() As Long
    Dim Info As TSystemInfo
    Call GetSystemInfo(Info)
    NumberOfProcessors = Info.dwNumberOfProcessors
    End Function

    Private Sub Form_Load()
    Me.Caption = NumberOfProcessors
    End Sub

    Наверх

27. Как узнать сколько работает ваш компьютер? - Visual Basic

    Private Declare Function GetTickCount Lib "kernel32" () As Long
    Private Sub Form_Load()

    Dim a_hour, a_minute, a_second
    a = Format(GetTickCount() / 1000, "0") 'всего секунд
    a_hour = Int(a / 3600)
    a = a - a_hour * 3600
    a_minute = Int(a / 60)
    a_second = a - a_minute * 60
    MsgBox "Ваш компьютер работает в эту загрузку " & Str(a_hour) & " часов " & Str(a_minute) & " минут" & Str(a_second) & " секунд"
    End Sub

    Наверх

28. Как управлять консолью под vb6? - Visual Basic

    To : Alexander Shherbakov
    Subj : Console help!!!

    A*>> Hе знаю как сделать программу в консольном режиме, так, чтобы
    A*>> вывод на
    AS> Так консоль или не консоль? ;)

    Будет тебе палка, будет тебе и свисток.
    Кто-то постил совершенно недавно.

    module1.bas:
    Option Explicit
    Public ProcessHandle As Long
    Public ProcessID As Long

    Private Declare Function AllocConsole Lib "kernel32" () As Long
    Private Declare Function FreeConsole Lib "kernel32" () As Long
    Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
    Private Declare Function ReadConsole Lib "kernel32" Alias "ReadConsoleA" (ByVal hConsoleInput As Long, ByVal lpBuffer As String, ByVal nNumberOfCharsToRead As Long, lpNumberOfCharsRead As Long, lpReserved As Any) As Long
    Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleOutput As Long, dwMode As Long) As Long
    Private Declare Function SetConsoleTextAttribute Lib "kernel32" (ByVal hConsoleOutput As Long, ByVal wAttributes As Long) As Long
    Private Declare Function SetConsoleTitle Lib "kernel32" Alias "SetConsoleTitleA" (ByVal lpConsoleTitle As String) As Long
    Private Declare Function WriteConsole Lib "kernel32" Alias WriteConsoleA" (ByVal hConsoleOutput As Long, ByVal lpBuffer As Any, ByVal nNumberOfCharsToWrite As Long, lpNumberOfCharsWritten As Long, lpReserved As Any) As Long
    ''''C O N S T A N T S'''''''''''''''''''''''''''''''''''''
    'I/O handlers for the console window. These are much like the
    'hWnd handlers to form windows.
    Private Const STD_INPUT_HANDLE = -10&
    Private Const STD_OUTPUT_HANDLE = -11&
    Private Const STD_ERROR_HANDLE = -12&
    'Color values for SetConsoleTextAttribute.
    Private Const FOREGROUND_BLUE = &H1
    Private Const FOREGROUND_GREEN = &H2
    Private Const FOREGROUND_RED = &H4
    Private Const FOREGROUND_INTENSITY = &H8
    Private Const BACKGROUND_BLUE = &H10
    Private Const BACKGROUND_GREEN = &H20
    Private Const BACKGROUND_RED = &H40
    Private Const BACKGROUND_INTENSITY = &H80
    'For SetConsoleMode (input)
    Private Const ENABLE_LINE_INPUT = &H2
    Private Const ENABLE_ECHO_INPUT = &H4
    Private Const ENABLE_MOUSE_INPUT = &H10
    Private Const ENABLE_PROCESSED_INPUT = &H1
    Private Const ENABLE_WINDOW_INPUT = &H8
    'For SetConsoleMode (output)
    Private Const ENABLE_PROCESSED_OUTPUT = &H1
    Private Const ENABLE_WRAP_AT_EOL_OUTPUT = &H2

    Private hConsoleIn As Long ' The console's input handle
    Private hConsoleOut As Long ' The console's output handle
    Private hConsoleErr As Long ' The console's error handle

    Private Sub Main()
    Dim szUserInput As String
    AllocConsole
    'ProcessID = Shell("command.com", 1)
    ' Create a console instance
    SetConsoleTitle "VB Console Example"
    'Set the title on the console window
    'Get the console's handle
    hConsoleIn = GetStdHandle(STD_INPUT_HANDLE)
    hConsoleOut = GetStdHandle(STD_OUTPUT_HANDLE)
    hConsoleErr = GetStdHandle(STD_ERROR_HANDLE)
    'Print the prompt to the user. Use the vbCrLf to get to a new line.
    SetConsoleTextAttribute hConsoleOut, FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE Or FOREGROUND_INTENSITY Or BACKGROUND_BLUE
    ConsolePrint "VB Console Example" & vbCrLf
    SetConsoleTextAttribute hConsoleOut, FOREGROUND_RED Or FOREGROUND_GREEN Or FOREGROUND_BLUE
    ConsolePrint "Enter your name--> "
    'Get the user's name
    Call SetConsoleMode(hConsoleOut, ENABLE_PROCESSED_OUTPUT)
    szUserInput = ConsoleRead()
    If Not szUserInput = vbNullString Then
    ConsolePrint "Hello, " & szUserInput & "!" & vbCrLf
    Else
    ConsolePrint "Hello, whoever you are!" & vbCrLf
    End If
    'End the program
    ConsolePrint "Press enter to exit"
    Call ConsoleRead
    FreeConsole ' Destroy the console
    End Sub
    ' Summary: Prints the output of a string'' Args: String ConsolePrint
    ' The string to be printed to the console's ouput buffer.'' Returns: None'
    '-----------------------------------------------------
    Private Sub ConsolePrint(szOut As String)
    WriteConsole hConsoleOut, szOut, Len(szOut), vbNull, vbNull
    End Sub
    'F+F++++++++++++++++++++++++++++++++++++++++++++++++++++'
    'Function: ConsoleRead
    ' Summary: Gets a line of input from the user.'' Args: None'
    ' Returns: String ConsoleRead' The line of input from the user.
    '---------------------------------------------------F-F
    Private Function ConsoleRead() As String
    Dim sUserInput As String * 256
    Call ReadConsole(hConsoleIn, sUserInput, Len(sUserInput), vbNull, vbNull)
    'Trim off the NULL charactors and the CRLF.
    ConsoleRead = Left$(sUserInput, InStr(sUserInput, Chr$(0)) - 3)
    End Function

    Наверх

29. Пишем трейнер на Visual Basic

    До сих пор в журнале мы учили вас ломать игры и изготавливать для них трейнеры с помощью таких программ, как MTC и ему подобных. Теперь же рассмотрим более продвинутый вариант - попробуем научиться программировать трейнеры своими силами. Зачем? А затем, что трейнеры, написанные самим на любом языке программирования, имеют намного более широкие возможности. Во-первых, поскольку вы сами пишете код, то, соответственно, знаете, где там что, и получаете возможность настраивать трейнер так, как вам нужно, учитывая любые мелочи. Во-вторых, такие трейнеры занимают небольшой объем памяти. Ну а в-третьих, намного приятней юзать собственную прогу, а также показывать и дарить ее своим знакомым. Но, разумеется, надо хотя бы немного знать какой-нибудь язык программирования и разбираться в шестнадцатеричных кодах. Неважно, на каком языке писать трейнер, общий принцип будет примерно тем же. Здесь мы рассмотрим написание трейнеров на Visual Basic, так как этот язык - один из наиболее простых и его легче осваивать начинающим. Если же вы хорошо разбираетесь в программировании, то можете использовать любой другой язык. Все, что нужно, это Visual Basic, желательно не ниже 5-й версии, и программа для поиска адресов памяти. В качестве последней вполне можно использовать тот же самый Magic Trainer Creator (MTC). Также можно воспользоваться теми адресами, которые мы публикуем в "шестнадцатеричном" разделе "КОДекса".

    Windows API - функции:

    Любое Windows-приложение использует так называемые стандартные API-функции. Вначале поговорим о тех функциях, которые понадобятся при написании простейшего трейнера. О том, куда это все писать и как, будет рассказано позже.

    FindWindow (ClassName, "заголовок окна") - с помощью этой функции программа ищет окно по его заголовку. В скобках указывается класс окна и, через запятую, в кавычках его заголовок. В Visual Basic любую функцию надо "декларировать", т.е. как бы описать машине, что это функция из себя представляет. Выглядит это так: Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long. Я не буду подробно пояснять смысл этих слов, так как в этой строке менять вам все равно ничего не придется, какую бы игру вы ни взяли.

    GetWindowThreadProcessId (WindowHandle, ProcessId) - перехватывает управление из FindWindow и возвращает идентификатор процесса (ProcessId), который нужен для управления этим процессом. Это описывается так: Declare Function GetWIndowProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

    OpenProcess (DesiredAccess, Inherit, ProcessId) - эта функция возвратит управление игре. Потом это можно использовать для записи и чтения данных. DesiretAccess определяет права доступа к данным игры. Здесь мы укажем полный доступ: PROCESS_ALL_ACCESS. Inherit всегда должен иметь значение False. ProcessId устанавливается такой же как в функции, описанной в пункте 2. Описывается все это так: Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

    CloseHandle (ProcessHandle) - закрывает все открытые программой процессы. Описывается так: DeclareFunction CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

    WriteProcessMemory (ProcessHandle, Address, Value, SizeofValue, BytesWritten) - записывает значение в адрес игры. Декларируется так: Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long

    ReadProcessMemory (ProcessHandle, Address, Value, SizeofValue, BytesWritten) - читает значение из адреса игры. Описывается: Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long

    Это пока что все функции Windows, которые понадобятся. Вы можете использовать еще и другие, если знаете их и если это вам понадобится для расширения возможностей. Прочитать подробней про них можно в хелпах и в соответствующей литературе.
    Если вы ничего не поняли из сказанного выше, а под рукой не нащупывается книги по Visual Basic, то пока что продолжайте читать дальше - по ходу разберетесь.

    Простейший трейнер

    Шаг первый - поиск адреса:

    Вначале ищем адрес. Для примера возьмем игру SimCity 3000 Holiday Theme Edition. Вы можете искать адрес любой удобной для вас программой, но здесь я объясню, как искать, на примере Magic Trainer Creator (МТС). Запустим игру, затем MTC. В поле Process ID выбираем запускаемый файл игры (Sc3.exe). Выбираем режим поиска Normal, в поле Value to search вводим текущую сумму денег. Нажимаем Start. По завершении поиска (нужный адрес, скорее всего, не будет найден с первого раза) возвращаемся в игру и меняем количество денег (строим новое недорогое здание, чтобы потратить немного). Затем в MTC ставим в поле Value to search новое количество денег и нажимаем Continue. Проделываем все это несколько раз, пока не найдем один адрес. У меня этот адрес был 235B218, но у вас может быть и другой. Адрес надо будет указывать в программе сразу после знаков &H без пробелов - это указывает программе, что мы используем шестнадцатеричные значения. Выглядеть будет так: &H235B218. Теперь на всякий случай проверим, правильно ли найден адрес. Щелкаем по нему, чтобы добавить в нижнее поле, затем щелкаем по нему там. В поле Monitor нажимаем кнопку в левом верхнем углу и в появившемся окне меняем первые 2 бита на FF FF. Нажимаем кнопку в нижнем правом углу окна для возврата в основное окно MTC. В поле Monitor нажимаем среднюю нижнюю кнопку. Возвращаемся в игру и смотрим, изменилось ли количество денег. Если да, тогда выписываем найденный адрес на бумагу - он нам пригодится при создании трейнера. Конечно, здесь можно ограничиться этим и создать трейнер в MTC. Но мы-то собрались писать трейнер сами. Выходим из MTC и игры и продолжаем читать статью дальше.

    Шаг второй - написание трейнера:

    Запускайте Visual Basic. Начните новый проект и выберите Standard EXE. В окне Properties в поле Caption можете оставить свое название для заголовка окна вместо принятого по молчанию Form1. Добавьте1 Textbox, 1 Button и Timer. Выделите только что добавленное текстовое поле (Textbox) и сотрите в окне Properties в поле Text название text1 - текстовое поле нужно для записи желаемого значения. Выделите добавленный таймер (Timer) и в окне Properties в поле Interval поставьте 500 - это частота обновления значения в игре (заморозка).
    Выделите добавленную кнопку (Button), и в окне Properties в поле Caption сможете поставить свое наименование кнопки (она нужна для записи в игру набранного нами в текстовом поле трейнера значения). Выберите в меню Project опцию Add Module, чтобы добавить новый модуль в программу. В окне Project перейдите в этот модуль и наберите указанные ниже строчки. Каждая новая строка начинается со слова Declare и должна быть набрана в одну строку (здесь некоторые строчки могут быть напечатаны с переносом):

    Declare Function FindWindow Lib “user32” Alias “FindWindowA” (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Declare Function GetWindowThreadProcessId Lib “user32” (ByVal hwnd As Long, lpdwProcessId As Long) As Long
    Declare Function OpenProcess Lib “kernel32” (ByVal dwDesiredAcess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
    Declare Function WriteProcessMemory Lib “kernel32” (ByVal hProcess As Long, ByVal lpBaseAdress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
    Declare Function ReadProcessMemory Lib “kernel32” (ByVal hProcess As Long, ByVal lpBaseAddess As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWriten As Long) As Long
    Declare Function CloseHandle Lib “kernel32” (ByVal hObject As Long) As Long

    Теперь перейдите в Form1, щелкнув по ней в окне Project. Вы увидите исходный экран с образом вашего будущего трейнера. Щелкните в любом месте этого окна правой кнопкой мыши и выберите пункт View Code. Напоминаю, что адрес, который я использовал здесь и в котором хранится инфа о деньгах, был у меня 235B218, но у вас может быть и другой. А заголовок окна игры в моей версии был Sim City 3000. У вас заголовок может несколько отличаться, и узнать вы его можете, переключившись из игры по Alt+Tab - заголовок написан на кнопке свернутого окна. Теперь наберите весь написанный ниже текст программы (после знака ' следуют комментарии, которые можно и не писать):

    Private Sub Command1_Click() ' Объявляем некоторые необходимые моменты для кнопки.
    Dim hwnd As Long ' удерживает управление, переданное функцией Find Window.
    Dim pid As Long' используется для хранения идентификатора процесса.
    Dim pHandle As Long' держит управление процессом.
    ' Ищем окно игры и, если игра не запущена, выдаем сообщение об ошибке.
    hwnd = FindWindow(vbNullString, "Sim City 3000")
    If (hwnd = 0) Then
    MsgBox "Window not found!"
    Exit Sub
    End If

    ' Теперь можно определить идентификатор процесса.
    GetWindowThreadProcessId hwnd, pid
    ' Используем этот идентификатор для получения управления процессом.
    pHandle = OpenProcess(PROCESS_ALL_ACCESS, False, pid)
    If (pHandle = 0) Then
    MsgBox "Couldn't get a process handle!"
    Exit Sub
    End If
    ' Теперь можно записать новое значение в память по нужному адресу.
    WriteProcessMemory pHandle, &H235B218, "Beans", 5, 0&
    ' Прекращаем управлять процессом.
    CloseHandle hProcess
    End Sub
    Private Sub ReadTimer_Timer()
    ' Объявляем некоторые необходимые моменты для таймера.
    Dim hwnd As Long' удерживает управление, переданное функцией FindWindow.
    Dim pid As Long ' удерживает идентификатор процесса.
    Dim pHandle As Long ' удерживает управление процессом.
    Dim str As String * 20 ' параметр текстовой строки.
    ' Вначале ищем окно игры.
    hwnd = FindWindow(vbNullString, "Sim City 3000")
    If (hwnd = 0) Then Exit Sub
    ' Теперь можно определить идентификатор процесса.
    GetWindowThreadProcessId hwnd, pid
    ' Используем идентификатор для управления процессом.
    pHandle = OpenProcess(PROCESS_ALL_ACCESS, False, pid)
    If (pHandle = 0) Then Exit Sub
    ' Теперь можно прочитать из памяти...
    ReadProcessMemory pHandle, &H235B218, str, 20, 0&
    ' ... и показать строку в текстовом поле трейнера.
    txtDisplay = str
    ' Прекращаем управлять процессом.
    CloseHandle hProcess
    End Sub

    Вот вроде и все. Теперь нажмите в меню File->Make Project1.exe, чтобы создать запускаемый файл вашего трейнера. Не забудьте предварительно сохранить проект и вообще почаще сохраняйтесь в процессе написания программы, чтобы вернуться, если что, к первоначальному рабочему ее варианту. Вот теперь уже можно испытать трейнер в работе. Не забудьте, что вначале нужно запускать игру, а затем уже трейнер.
    Прочие игры ломаются аналогичным образом.

    Автор: Ivanov Ivanovich
    Наверх

30. Зашифрованные пароли - Visual Basic

    Следующие две функции легко и эффективно шифрут/дешифруют текстовый пароль. Функции имеют два аргумента: число от 1 до 10 чтобы сдвигать позицию символа ASCII в пароле, и собственно строка пароля. Функция EncryptPassword проходит через каждый символ строки DecryptedPassword, проверяет символ на четность/нечетность, и сдвигает его вверх/вниз согласно параметру Number. Эту делает зашифрованную строку нечитабельной. Зашифрованный пароль «укатывается» затем оператором XOR, который еще более запутывает строку. Я ограничил параметр Number числом 10, поскольку мне не надо делать проверку на «неправильные» символы ASCII. Функция DecryptPassword повторяет в обратном порядке процесс шифрования, применяя XOR, а затем сдвиг.
    Function EncryptPassword(Number As Byte, DecryptedPassword As String)
    Dim Password As String, Counter As Byte
    Dim Temp As Integer

    Counter = 1
    Do Until Counter = _
    Len(DecryptedPassword) + 1
    Temp = Asc(Mid(DecryptedPassword, _
    Counter, 1))
    If Counter Mod 2 = 0 Then
    'see if even
    Temp = Temp - Number
    Else
    Temp = Temp + Number
    End If
    Temp = Temp Xor (10 - Number)
    Password = Password & Chr$(Temp)
    Counter = Counter + 1
    Loop
    EncryptPassword = Password
    End Function

    Function DecryptPassword(Number As Byte, EncryptedPassword As String)
    Dim Password As String, Counter As Byte
    Dim Temp As Integer
    Counter = 1
    Do Until Counter = _
    Len(EncryptedPassword) + 1
    Temp = Asc(Mid(EncryptedPassword, _
    Counter, 1)) Xor (10 - Number)
    If Counter Mod 2 = 0 Then 'see if even
    Temp = Temp + Number
    Else
    Temp = Temp - Number
    End If
    Password = Password & Chr$(Temp)
    Counter = Counter + 1
    Loop
    DecryptPassword = Password
    End Function

    Наверх

31. Как завершить указанный процесс - Visual Basic

    В данном примере мы закрываем нашу любимую Аську(ICQlite.exe)
    Shell "Cmd /x/c taskkill /f /im ICQlite.exe", vbvhite

    Наверх

32. Управление событиями в комбоксе - Visual Basic

    Две проблемы могут приключиться, когда смущенный юзер ползает по комбобоксу при помощи мышки вверх и вниз, а затем нажатием на Enter делает свой юзерский выбор. Во-первых, нажатие на серую стрелочку вызывает два события: Change и Click. Во-вторых, нажатие на Enter перемещает фокус к следующему элементу формы, тогда как нажатие на кнопку мыши не вызывает подобного эффекта (т.е. фокус остается на комбобоксе). Поэтому, если Ваш код помещен в секцию события Change, то на стрелочки вверх/вниз (клавиатурой) вызовет это событие, чего Вы, естественно, не хотите. Напротив, если Вы помещаете свой код только в секцию события Lost Focus и юзер щелкает мышью на своем выборе, то фокус не уйдет из комбобокса, а юзер будет созерцать текст, который он выбрал своей мышью, и думать, почему это ничего не происходит. Нижеприведенное решение «фильтрует базар» событий Click, генерирующихся нажатиями на стрелочки клавиатуры, и вынуждает контрол потерять фокус.В секции Declarations формы введите следующее

    ' В VB3 надо поменять тип флага на integer
    Dim bNoise as Boolean
    ' True означает, что происходит «шум», на который не следует реагировать

    А этот код введите в секции события Form_Load:

    bNoise = False

    Этот код введите в событии KeyDown комбобокса:

    Private Sub cbTest_KeyDown(KeyCode As _
    Integer, Shift As Integer)
    ' если юзер использует стрелки для езды по списку комбобокса
    ' игнорировать события Click
    If KeyCode = vbKeyDown Or KeyCode _
    = vbKeyUp Then bNoise = True
    End Sub

    Этот код вводится в событии Click комбобокса:

    Private Sub cbTest_Click()
    If bNoise Then
    ' Ignore Noise events
    ' (up or down arrow)
    bNoise = False
    Else
    ' Увести фокус с контрола
    SendKeys "{TAB}", True
    End If
    End Sub

    Теперь Вам остается написать код, содержащий реакцию на выбор юзера, и занести его в секцию события LostFocus комбика.

    Наверх

33. Как содержимое формы или Picture выкинуть на принтер? - Visual Basic

    w=Screen.ScaleX(Picture1.Picture.Width, vbHiMetric, vbTwips)
    h=Screen.ScaleY(Picture1.Picture.Height, vbHiMetric, vbTwips)
    Printer.PaintPicture Picture1.Picture, 0, 0, w, h, 0, 0, w, h, vbSrcCopy

    Наверх

34. Ошибки при замене десятичного разделителя - Visual Basic

    Может быть кому-нибудь пригодятся результаты упражнений в связи с недавним обсуждением в эхе ошибок, возникающих из-за замены символа десятичного разделителя в данных типа Single или Double.
    Функция Val в качестве десятичного разделителя воспринимает только точку (.) :

    fV = Val("1.2") ' fV = 1.2
    fV = Val("1,2") ' fV = 1 т.е. числа после запятой не воспринимаются

    Функции конвертации с учетом типа данных (CSng, CDbl) зависят от локальных установок компьютера. Hа компьютере с локализованной (русской) версией Win'95 :

    fV = CSng("1.2") ' Run-time error 13 - Type mismatch
    fV = CSng("1,2") ' fV = 1.2

    Функция Format воспринимает только точку (.), если число передается непосредственно в функцию:

    sV = Format(1.2, "#0.00") ' sV = "1.20" sV = Format(1, 2, "#0.00") ' Run-time error 13 - Type mismatch

    Однако, если число в функцию Format передается с помощью переменной, допустима цепочка команд :

    fV = CSng("1,2")
    sV = Format(fV, "#0.00") ' sV = "1.20"

    а компьютере с американской версией Win'98 в качестве десятичного разделителя используется точка, использование запятой приводит к сообщению об ошибке или неправильному результату. Чтобы избежать ошибок, сначала надо выяснить какой символ используется на данном компьютере в качестве десятичного разделителя. Это можно сделать, например, так:

    Sub PVar_Define() ' Определить глобальные переменные, общие для проекта
    On Error GoTo ErrH

    ' ........ определение различных глобальных переменных .........
    spDS = "." ' Разделитель целой и дробной части. По умолчанию "."

    If CSng("1,2") = 1.2 Then spDS = ","

    ErrH:

    End Sub

    При чтении данных из файла можно использовать функцию типа следующей:

    ' Замена точек, используемых в качестве десятичных разделителей,
    ' на запятые (если надо)
    Public Function PointToComma(sStr As String) As String
    Dim nP As Integer

    If spDS = "," Then ' В качестве десятичного разделителя установлена запятая
    nP = InStr(sStr, ".") ' Заменим вероятные точки на запятые
    While nP > 0
    Mid(sStr, nP, 1) = ","
    nP = InStr(sStr, ".")
    Wend
    End If

    PointToComma = sStr

    End Function


    При записи данных в файл соответственно используется обратное преобразование.
    Что касается ввода данных в TextBox, то можно разрешить только ввод
    корректного на данной машине десятичного разделителя, не давая
    вводить неправильный.

    Наверх

35. Как определить длину файла (все версии Visual Basic)

    http://www.microsoft.com/Rus/Msdn/Activ/MSVB/Archive/WindowsAPI/FileSystem/118.mspx

    Наверх

36. Управление длиной элемента списка ComboBox - Visual Basic

    Элемент управления ComboBox, в отличие от текстового окна, не имеет свойства MaxLength. Однако нет ничего проще, чем добавить недостающее свойство. Для этого достаточно ввести в событие KeyPress элемента управления ComboBox следующий код:

    Private Sub Combo1_KeyPress(KeyAscii As Integer)
    '
    ' Если пользователь попытается нажать одиннадцатую клавишу и
    ' если эта клавиша не Backspace, то отменить данное событие
    '
    Const MAXLENGTH = 10
    If Len(Combo1.Text) >= MAXLENGTH And KeyAscii <> vbKeyBack Then
    KeyAscii = 0
    End If
    End Sub

    Константа MaxLength может иметь любое значение. Кроме того, вместо Backspace вы можете использовать любые другие клавиши. Для этого просто введите их значения KeyAscii, как показано в примере с клавишей Backspace.
    Наверх

37. Увеличение и уменьшение даты с помощью клавиш [+] и [-] - Visual Basic


    В некоторых программах работа с датой реализована довольно интересным образом. Нажатие клавиши [+] увеличивает дату на один день, клавиши [-] — уменьшает на один день, клавиша [PgDn] прибавляет один месяц, а клавиша [PgDn] убавляет на один месяц. Попробуем реализовать это с помощью VB.

    Вначале поместите на форму элемент управления TextBox (txtDate). Установите его свойство Text равным "", а свойство Locked — True. После этого введите следующий код в событие KeyDown:

    Private Sub txtDate_KeyDown(KeyCode As Integer, Shift As Integer)
    '
    ' KeyCode — специальный код клавиши (а не ASCII-код!)
    ' 107 = "+" KeyPad (цифровая клавиатура)
    ' 109 = "-" KeyPad
    ' 187 = "+" (в действительности это клавиша "=")
    ' 189 = "-"
    ' 33 = PageUp
    ' 34 = PageDown
    '
    Dim strYear As String
    Dim strMonth As String
    Dim strDay As String
    '
    If txtDate.Text = "" Then
    txtDate.Text = Format(Now, "d/m/yyyy")
    Exit Sub
    End If
    '
    strYear = Format(txtDate.Text, "yyyy")
    strMonth = Format(txtDate.Text, "mm")
    strDay = Format(txtDate.Text, "dd")
    '
    Select Case KeyCode
    Case 107, 187 ' добавляет один день
    txtDate.Text = Format(DateSerial(strYear, strMonth, strDay) + 1, "d/m/yyyy")
    Case 109, 189 ' убавляет на один день
    txtDate.Text = Format(DateSerial(strYear, strMonth, strDay) - 1, "d/m/yyyy")
    Case 33 ' увеличивает на один месяц
    txtDate.Text = Format(DateSerial(strYear, strMonth + 1, strDay), "d/m/yyyy")
    Case 34 ' уменьшает на один месяц txtDate.Text = Format(DateSerial(strYear, strMonth - 1, strDay), "d/m/yyyy")
    End Select
    '
    End Sub

    Этот способ коррекции даты очень полезен, так как гарантирует правильный формат даты в окне. Именно для того, чтобы избежать возможных ошибок при вводе, мы, установив свойство Locked равным True, заблокировали возможность редактировать в текстовом окне дату в явном виде.

    Наверх

38. Как перетащить элементы из одного списка в другой - Visual Basic

    Чтобы взять элементы из одного списка и поместить их в другой, создайте два списка (lstDraggedItems и lstDroppedItems) и текстовое поле (txtItem) в форме (frmTip). Поместите такой код в событие Load для формы:

    Private Sub Form_Load()
    ' Установите свойство Visible
    ' для текстового поля как False
    txtItem.Visible = False
    ' Добавьте элементы к списку 1 (lstDraggedItems)
    lstDraggedItems.AddItem "Яблоко"
    lstDraggedItems.AddItem "Апельсин"
    lstDraggedItems.AddItem "Грейпфрут"
    lstDraggedItems.AddItem "Банан"
    lstDraggedItems.AddItem "Лимон"
    End Sub

    В событии MouseDown списка lstDraggedItems напишите следующее:

    Private Sub lstDraggedItems_MouseDown _
    (Button As Integer, Shift As Integer, _
    X As Single, Y As Single)
    '
    txtItem.Text = lstDraggedItems.Text
    txtItem.Top = Y + lstDraggedItems.Top
    txtItem.Left = X + lstDraggedItems.Left
    txtItem.Drag
    End Sub

    А в событии DragDrop списка lstDroppedItems введите такой код:

    Private Sub lstDroppedItems_DragDrop _
    (Source As Control, X As Single, Y As Single)
    '
    If lstDraggedItems.ItemData _
    (lstDraggedItems.ListIndex) = 9 Then Exit Sub
    ' Убедимся, что данный элемент
    ' не будет перемещен снова
    lstDraggedItems.ItemData _
    (lstDraggedItems.ListIndex) = 9
    lstDroppedItems.AddItem txtItem.Text
    End Sub

    Теперь запустите этот тест на выполнение и попробуйте перетащить элементы из списка lstDraggedItems и поместить их в список LstDroppedItems.

    Обратите внимание, что вы не можете перемещать элементы второго списка в первый. Кроме того, перетаскиваемые элементы сохраняются в первом списке. Надеемся, вы сумеете легко устранить данные ограничения.
    Наверх

39. Создание нового контекстного меню - Visual Basic

    Следующая программа позволит вам заменить исходное контекстное меню на свое собственное. Для этого добавьте следующий код к форме или BAS-модулю:

    Private Const WM_RBUTTONDOWN = &H204
    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

    Public Sub OpenContextMenu(FormName As Form, MenuName As Menu)
    '
    ' Говорит системе, что пользователь щелкнул
    ' правой кнопкой мыши на форме
    Call SendMessage(FormName.hwnd, _
    WM_RBUTTONDOWN, 0, 0&)
    ' Показывает контекстное меню
    FormName.PopupMenu MenuName
    End Sub

    После этого с помощью редактора Visual Basic Menu Editor и приведенной здесь таблицы создайте простое меню.

    Caption_____Name_____Visible
    Контекстное меню mnuContext__No
    Первый элемент mnuContext1
    Второй элемент mnuContext2


    Обратите внимание, что два последних элемента смещены на один уровень (...) и что у первого элемента ("Контекстное меню") свойство Visible установлено как NO.

    Теперь добавьте текстовое поле к форме и введите следующий код в событие MouseDown для этого элемента управления:

    Private Sub Text1_MouseDown(Button As Integer, _
    Shift As Integer, X As Single, Y As Single)
    '
    If Button = vbRightButton Then
    Call OpenContextMenu(Me, Me.mnuContext)
    End If
    End Sub

    Наверх

40. Для тех, кто занимается геометрическими расчетами - Visual Basic

    Источник: www.visual.2000.ru

    Возможно, вам пригодятся две процедуры, которые приведены в модуле XY_TESTC.BAS (см. ниже). Они сохранились у нас еще со времен Basic/DOS, поэтому их текст и имеет такой вид (например, все ключевые слова записаны заглавными буквами). Процедура CircleTestXY определяет местоположение точки относительно фигуры-многоугольника (внутри или снаружи), CircleSquare вычисляет площадь многоугольника. Следует обратить внимание на то, что одна из вершин многоугольника задана в массиве дважды - в качестве начальной и конечной точки.

    Кстати. Раньше названия языков программирования и их ключевых слов было принято писать большими буквами. Однако в начале 90-х годов Международная Организация по Стандартам (ISO - International Standard Organization) приняла решение об изменении этого правила, С тех пор они пишутся так: первая буква - заглавная, остальные - прописные.

    DECLARE SUB CircleTestXY (xyd!(), Np%, x0!, y0!, kz%)
    DECLARE SUB CircleSquare (xyd!(), Np%, Square!)
    DEFINT I-N
    '**************************************************
    ' Модуль XY_TESTC.BAS
    '
    ' Процедуры:
    ' CircleTestXY - определение местоположения точки
    ' относительно фигуры-многоугольника
    ' CircleSquare - вычисление площади многоугольника
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''"""""""""""""""""""""""""""""""""
    ' тестовый пример использования функций
    Np = 6: DIM xyd(Np, 2) ' массив для пятиугольника
    xyp(1, 1) = 10: xyp(2, 1) = 20
    xyp(1, 2) = 0: xyp(2, 2) = 10
    xyp(1, 3) = -10: xyp(2, 3) = 20
    xyp(1, 4) = -10: xyp(2, 4) = -20
    xyp(1, 5) = 10: xyp(2, 5) = -20
    xyp(1, Np) = xyp(1, 1): xyp(2, Np) = xyp(2, 1)
    ' вычисление площади многоугольника
    CALL CircleSquare(xyp(), Np, Square)
    ' проверка - где находится заданная точка?
    x0 = 0: y0 = 0 ' координаты тестируемой точки
    CALL CircleTestXY(xyp(), Np, x0, y0, kz)
    PRINT "kz, Square = "; kz; Square
    END

    SUB CircleSquare (xyd(), Np, Square)
    ' Вычисление площади многоугольника
    '————————————————————————————————
    ' ВХОД:
    ' xyd() - массив координат углов многоугольника
    ' x = xyd(1,i), y = xyd(2,i) ; i = 1 to Np
    ' (Np-1) - количество узлов
    ' координаты 1-й точки = координатам N-й
    '
    ' ВЫХОД: Square - площадь многоугольника
    '''''''''''''''''''''''''''''''''''''''''''''''""""""""""""""""""""""""""""""""""
    CONST pi = 3.141593
    Square = 0
    FOR k = 1 TO Np ' Np + 1
    x2 = xyd(1, k): y2 = xyd(2, k)
    v2 = SQR(x2 * x2 + y2 * y2)
    ay2 = ABS(y2): ax2 = ABS(x2)
    IF ax2 * 10000 > ay2 THEN
    alfa2 = ATN(ay2 / ax2)
    ELSE alfa2 = pi * .5
    END IF
    IF x2 < 0 THEN alfa2 = pi - alfa2
    IF y2 < 0 THEN alfa2 = -alfa2
    IF k > 1 THEN ' проверка перехода
    Square = Square + .5 * SIN(alfa2 - alfa1) * v1 * v2
    END IF
    x1 = x2: y1 = y2: v1 = v2: alfa1 = alfa2
    NEXT
    END SUB

    SUB CircleTestXY (xyd(), Np, x0, y0, kz)
    '
    ' Проверка местонахождения точки на плоскости
    ' относительно многоугольника - внутри или снаружи
    '————————————————————————-
    ' ВХОД:
    ' xyd() - массив координат углов многоугольника
    ' x = xyd(1,i), y = xyd(2,i) ; i = 1 to Np
    ' (Np-1) - количество узлов
    ' координаты 1-й точки = координатам N-й точки
    ' x0,y0 - координаты тестируемой точки
    '
    ' ВЫХОД: положение тестируемой точки
    ' kz = 0 - вне
    ' = -100 - на границе
    ' = -4 - внутри (обход по часовой стрелке)
    ' = 4 - внутри (против часовой стрелки)
    ''''''''''''''''''''''''''
    kz = 0
    FOR k = 1 TO Np ' Np + 1
    ' IF l > Np THEN k = 1 ELSE k = l
    x2 = xyd(1, k) - x0: y2 = xyd(2, k) - y0
    '
    ' проверка четверти плоскости
    kv2 = 0
    IF x2 >= 0 AND y2 > 0 THEN kv2 = 1
    IF x2 < 0 AND y2 >= 0 THEN kv2 = 2
    IF x2 <= 0 AND y2 < 0 THEN kv2 = 3
    IF x2 > 0 AND y2 <= 0 THEN kv2 = 4
    IF kv2 = 0 THEN kz = -100: EXIT FOR
    '
    IF k > 1 THEN ' проверка перехода
    IF kv2 <> kv1 THEN ' переход в другую четверть
    kv = kv2 - kv1
    IF kv = 3 THEN kv = -1
    IF kv = -3 THEN kv = 1
    IF kv = 2 OR kv = -2 THEN ' переход через две четверти
    IF x1 = x2 THEN kz = -100: EXIT FOR
    yb = (y2 * x1 - y1 * x2) / (x1 - x2)
    IF yb = 0 THEN kz = -100: EXIT FOR
    kv = kv * SGN(yb)
    IF kv1 = 2 OR kv1 = 4 THEN kv = -kv
    END IF
    kz = kz + kv
    END IF
    END IF
    x1 = x2: y1 = y2: kv1 = kv2
    NEXT
    END SUB

    Наверх

41. Копирование областей памяти в DOS - Visual Basic


    Дополнительные функции DLL-библиотек могут серьезно расширить возможности VB-программиста. При этом следует иметь в виду, что для написания таких процедур зачастую совсем не обязательно быть большим знатоком языка, на котором они будут писаться.

    Например, функция копирования областей памяти пригодится и тем, кто еще работает в Basic/DOS. В силу специфики использования библиотек в этих версиях Basic (мы вновь сожалеем, что в VB/Win-проектах Microsoft не позволяет подключать к исполняемому модулю объектные библиотеки) такие внешние функции лучше всего было писать на Ассемблере. Посмотрите, какой простой код имеет функция StringCopy, написанная для варианта MASM 6.0 и фактически являющаяся точным аналогом функции CopyMemory для режима DOS (только число байтов задается целочисленной переменной):

    .MODEL Medium,Basic
    .CODE
    StringCopy PROC USES DS DI SI DF,
    SourceAddr:DWord, DestAddr:DWord, Len:Word
    ; прием входных параметров:
    MOV CX,Len ; количество байт
    LES DI,DestAddr ; полный адрес Приемника (Куда)
    LDS SI,SourAddr ; полный адрес Источника (Откуда)
    ; пересылка данных:
    CLD ; очистка флага DF
    REP MOVSB ; пересылка CX-байт
    ; выход из процедуры:
    RET ; возврат управления
    StringCopyByv ENDP
    END

    Ее описание можно сделать двумя способами:

    1. Адреса задаются с помощью двух 16-разрядных переменных — сегмент и смещение:
    описание:

    DECLARE SUB StringCopy(BYVAL SourceSeg%, BYVAL SourceOff%,_
    BYVAL DistSeg%, BYVAL DistOff%, BYVAL LenByte%)

    обращение:

    CALL StringCopyByv(SourceSeg%, SourceOff%, _
    DistSeg%, DistOff%, LenByte%)

    2. Полные адреса задаются с помощью 32-разрядных переменных: описание:

    DECLARE SUB StringCopy(BYVAL SourceAdr&, BYVAL DistAdr&, _
    BYVAL LenByte%)

    обращение:

    CALL StringCopyByv(SourceAddr&, DistAddr&, LenByte%)

    Наверх

42. Сортировка содержимого ListView

    Во многих программах, например в Outlook и Windows Explorer, можно выполнять сортировку содержимого элемента управления ListView с помощью щелчка мышью по заголовку колонки. При этом порядок сортировки меняется между вариантами "по возрастанию" и "по уменьшению". Чтобы добавить подобную функциональность в свой проект, создайте в стандартном модуле следующую процедуру:

    Public Sub SortListView(ByVal lvw As MSComctlLib.ListView, ByVal colHdr As MSComctlLib.ColumnHeader)
    ' установка режима сортировки для указанной колонки
    lvw.SortKey = colHdr.Index - 1
    lvw.Sorted = True
    ' изменение сортировки меняется между
    ' "по возрастанию" и "по уменьшению"
    lvw.SortOrder = 1 Xor lvw.SortOrder
    End Sub

    Чтобы обеспечить выполнение данной операции при щелчке мышью на заголовках, используйте событие ColumnClick для конкретного элемента управления:

    Private Sub lvwMyListView_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    SortListView lvwMyListView, ColumnHeader
    End Sub

    Наверх

43. Быстрый поиск в массивах, листбоксах и комбобоксах

    Данный метод удобен, если пользователь вводит данные, по которым потом будет осуществлять поиск. Поисковый запрос в базу данный обычно занимает доволно длительное время. Для уменьшения этого времени, можно хранить поисковую таблицу локально в отсортированном массиве, лист-боксе или комбо-боксе, у которых свойство Sorted установлено в True. Для больших отсортированных массивов строк, листбоксов или комбо-боксов с большим количеством строк (около 10,000), бинарный поиск в 10-20 раз быстрее, чем вызов API функций и в сотни раз быстрее, чем последовательный поиск. Различии скорости поиска увеличивается в несколько раз, если поиск надо сделать несколько раз. Итак, следующий код можно использовать для массива:

    'Вход:
    'Массив для поиска
    Dim rasArray() As String
    'Строка для поиска
    Dim vsName As String
    'Выход:
    'Индекс в массиве строки, если найдено
    Dim rlIndex As Long
    'Локальные переменные:
    'Индекс в массиве
    Dim lnIdx As Long
    'Нижний предел интервала поиска
    Dim lnMin As Long
    'Верхний предел интервала поиска
    Dim lnMax As Long
    'Если строка не найдена, то в индексе возвращаем ошибку
    rlIndex = LBound(rasArray) - 1
    lnMax = UBound(rasArray)

    lnMin = LBound(rasArray)
    'ищем vsName в rasArray()
    Do While lnMin <= lnMax
    lnIdx = (lnMax + lnMin) \ 2
    If vsName = rasArray(lnIdx) Then
    rlIndex = lnIdx
    Exit Do
    ElseIf vsName < rasArray(lnIdx) Then
    lnMax = lnIdx - 1
    Else
    lnMin = lnIdx + 1
    End If
    Loop
    Так же этот код можно легко переделать как для combo-box, так и для list-box:
    'Вход:
    'Combo для поиска
    ' (change into As ListBox for listbox controls
    ' or use As Controls to use with both types

    ' of controls)
    Dim rcboCombo As ComboBox
    'Строка для поиска
    Dim vsName As String
    'Выход:
    'Если строка найдена, то это индекс в combo
    Dim rlIndex As Long
    'Локальные переменные
    'Индекс в массиве
    Dim lnIdx As Long
    'Нижний предел интервала поиска
    Dim lnMin As Long
    'Верхний предел интервала поиска
    Dim lnMax As Long
    'Если строка не найдена, то в индексе возвращаем ошибку
    rlIndex = -1
    lnMin = 0
    lnMax = rcboCombo.ListCount - 1

    lnIdx = lnMax \ 2
    'ищем имя в combo
    Do While rlIndex = -1 And lnMin <= lnMax
    If vsName = rcboCombo.List(lnIdx) Then
    rlIndex = lnIdx
    ElseIf vsName < rcboCombo.List(lnIdx) Then
    lnMax = lnIdx - 1
    lnIdx = (lnMax + lnMin) \ 2
    Else
    lnMin = lnIdx + 1
    lnIdx = (lnMax + lnMin) \ 2
    End If
    Loop

    Наверх

44. Сделать картинку светлей или темней - Visual Basic

    Увеличение или уменьшение яркости PictureBox

    Private Sub LightOrDark(ByVal fraction As Single)
    Dim r As Integer, g As Integer, b As Integer
    Dim X As Integer, Y As Integer, clr As Long
    MyPic.ScaleMode = vbPixels
    For Y = 0 To MyPic.ScaleHeight
    For X = 0 To MyPic.ScaleWidth
    ' Получить цвет
    clr = MyPic.Point(X, Y)
    r = clr Mod 256
    g = (clr \ 256) Mod 256
    b = clr \ 256 \ 256
    ' Уменьшить/увеличить яркость
    r = r * fraction
    g = g * fraction
    b = b * fraction
    ' Иногда бывает < 0
    If r < 0 Then r = 0
    If g < 0 Then g = 0
    If b < 0 Then b = 0
    ' Hарисовать пиксель
    MyPic.PSet (X, Y), RGB(r, g, b)
    Next X
    DoEvents
    Next Y
    End Sub

    Private Sub Form_Click()
    Call LightOrDark(0.9)
    End Sub

    Вызов - LightOrDark 1.5 - если аргумент > 1 - засветление,< 1 - затемнение.
    Hа форме не забудь поместить пикчербокс MyPic скакой нибудь картинкой. Hо
    это ооочень долго, если много пикчуров (For Each.....Next), а еще и форма

    :((. Может, сам метод где нибудь пригодится? Так, изобласти предположений,
    попробуй накрывать свою форму прозрачной формойс черными точками или
    тонкими линиями - затемнение и белыми (м.б.желтыми?) - засветление.

    Наверх

45. Как загрузить текст из файла в ListBox? - Visual Basic

    Option Explicit

    Private Sub Form_Load()
    Dim strText As String
    Dim FileNum As Integer
    Dim FName As String
    FileNum = FreeFile

    Open App.Path & "\Text.txt" For Input As #FileNum
    Do While Not EOF(FileNum)
    Line Input #FileNum, strText
    List1.AddItem strText
    Loop
    Close #FileNum
    End Sub

    Наверх

46. Формы в виде текста! - Visual Basic

    Все прошлые разы мы пользовались простым регионом, создаваемым при помощи Create...Region, а вот теперь погляди на мощь примера, использующего Path:

    Private Declare Function SelectClipPath Lib "gdi32" _
    (ByVal hdc As Long, ByVal iMode As Long) As Long
    Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function PathToRegion Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" _
    (ByVal hWnd As Long, ByVal hRgn As Long, _
    ByVal bRedraw As Boolean) As Long

    Private Const RGN_COPY = 5

    Private Sub Form_Load()
    Const TXT = " Прикольной программы" & vbCrLf & "Прикольный пример"
    Dim hRgn As Long
    Font.Name = "Times New Roman"
    Font.Bold = True
    Font.Size = 50
    Width = TextWidth(TXT)
    Height = TextHeight(TXT)
    BeginPath hdc
    CurrentX = 0
    CurrentY = 0
    Print TXT

    ' Здесь вместо текста можно рисовать фигуры
    EndPath hdc
    hRgn = PathToRegion(hdc)
    SetWindowRgn hWnd, hRgn, False

    ' Hачинаем фантазировать с формой. Можно так
    Picture = LoadPicture("c:\windows\Кофейня.bmp")
    ' А можно так
    ' dclr = 256 / (TextHeight(TXT) / 30)
    ' clr = 0
    ' For i = 120 To 120 + TextHeight(TXT) Step 30
    ' Line (0, i)-Step(5000, 0), RGB(0, 0, clr)
    ' clr = clr + dclr
    ' Next i
    ' Можно дать форме градиентную заливку и т.д.
    ' Двигаем к центру, а можно в таймере крутить
    Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
    End Sub

    P.S. Не забудь изменит свойство BorderStyle на 0 - None. Удачи!

    Наверх

47. Как выполнять код пока кнопка нажата - Visual Basic

    Командные кнопки присутствуют в большинстве VB-проектов. Однако они регистрируют только одиночное нажатие обрабатываемое событием Click(). Часто может быть полезным позволить пользователю держать кнопку нажатой для выполнить некоторых действий много раз пока кнопка остается нажатой. Это можно сделать несколькими методами например при помощи таймера.
    Откройте или создайте стандартный проект Visual Basic. Поместите на форму объекты Label, Command Button и Timer. Щелкните правой кнопкой мыши на форме, выберите View Code и введите введите следующий код:

    Private Sub Command1_MouseDown(Button As Integer, _
    Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = True
    End Sub

    Private Sub Command1_MouseUp(Button As Integer, _
    Shift As Integer, X As Single, Y As Single)
    Timer1.Enabled = False
    End Sub

    Private Sub Form_Load()
    Timer1.Interval = 100
    End Sub

    Private Sub Timer1_Timer()
    Label1.Caption = Now
    End Sub

    Нажмите F5 для запуска проекта. Теперь нажмите и удерживайте кнопку, которую вы поместили на форму. В течении этого времени событие Timer() должно обновлять label и отображать там текущее время. После того, как вы отпустите кнопку таймер должен остановить выполнение кода.

    Наверх

48. Как работать с ресурсами, файлы ресурсов (*.RES) - Visual Basic

    Скачать более подробное руководство по созданию файл ресурсов+пример (265КБ)


    ФАЙЛ РЕСУРСОВ

    ЧТО это?
    Файл-ресурсов - это некий мульти-файл, в который могут входить данные абсолютно любого типа, будь то строковые данные или целые файлы. В проекте может находится только один файл ресурсов, но с любым количеством и типами данных в нем.

    Как создать файл-ресурс?
    1. Откройте меню Add-Ins (Модули) и выберите опцию Add-In Manager (Менеджер модулей)
    2. В открывшейся форме найдите VB6 Resource Editor, выделите его и внизу справа поставьте галочку на Loaded/Unloaded (Загруженный/Выгруженный),а так же на Load on Startup (Загружать при запуске) если вы хотите чтобы при запуске VB, Редактор ресурсов запускался автоматически, затем нажмите Ок. Если вы не нашли VB6 Resource Editor в Менеджере модулей, то смотри раздел "Секреты и полезные советы по файлу-ресурсу"
    3. Выберите меню Tools (Инструменты) и в самом низу Resource Editor
    4. Нажмите на иконку с дискетой (Save), чтобы сохранить файл ресурсов на диске, после зтого, файл-ресурс появится в составе вашего проекта.

    Как работать с файлом ресурсов?
    Как добавить данные в файл-ресурсов?
    Для добавления в файл-ресурс строковых значений, курсоров, иконок, картинок (только BMP) служат соответствующие иконки на панели инструментов VB Resource Editor: Edit String Tables, Add Cursor, Add Icon, Add Bitmap
    Если вы хотите добавить в файл ресурсов данные другого типа (файл) то используйте кнопку Add Custom Resource, на той же пнели инструментов.

    Как взять данные из файла ресурсов?


    'Загрузка текстовых данных.
    Объект = LoadResString(index)
    'Index - идентификационный номер строки
    'Объект - TextBox, Label, текстовая переменная и все остальное, куда можно загргрузить текст.

    'Загрузка графических данных
    Объект = LoadResPicture(index,format)
    'Index - идентификационный номер строки с картинкой
    'Format - тип загружаемых данных:
    'VbResBitmap - картинки
    'VbResCursor - курсоры
    'VbResIcon - иконки
    'Объект - PictureBox, Image и все остальное, куда можно загрузить графику

    Объект = LoadResData(index, format)
    'Загружает данные и возвращает байтовый массив
    'ВНИМАНИЕ!!! Используйте эту функцию ОЧЕНЬ ОСТОРОЖНО!!!
    'Так как могут возникнуть проблемы с форматом данных
    'Index - идентификационный номер строки с данными
    'Format - тип возвращаемых данных в виде байтов
    '(может быть и строкой с названием типа пользовательских данных,
    'например: LoadResData(101, "CUSTOM")):
    '1 - Курсор
    '2 - Графика
    '3 - Иконка
    '4 - Меню
    '5 - Окно диалога
    '6 - Текст
    '7 - Каталог со шрифтами
    '8 - Шрифт
    '9 - Таблица
    '10 - Пользовательские ресурсы
    '12 - Группа курсоров
    '14 - Группа иконок


    Секреты и полезные советы по файлу-ресурсу
    Как достать файл из файла-ресурса и сохранить его на диск?
    Для начала его туда нужно поместить)
    Вообще-то для загрузки данных произвольного типа служит функция LoadResData(index,format), но она возращает массив байтов, которые не есть исходный файл
    Вот функция, которая устраняет данную проблему:

    Dim i1 as Variant
    'index = идентификационный номер строки, в файле-ресурсе
    i1 = LoadResData(index, "CUSTOM")
    Open "полный путь к файлу" For Binary As #1
    For x = 0 To UBound(i1)
    Put #1, , CByte(i1(x))
    Next x
    Close #1

    Какие есть особенности при работе с файлом-ресурсов?
    # Если вы не нашли VB6 Resource Editor в Менеджере модулей, то нужно переустановить VB6.0, выбрав выборочную (CUSTOM) установку и поставив в меню выбора устанавливаемых компонентов галочку Select All (выбрать все)
    # После создания файла ресурсов картинки, тексты и т.д., которые были вставлены в файл - не нужны;
    # Не присваивайте идентификационный номер 1, т.к. VB резервирует этот номер для себя;
    # При компиляции файл ресурсов сохраняется в иполняемый файл (exe), поэтому, если вы скомпилировали программу, то вам не нужно таскать файл ресурсов оттдельно от самой программы, это может быть полезно при создании инсталляторов;

    Наверх

49. Как узнать полный к программе, зная её h, именно hWnd

    Private Const TH32CS_SNAPPROCESS As Long = 2&
    Private 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)
    Public 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
    ' Get ID for window thread
    threadID = GetWindowThreadProcessId(hwnd, processID)
    ' Check if valid
    If threadID = 0 Or processID = 0 Then Exit Function
    ' Create snapshot of current processes
    hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
    ' Check if snapshot is valid
    If hSnapshot = -1 Then Exit Function
    'Initialize uProcess with correct size
    uProcess.dwSize = Len(uProcess)
    'Start looping through processes
    rProcessFound = ProcessFirst(hSnapshot, uProcess)
    Do While rProcessFound
    If uProcess.th32ProcessID = processID Then
    'Found it, now get name of exefile
    i = InStr(1, uProcess.szexeFile, Chr(0))
    If i > 0 Then szExename = Left$(uProcess.szexeFile, i - 1)
    Exit Do
    Else
    'Wrong ID, so continue looping
    rProcessFound = ProcessNext(hSnapshot, uProcess)
    End If Loop
    Call CloseHandle(hSnapshot)
    GetExeFromHandle = szExename
    End Function

    Private Sub Form_Load()
    Me.Caption = GetExeFromHandle(Me.hWnd)
    End Sub

    Наверх

50. Форма сверху всех - Visual Basic

    ажмите кнопку "always on top", чтобы делать эту форму ВСЕГДА выше любой другой формы или приложения. (При щелчке кнопки, пробуйте перетащить другую форму или приложение на верх этой формы. Они будут всегда "падать" позади этой формы)

    Эта подпрограмма хороша для создания "плавающих" поддонов значка, и т.д. Между прочим, если Вы любите Visual Basic, и Вы не имеете verions 2.0 все же, Вы должны получить это. Это верно удивительно!

    Модуль:
    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
    Global Const HWND_TOPMOST = -1
    Global Const HWND_NOTOPMOST = -2
    Global Const SWP_NOACTIVATE = &H10
    Global Const SWP_SHOWWINDOW = &H40

    Наверху всех:
    SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW
    Цифры в функции: X, Y, ширина, высота

    Не наверху:
    SetWindowPos Me.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW


    Еще один вариант:
    ====================

    ' Declaration of a Windows routine.
    ' This statement should be placed in the module.
    Declare Function SetWindowPos Lib "user32" Alias_ "SetWindowPos" (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
    ' Set some constant values (from WIN32API.TXT).
    Const conHwndTopmost = -1
    Const conHwndNoTopmost = -2
    Const conSwpNoActivate = &H10
    Const conSwpShowWindow = &H40

    Private Sub mnuTopmost_Click ()
    ' Add or remove the check mark from the menu.
    mnuTopmost.Checked = Not mnuTopmost.Checked
    If mnuTopmost.Checked Then
    ' Turn on the TopMost attribute.
    SetWindowPos hWnd, conHwndTopmost, 0, 0, 0, 0,_ conSwpNoActivate Or conSwpShowWindow
    Else
    ' Turn off the TopMost attribute.
    SetWindowPos hWnd, conHwndNoTopmost, 0, 0, 0,_ 0, conSwpNoActivate Or conSwpShowWindow
    End If
    End Sub

    Наверх

51. Как перетаскивать окно не за заголовок - Visual Basic

    Перемещение окна при помощи API Windows

    Private Const WM_NCLBUTTONDOWN = &HA1
    Private Const LP_HT_CAPTION = 2
    Private Declare Function ReleaseCapture Lib "user32" () As Long
    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 Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim rc As Long
    rc = ReleaseCapture
    rc = SendMessage(hWnd, WM_NCLBUTTONDOWN, LP_HT_CAPTION, ByVal 0&)
    End Sub

    И ВСЁ!!!
    Наверх

52. Как ловить нажатия на клавиши вне вашей программы - Visual Basic

    1. Положите на форму таймер, поставьте интервал в 50
    2. Добавьте в модуль:

    Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

    Public Const VK_TAB = &H9 ' Константа для TAB key.
    ' константы для других кнопок посмотрите в API вьювере
    ' Поместите в событие Timer:
    If GetAsyncKeyState(VK_TAB) And KEY_SHIFT = True Then
    msgboх "Кто то трогает ТАБ", vbinformation
    End If

    Наверх

53. Форматирование и копирование дискет через функции API - VB

    В Win32 API есть парочка функций, позволяющих форматировать и копировать дискеты из программы:

    Private Declare Function SHFormatDrive
    _ Lib "shell32" (ByVal hwnd As Long, _
    ByVal Drive As Long, _
    ByVal fmtID As Long, _
    ByVal options As Long) As Long
    Private Declare Function GetDriveType _
    Lib "kernel32" _
    Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long

    Добавьте две command buttons в форму, назовите их cmdDiskCopy и cmdFormatDrive, и засуньте в их события Click следующие фрагменты кода:

    Private Sub cmdDiskCopy_Click()
    ' DiskCopyRunDll требует два параметра - From и To
    Dim DriveLetter$, DriveNumber&, _
    DriveType&
    Dim RetVal&, RetFromMsg&
    DriveLetter = UCase(Drive1.Drive)
    DriveNumber = (Asc(DriveLetter) - _
    65)
    DriveType = GetDriveType_
    (DriveLetter)
    If DriveType = 2 Then 'Floppies, _
    etc
    RetVal = Shell_
    ("rundll32.exe " & _
    "diskcopy.dll," _
    & "DiskCopyRunDll " & _
    DriveNumber & "," & _
    DriveNumber, 1)
    Else ' Just in case
    RetFromMsg = MsgBox_
    ("Only floppies can be " & _
    "copied", 64, _
    "DiskCopy Example")
    End If
    End Sub

    Private Sub cmdFormatDrive_Click()
    Dim DriveLetter$, DriveNumber&, _
    DriveType&
    Dim RetVal&, RetFromMsg% DriveLetter = UCase(Drive1.Drive)
    DriveNumber = (Asc(DriveLetter) - _
    65)
    ' Заменить букву на цифру: A=0
    DriveType = GetDriveType_
    (DriveLetter)
    If DriveType = 2 Then _
    ' т.е. флоп
    RetVal = SHFormatDrive(Me.hwnd, _
    DriveNumber, 0&, 0&)
    Else
    RetFromMsg = MsgBox_
    ("This drive is NOT a " & _
    "removeable drive! " & _
    "Format this drive?", _
    276, "SHFormatDrive Example")
    If RetFromMsg = 6 Then
    ' Раскомментируйте и увидите...
    'RetVal = SHFormatDrive_
    (Me.hwnd, _
    ' DriveNumber, 0&, 0&)
    End If
    End If
    End Sub


    Добавьте контрол DriveListBox под именем Drive1:

    Private Sub Drive1_Change()
    Dim DriveLetter$, DriveNumber&, _
    DriveType&
    DriveLetter = UCase(Drive1.Drive)
    DriveNumber = (Asc(DriveLetter) - _
    65)
    DriveType = GetDriveType_
    (DriveLetter) If DriveType <> 2 Then _
    'Floppies, etc
    cmdDiskCopy.Enabled = False
    Else
    cmdDiskCopy.Enabled = True
    End If
    End Sub

    Будьте осторожны: так недолго и винт запороть.
    Наверх

54. Ярылык для загрузки последнего рабочего проекта в Visual Basic

    Часто я стартую VB и возобновляю работу с последним проектом, но мне не хочется загромождать desktop иконками для текущих работ. В качестве решения я предлагаю мою прогу, которую нужно скомпилировать и запустить на Вашем desktopе. Эту прогу можно применить и к другим, использующим INI файлы.

    Option Explicit
    Declare Function GetPrivateProfile String Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

    Public Sub Main()
    Dim temp As String, rVal$, tmp As Long
    rVal$ = String$(256, 0)
    tmp = GetPrivateProfileString ("Visual Basic", "vb32location", "", rVal$, ByVal Len(rVal$) - 1, "c:\windows\vb.ini")
    temp = Left$(rVal$, tmp)
    rVal$ = String$(256, 0)
    tmp = GetPrivateProfileString ("Visual Basic", "RecentFile1", "", rVal$, ByVal Len(rVal$) - 1, "c:\windows\vb.ini")
    temp = temp & " """ & Left$(rVal$, tmp) & """"
    Shell temp, 1
    End
    End Sub

    Наверх

55. Постоянно возникающий вопрос у тех, кто пишет блокнот. Функция Command - Visual Basic

    Вопрос,
    допустим я сделал блокнот, и мне нужно чтобы когда я открывал например TXT файл с помощью 2ой кнопки мыши, Открыть с помощью...
    и после того как я указал в окне выбора программ, свою программу чтобы когда я нажал на кнопку ОК, не просто тупо октрылася моя программа,
    а чтобы в текстовом поле этой программы появился путь к этому файл.

    Ответ
    Используй функцию Command

    Пример
    Кинь на форму 1 TextBox и в загрузку формы, помести код:

    Text1.text = Command

    теперь скомпилируй программу
    и открой какойнибудь файл указав на свою программу)
    при загрузке программы в переменную Command записывается путь того файла который ты открыл через свою прогу


    Наверх

56. Создание временных файлов

    Я пишу прогу с базами данных, использующую много вспомогательных файлов в одно и то же время. При программировании баз данных можно создавать временные файлы для, например, вывода результата инструкции SQL или из временной базы данных, чтобы более эффективно работать с записями. Я написал функцию FileAux, возварщающую имя временного файла. Если мне надо создать несколько временных файлов одновременно, я сохраняю их имена в заранее определенных переменных:

    Function FileAux(Ext As String) As String
    Dim i As Long, X As String
    If InStr(Ext, ".") = 0 Then
    Ext = "." + Ext
    End If
    ' Ищем уже имеющиеся файлы на винте
    i = 0
    Do
    X = "Aux" + Format$(i, "0000") + Ext
    If FileExists(X) Then
    i = i + 1
    Else
    Exit Do
    End If
    Loop
    FileAux = X
    End Function

    'Эта функция обращается к функции FileExists:

    Function FileExist(filename As String) As Boolean
    FileExist = Dir$(filename) <> ""
    End Function

    А вот пример использования:

    Sub Test()
    Dim File1 As String, File2 As String, File3 As String
    Dim DB1 As database, DB2 As DataBase
    Dim FileNum As Integer
    File1 = FileAux("MDB")
    Set DB1 = CreateDataBase(File1)
    File2 = FileAux("MDB")
    Set DB2 = CreateDataBase(File2)
    File3 = FileAux("TXT")
    FileNum = FreeFile
    Open File3 For OutPut As FileNum
    ' Ваш код
    ' ...
    Close FileNum
    End Sub

    Наверх

57. Быстрый поиск в базе данных - Visual Basic

    В VB нет встроенной процедуры типа DLookUp из Аксесса. Вы можете использовать нижеприведенный код для получения Name объекта по его ID:
    Public Function MyDLookUp(Column As _
    String, TableName As String, _
    Condition As String) As Variant
    Dim Rec As Recordset
    On Error GoTo MyDlookUp_Err

    ' gCurBase - глобальная переменая, указывающая на текущкю БД
    Set Rec = gCurBase.OpenRecordset_
    ("Select * From " & TableName)
    Rec.FindFirst Condition
    If Not Rec.NoMatch Then
    ' возвращает искомое поле, если найдено
    MyDLookUp = Rec(Column)
    Exit Function
    End If

    ' возврат, если не найдено, или произошла другая ошибка
    MyDlookUp_Err:
    MyDLookUp = -1
    End Function

    Наверх

58. Заперетить юзеру закрывать форму - Visual Basic

    Если выставить свойство ControlBox на форме в False, то кнопки Minimize и Maximize тоже исчезнут. Предположим, что Вы хотите тем не менее давать возможность юзеру использовать кнопки Minimize и Maximize, но при этом чтобы он не мог закрыть форму кнопкой с крестиком. Добавьте следующий код в событие Query_Unload:

    ' если у Вас VB3, раскомментируйте следующую строку
    ' Const vbFormControlMenu = 0
    Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    If UnloadMode = vbFormControl Menu Then
    Cancel = True
    End If
    End Sub

    Наверх

59. Как просто отформатировать и округлить число - Visual Basic

    Пример округления с заданной точностью.

    n = 12.345
    Format(n, "0.00\0")
    ' возвращает "12.350"
    Format(n, "0.\0\0")
    ' возвращает "12.00"
    Format(0.55, "#.0\0") ' возвращает ".60"

    Наверх

60. Перевод денежных сумм из цифp в 'прописью' - Visual Basic

    У нас работает в Access и Excel

    Function Сумма_прописью(s@) As String
    Static triad(4) As Integer, numb1(0 To 19) As String, numb2(0 To 9) As String, numb3(0 To 9) As String
    If s@ = 0 Then
    Сумма_прописью = ""
    Exit Function
    End If
    ss@ = s@
    triad(1) = ss@ - Int(ss@ / 1000) * 1000
    ss@ = Int(ss@ / 1000)
    triad(2) = ss@ - Int(ss@ / 1000) * 1000
    ss@ = Int(ss@ / 1000)
    triad(3) = ss@ - Int(ss@ / 1000) * 1000
    ss@ = Int(ss@ / 1000)
    triad(4) = ss@ - Int(ss@ / 1000) * 1000
    ss@ = Int(ss@ / 1000)
    numb1(0) = ""
    numb1(1) = "один "
    numb1(2) = "два "
    numb1(3) = "три "
    numb1(4) = "четыре "
    numb1(5) = "пять "
    numb1(6) = "шесть "
    numb1(7) = "семь "
    numb1(8) = "восемь "
    numb1(9) = "девять "
    numb1(10) = "десять "
    numb1(11) = "одиннадцать "
    numb1(12) = "двенадцать "
    numb1(13) = "тринадцать "
    numb1(14) = "четырнадцать "
    numb1(15) = "пятнадцать "
    numb1(16) = "шестнадцать "
    numb1(17) = "семнадцать "
    numb1(18) = "восемнадцать "
    numb1(19) = "девятнадцать "
    numb2(0) = ""
    numb2(1) = ""
    numb2(2) = "двадцать "
    numb2(3) = "тридцать "
    numb2(4) = "сорок "
    numb2(5) = "пятьдесят "
    numb2(6) = "шестьдесят "
    numb2(7) = "семьдесят "
    numb2(8) = "восемьдесят "
    numb2(9) = "девяносто "
    numb3(0) = ""
    numb3(1) = "сто "
    numb3(2) = "двести "
    numb3(3) = "триста "
    numb3(4) = "четыреста "
    numb3(5) = "пятьсот "
    numb3(6) = "шестьсот "
    numb3(7) = "семьсот "
    numb3(8) = "восемьсот "
    numb3(9) = "девятьсот "
    txt$ = ""
    If ss@ <> 0 Then
    n% = MsgBox("Сумма выходит за границы формата", 16, "Сумма прописью")
    Сумма_прописью = ""
    Exit Function
    End If
    For i% = 4 To 1 Step -1
    n% = 0
    If triad(i%) > 0 Then
    n% = Int(triad(i%) / 100)
    txt$ = txt$ & numb3(n%)
    n% = Int((triad(i%) - n% * 100) / 10)
    txt$ = txt$ & numb2(n%)
    If n% < 2 Then
    n% = triad(i%) - (Int(triad(i%) / 10) - n%) * 10
    Else
    n% = triad(i%) - Int(triad(i%) / 10) * 10
    End If
    Select Case n%
    Case 1
    If i% = 2 Then txt$ = txt$ & "одна " Else txt$ = txt$ & "один "
    Case 2
    If i% = 2 Then txt$ = txt$ & "две " Else txt$ = txt$ & "два"
    Case Else
    txt$ = txt$ & numb1(n%)
    End Select
    Select Case i%
    Case 2
    If n% = 0 Or n% > 4 Then
    txt$ = txt$ + "тысяч "
    Else
    If n% = 1 Then txt$ = txt$ + "тысяча " Else txt$ = txt$ + "тысячи "
    End If
    Case 3 If n% = 0 Or n% > 4 Then
    txt$ = txt$ + "миллионов "
    Else
    If n% = 1 Then txt$ = txt$ + "миллион " Else txt$ = txt$ + "миллиона "
    End If
    Case 4
    If n% = 0 Or n% > 4 Then
    txt$ = txt$ + "миллиардов "
    Else
    If n% = 1 Then txt$ = txt$ + "миллиард " Else txt$ = txt$ + "миллиарда "
    End If
    End Select
    End If
    Next i%
    If n% = 0 Or n% > 4 Then
    txt$ = txt$ + "рублей"
    Else
    If n% = 1 Then txt$ = txt$ + "рубль" Else txt$ = txt$ + "рубля"
    End If
    txt$ = UCase$(Left$(txt$, 1)) & Mid$(txt$, 2)
    Сумма_прописью = txt$
    End Function

    Наверх

61. Как запретить запуск второй копии программы - Visual Basic

    'Добавьте этот код в загрузку формы:

    If App.PrevInstance Then End

    Наверх

62. Открыть/закрыть дверцу CD/DVD-ROM

    62.1 Открыть/закрыть дверцу CD/DVD-ROM - Visual Basic
    62.2 Открытие и закрытие нескольких CD-ROM ’ов - Visual Basic
    62.3 Информация о CD-ROM - Visual Basic


    62.1 Открыть/закрыть дверцу CD/DVD-ROM
    ===================================================

    ' Открыть дверцу CD-ROM
    mciSendString "Set CDAudio Door Open Wait", 0&, 0&, 0&

    ' Закрыть дверцу CD-ROM
    mciSendString "Set CDAudio Door Closed Wait", 0&, 0&, 0&


    62.2 Открытие и закрытие нескольких CD-ROM ’ов
    ===================================================

    Private Declare Function mciSendString Lib "winmm.dll" Alias _
    "mciSendStringA" (ByVal lpstrCommand As String, ByVal _
    lpstrReturnString As String, ByVal uReturnLength As _
    Long, ByVal hwndCallback As Long) As Long

    Private Sub OpenCloseDoor(strDriveLetter As String, Optional blnDoOpen As Boolean = True)
    Dim AliasName$, strOpenClose$
    strOpenClose = IIf(blnDoOpen, "Open", "Closed")
    AliasName = "Laufwerk" & strDriveLetter
    mciSendString "Open " & strDriveLetter & ": Alias " & AliasName & " Type CDAudio", 0, 0, 0
    mciSendString "Set " & AliasName & " Door " & strOpenClose, 0, 0, 0
    End Sub

    Private Sub Command1_Click()
    OpenCloseDoor "d:\" 'Открываем
    End Sub

    Private Sub Command2_Click()
    OpenCloseDoor "d:\", False 'Закрываем
    End Sub

    'Источник: http://bit.pirit.info/

    62.3 Информация о CD-ROM - Visual Basic
    ===================================================

    Dim WMI, str, ColCD, CD
    set WMI=getobject("Winmgmts:")
    str=str & "CD-ПРИВОДЫ:" & VBCRLF
    Set ColCD=WMI.execquery("select * from Win32_CDROMDrive")
    str=str & "Количество: " & ColCD.count & vbcrlf
    For Each CD In ColCD
    str=str & "Диск (" & CD.MediaType & ") " & CD.Drive & vbcrlf
    str=str & CD.caption & vbcrlf
    Next

    Источник: http://www.cyberforum.ru/
    Наверх

63. Работа с Word - Создание, открытие, форматирование, закрытие и сохранение

    Автор: Назаров Валерий

    Источник: www.vbstreets.ru

    Использование Word в приложениях на Visual Basic 6 открывает широчайшие возможности для создания профессионально оформленных документов (например отчетов). Это часто необходимо при работе в фирме или на предприятии для обеспечения документооборота. Основным преимуществом использования Wordа в этом случае является то, что практически на всех компьютерах, используемых в фирмах и на предприятиях установлены Windows и пакет Microsoft Office. Поэтому подготовленные документы Word не требуют каких-либо дополнительных усилий для их просмотра, печати и редактирования. Единственное что нужно помнить, это то что работа через автоматизацию OLE (связывание и внедрение объектов) на деле оказывается довольно медленной технологией, хотя и очень полезной.
    Чтобы использовать объекты Word в Visual Basic , необходимо инсталлировать сам Word. После этого вы получаете в своё распоряжение библиотеку Microsoft Word Object Library, которую нужно подключить к текущему проекту через диалоговое окно "Разработать">>"Ссылки" (References) и указать Microsoft Word 9.0 Object Library (для Word 2000). Два самых важных объекта Word это Word.Application и Word.Document. Они обеспечивают доступ к экземпляру приложения и документам Word. Поэтому в раздел Generals "Общее" формы введите следующий код для объявления объектных переменных приложения Word и документа Word.

    Dim WordApp As Word.Application ' экземпляр приложения
    Dim DocWord As Word.Document' экземпляр документа


    Чтобы создать новый экземпляр Word, введите такой код кнопки;

    Private Sub Комманда1_Click()

    'создаём новый экземпляр Word-a
    Set WordApp = New Word.Application

    'определяем видимость Word-a по True - видимый,
    'по False - не видимый (работает только ядро)
    WordApp.Visible = True

    'создаём новый документ в Word-e
    Set DocWord = WordApp.Documents.Add

    '// если нужно открыть имеющийся документ, то пишем такой код
    'Set DocWord = WordApp.Documents.Open("C:\DDD.doc")

    'активируем его
    DocWord.Activate

    End Sub


    Для форматирования печатной области документа используйте данный код:
    (вообще-то Word использует для всех размеров своих элементов пункты, поэтому для использования других единиц измерения, необходимо использовать встроенные функции форматирования.)
    Например:
    CentimetersToPoints(Х.ХХ) - переводит сантиметры в пункты.
    MillimetersToPoints(X.XX) - переводит миллиметры в пункты

    Private Sub Комманда2_Click()

    'отступ слева "2,0 сантиметра"
    DocWord.Application.Selection.PageSetup.LeftMargin = CentimetersToPoints(2)

    'отступ справа "1,5 сантиметра"
    DocWord.Application.Selection.PageSetup.RightMargin = CentimetersToPoints(1.5)

    'отступ сверху "3,5 сантиметра"
    DocWord.Application.Selection.PageSetup.TopMargin = CentimetersToPoints(3.5)
    'отступ снизу "4,45 сантиметра"
    DocWord.Application.Selection.PageSetup.BottomMargin = CentimetersToPoints(4.45)

    End Sub


    Небольшое отступление.
    Для того чтобы в своём приложении не писать постоянно одно и тоже имя объекта, можно использовать оператор With. Например код находящейся выше можно переписать так:

    With DocWord.Application.Selection.PageSetup
    .LeftMargin = CentimetersToPoints(2)
    .RightMargin = CentimetersToPoints(1.5)
    .TopMargin = CentimetersToPoints(3.5)
    .BottomMargin = CentimetersToPoints(4.45)
    End With


    Если вам необходимо создать документ Word с нестандартным размером листа, то используйте данный код:

    With DocWord.Application.Selection.PageSetup
    .PageWidth = CentimetersToPoints(20) 'ширина листа (20 см)
    .PageHeight = CentimetersToPoints(25) 'высота листа (25 см)
    End With


    Данный код меняет ориентацию страницы (практически меняет местами значения ширины и высоты листа):

    DocWord.Application.Selection.PageSetup.Orientation = wdOrientLandscape

    wdOrientLandscape - альбомная ориентация ( число 1)
    wdOrientPortrait - книжная ориентация ( число 0)

    Для сохранения документа под новым именем и в определенное место
    используйте данный код код:

    'сохраняем документ как
    DocWord.SaveAs "c:\DDD.doc"


    После такого сохранения вы можете про ходу работы с документом сохранять его.

    'сохраняем документ
    DocWord.Save


    Или проверить, были ли сохранены внесенные изменения свойством Saved и если изменения не были сохранены - сохранить их;

    If DocWord.Saved=False Then DocWord.Save


    Завершив работу с документом, вы можете закрыть сам документ методом Close и сам Word методом Quit.

    'закрываем документ (без запроса на сохранение)
    DocWord.Close True

    'закрываем Word (без запроса на сохранение)
    WordApp.Quit True

    'уничтожаем обьект - документ
    Set DocWord = Nothing

    'уничтожаем обьект - Word
    Set WordApp = Nothing


    Если в методах Close и Quit не использовать необязательный параметр True то Word запросит согласие пользователя (если документ не был перед этим сохранён) на закрытие документа. Если вам необходимо оставить Word открытым, просто не используйте методы Close и Quit. Если вам необходимо поставить пароль на документ, то используйте код:

    DocWord.Protect wdAllowOnlyComments, , "123456789"
    Наверх

64. Работа с Word - Добавление текста в документ Word - VB

    Источник: www.vbstreets.ru

    В этом примере описываются основные приёмы последовательного добавления текста в документ Word. Для правильного использования данных приёмов нужно представлять принцип построения документа Word. Основным принципом структуры текста в Word-е можно назвать то, что текст делится на параграфы. Сам текст не привязан к какому-либо конкретному месту листа, как это происходит в SCADa системах. В Word-е можно в конкретное место листа (по каким-либо координатам ) вставить графические элементы (линии, прямоугольники, рисунки и т.д.), а текст не является жесткой структурой. Весь текст в документе вводится последовательно и так или иначе связан между собой. Вы можете, например, изменить размер части текста и при этом тот текст который находится ниже изменит своё положение на листе. Весь текст в документе разбит на параграфы, когда вы при работе в Word и нажимаете , вы начинаете с новой строки, то есть начинаете новый параграф. При последовательном добавлении (программно) текста, он вводится в место расположения курсора. В новом документе с самого начала области печати, а в открытом (программно) документе текст добавляется к существующему тексту (по умолчанию), если вы не принимаете специальных мер. Нужно обязательно помнить, что следующий вводимый текст или параграф будет печататься с теми же параметрами, что были заданы предыдущему тексту. Поэтому внимательно следите за тем, что вы вводите.


    Ввод нового текста

    Перед этим вы должны создать или открыть документ Word, как это было описано в первой статье. Я лично предпочитаю создавать новый документ, ведь при этом вы можете, не зависимо от установок на конкретном компьютере, делать документ, параметры которого целиком задаёте вы. При добавлении текста он выделяется и если вам необходимо вводить последующий текст с новыми параметрами, вы должны снять выделение с предыдущего текста.

    Добавляем текст к концу предыдущего.

    'печатаем какой то текст (при этом он выделен)
    DocWord.Application.Selection.InsertAfter "Первая строка текста (синий, 12 пт,"
    DocWord.Application.Selection.InsertAfter " Tahoma, полужирный)"

    'делаем выделенный текст полужирным "Font.Bold=True"
    DocWord.Application.Selection.Font.Bold = True

    'делаем выделенный текст синим
    DocWord.Application.Selection.Font.Color = wdColorBlue

    'делаем выделенный текст размером 12 пунктов
    DocWord.Application.Selection.Font.Size = 12

    'делаем текст шрифтом "Tahoma"
    DocWord.Application.Selection.Font.Name = "Tahoma"

    'снимаем выделение с текста
    DocWord.Application.Selection.EndOf



    Данная строка кода добавляет параграф ниже существующего

    'начинаем с новой строки, то есть новый параграф (при этом параметры
    'текста как в предыдущей строке)
    DocWord.Application.Selection.InsertParagraphAfter


    Печатаем новый параграф.

    With DocWord.Application.Selection
    'печатаем какой то текст (при этом он выделен)
    'и используем Tab для отступа
    .InsertAfter vbTab & "Вторая строка текста с отступом (обычный"
    .InsertAfter ", черный, 14 пт, Arial)"
    'текст напечатался с параметрами текста в
    'предыдущем параграфе, поэтому
    'вводим новые параметры
    'делаем выделенный текст простым "Font.Bold= False"
    .Font.Bold = False
    'делаем выделенный текст черным
    .Font.Color = wdColorBlack
    'делаем выделенный текст размером 14 пунктов
    .Font.Size = 14
    'делаем текст шрифтом "Arial"
    .Font.Name = "Arial"
    'снимаем выделение с текста
    .EndOf
    'начинаем с новой строки, то есть новый параграф
    '(при этом параметры текста как в предыдущей строке)
    .InsertParagraphAfter
    'делаем строку промежуток
    .InsertParagraphAfter
    End With



    Печатаем текст различными стилями


    With DocWord.Application.Selection
    'печатаем текст (при этом он выделен)
    'и используем Tab для отступа
    .InsertAfter vbTab & "Простой текст, "
    'делаем выделенный текст простым "Font.Bold= False"
    .Font.Bold = False
    'делаем выделенный текст черным
    .Font.Color = wdColorBlack
    'делаем выделенный текст размером 14 пунктов
    .Font.Size = 14
    'делаем текст шрифтом "Arial"
    .Font.Name = "Arial"
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "полужирный текст, "
    'делаем выделенный текст полужирным "Font.Bold=True"
    .Font.Bold = True
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "текст курсив, "
    'делаем текст обычным (выше был полужирный)
    .Font.Bold = False
    'делаем текст курсивом
    .Font.Italic = True
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "полужирный курсив, "
    'делаем текст полужирным
    .Font.Bold = True
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "подчеркнутый текст, "
    'делаем текст простым (отключаем Bold, Italic)
    .Font.Bold = False
    .Font.Italic = False
    'делаем текст с подчеркиванием (выбирая разные константы
    'делаем перечеркнутый,двойное подчеркивание и т.д.)
    .Font.Underline = wdUnderlineSingle
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "окончание стилей."
    'делаем текст простым (отключаем подчеркивание)
    .Font.Underline = wdUnderlineNone
    'снимаем выделение с текста
    .EndOf
    End With

    Наверх

65. Работа с Word - Добавление текста в документ Word (Продолжение)l

    Автор: Назаров Валерий
    Источник: www.vbstreets.ru


    Вместо инструкции .Application вы можете использовать .ActiveWindow.



    Печатаем надстрочный и подстрочный текст


    With DocWord.ActiveWindow.Selection
    'делаем текст простым "Font.Bold= False"
    .Font.Bold = False
    'делаем выделенный текст черным
    .Font.Color = wdColorBlack
    'делаем выделенный текст размером 14 пунктов
    .Font.Size = 14
    'делаем текст шрифтом "Arial"
    .Font.Name = "Arial"

    'начинаем с новой строки, то есть новый параграф
    .InsertParagraphAfter
    'делаем строку промежуток
    .InsertParagraphAfter
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "Обычный текст"
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "подстрочный текст"
    'делаем его подстрочным "нижний индекс"
    .Font.Subscript = True
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "обычный текст"
    'делаем его обычным
    .Font.Subscript = False
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "надстрочный текст"
    'делаем его надстрочным "верхний индекс"
    .Font.Superscript = True
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "обычный текст"
    'делаем его обычным
    .Font.Superscript = False
    'снимаем выделение с текста
    .EndOf

    End With



    Выравнивание текста:


    With DocWord.ActiveWindow.Selection
    'делаем текст простым "Font.Bold= False"
    '.Font.Bold = False
    'делаем выделенный текст черным
    '.Font.Color = wdColorBlack
    'делаем выделенный текст размером 14 пунктов
    '.Font.Size = 14
    'делаем текст шрифтом "Arial"
    '.Font.Name = "Arial"

    'начинаем с новой строки, то есть новый параграф
    .InsertParagraphAfter
    'делаем строку промежуток
    .InsertParagraphAfter
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "Обычный текст с выравниванием по центру."
    'форматируем текст
    'по центру "wdAlignParagraphCenter"=1
    .ParagraphFormat.Alignment = 1

    'начинаем с новой строки, то есть новый параграф
    .InsertParagraphAfter
    'делаем строку промежуток
    .InsertParagraphAfter
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "Обычный текст с выравниванием по правому краю."
    'форматируем текст
    'по правому краю "wdAlignParagraphRight"=2
    .ParagraphFormat.Alignment = 2

    'начинаем с новой строки, то есть новый параграф
    .InsertParagraphAfter
    'делаем строку промежуток
    .InsertParagraphAfter
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "Обычный текст с выравниванием по ширине. "
    .InsertAfter "Обычный текст с выравниванием по ширине."
    'форматируем текст
    'по ширине "wdAlignParagraphJustify"=3
    .ParagraphFormat.Alignment = 3

    начинаем с новой строки, то есть новый параграф
    .InsertParagraphAfter
    'делаем строку промежуток
    .InsertParagraphAfter
    'снимаем выделение с текста
    .EndOf
    'печатаем текст
    .InsertAfter "Обычный текст с выравниванием по левому краю."
    'форматируем текст
    ' по левому краю "wdAlignParagraphLeft"=0
    .ParagraphFormat.Alignment = 0

    начинаем с новой строки, то есть новый параграф
    .InsertParagraphAfter
    'делаем строку промежуток
    .InsertParagraphAfter
    'снимаем выделение с текста
    .EndOf
    End With



    Междустрочный интервал


    With DocWord.ActiveWindow.Selection
    'начинаем с новой строки
    .InsertParagraphAfter
    .InsertParagraphAfter
    'печатаем какой то текст
    .InsertAfter "полуторный интервал полуторный интервал полуторный интервал."
    'снимаем выделение с текста
    .EndOf
    'начинаем с новой строки
    .InsertParagraphAfter
    .InsertParagraphAfter
    'полуторный интервал (в параграфе выше)
    .ParagraphFormat.Space15
    'печатаем какой то текст
    .InsertAfter "обычный интервал обычный интервал обычный интервал "
    'снимаем выделение с текста
    .EndOf
    'начинаем с новой строки
    .InsertParagraphAfter
    .InsertParagraphAfter
    'обычный интервал (в параграфе выше)
    .ParagraphFormat.Space1
    'печатаем какой то текст
    .InsertAfter "двойной интервал двойной интервал двойной интервал."
    'снимаем выделение с текста
    DocWord.ActiveWindow.Selection.EndOf
    'двойной интервал (в параграфе выше)
    DocWord.Application.Selection.ParagraphFormat.Space2
    'снимаем выделение с текста
    .EndOf
    End With

    Наверх

66. Работа с Word - Работа с таблицами в Word (часть 1)

    Автор: Назаров Валерий


    При создании документов в Word рано или поздно возникает необходимость в каких-либо методах форматирования данных, вводимых в документ. Можно конечно использовать Tab-ы в параграфах или всё время новые строки, но это не решение всех проблем. Хорошим решением этой проблемы являются таблицы. Работа с таблицами в Word очень напоминает работу с книгой в Exsel, методы практически одни и те же.

    Перейдём к практике.
    Основным элементом для работы с таблицами является коллекция Tables. Также как и все объекты Word, данную коллекцию нужно сначала объявить, а потом инициализировать. В данной статье не рассматриваются вопросы доступа к существующим таблицам, мы создаём новые и работаем с ними. Рассмотрим это на примере.


    'объявляем объектную переменную в разделе
    ' Generals формы
    Dim TableWord As Word.Table


    Инициализируем коллекцию Tables и создаём новую таблицу. При этом нужно сразу определиться, какая таблица вам необходима, сколько в ней должно быть строк и столбцов, а также где она будет находиться. Если использовать первый код, то новая таблица перекроет весь текст который был в документе ("удалит" его). Если вы уже добавили текст в документ, то используйте второй код. Он вставит таблицу туда, где находится в данный момент "мигающий" курсор.

    Код №1

    'создаём таблицу 10 строк, 2 столбца
    'во всю ширину области печати текста
    Set TableWord = DocWord.Tables.Add(DocWord.Range(), 10, 2)


    Код №2

    'создаём таблицу 10 строк, 2 столбца
    'во всю ширину области печати текста
    Set TableWord = DocWord.Tables.Add(DocWord.Application.Selection.Range, 10, 2)


    После этого мы можем добавлять текст в ячейки таблицы используя метод Cell.

    'печатаем текст в ячейке с адресом
    '(номер_строки, номер_столбца)
    TableWord.Cell(1, 1).Range.Text = "Первая ячейка"
    TableWord.Cell(2, 1).Range.Text = "Вторая ячейка"


    Небольшое отступление. Вы можете данную инструкцию использовать и для получения текста из ячейки:

    Dim strText As String
    'получаем текст из ячейки
    strText= TableWord.Cell(1, 1).Range.Text



    Следующий этап программирования - задаём высоту строк в данной таблице. Имеется возможность задавать высоту строк для конкретной строки или для всех сразу. Изменение высоты всех строк используйте сразу после создании таблицы, иначе, если вы по ходу программы для конкретных строк задали разные высоты, все ваши труды пропадут. При этом и учитывайте то, что если текст больше вместимости ячейки, а вы не задали опцию "не изменять размер ячейки", текст раздвинет её высоту (и ширину) до необходимых для себя размеров и естественно увеличит высоту всей строки.

    'делаем все строки высотой 24 пт
    'если нужно в других единицах измерения, то
    'используем функции перевода: например (CentimetersToPoints(Х.ХХ))
    TableWord.Rows.Height = 24
    'делаем определённую строку (5-тую) высотой 2 см
    TableWord.Rows(5).Height = CentimetersToPoints(2)


    Продолжаем форматирование таблицы - изменяем ширину столбцов.
    Внимательно следите за общей шириной таблицы, чтобы её ширина не превысила ширину области печати. Иначе ваша таблица "уползёт" за границы листа. Также как высота строк, ширина столбцов может задаваться для конкретных столбцов по отдельности или всех столбцов сразу, со всеми вытекающими последствиями.

    'делаем все столбцы шириной 5 см
    TableWord.Columns.Width = CentimetersToPoints(5)

    'делаем 1-вый столбец шириной 3 см
    TableWord.Columns(1).Width = CentimetersToPoints(3)


    По ходу выполнения программы вы можете изменять местоположение таблицы. При этом текст будет "обтекать" таблицу (по умолчанию). Помните, что позиция таблицы задается от левой и верхней границ места вставки.

    'изменяем положение таблицы по вертикали
    TableWord.Rows.VerticalPosition = CentimetersToPoints(5)

    ''изменяем положение таблицы по горизонтали
    TableWord.Rows.HorizontalPosition = CentimetersToPoints(1.5)


    Для того чтобы эффективно работать с таблицей, нужно знать количество строк и столбцов, а также ячеек в таблице (особенно это касается тех таблиц, которые уже есть в документе, если вы работаете не с новым экземпляром Word-а, а с уже существующим). Для этого OLE automation предоставляет свойство Count (количество). Это свойство позволяет узнать количество строк, столбцов, ячеек в таблице, а также количество самих таблиц в документе (а также количество слов, параграфов "абзацев" и т.д).

    Для получения количества строк в данной таблице воспользуемся коллекцией Rows.

    'получаем количество строк в таблице
    TableWord.Cell(2, 2).Range.Text = "Строк - " & TableWord.Rows.Count


    Для получения количества столбцов в данной таблице воспользуемся коллекцией Columns.

    'получаем количество столбцов в таблице
    TableWord.Cell(3, 2).Range.Text = "Столбцов - " & TableWord.Columns.Count



    А для получения количества ячеек в данной таблице воспользуемся коллекцией Cells.

    'получаем количество ячеек в таблице
    TableWord.Cell(3, 2).Range.Text = "Ячеек - " & TableWord.Range.Cells.Count


    Коллекции Columns, Rows и Cells позволяют получить доступ к своим элементам через индекс. Например TableWord.Range.Cells(1).Text получит текст из первой ячейки. Однако помните, что обращение к несуществующему индексу вызовет ошибку времени исполнения. Поэтому перед обращением к коллекции через индекс проверьте, не выходит ли он за допустимый диапазон свойством .Count и не забудьте добавить в начало код обработчика ошибок. После этого вы можете использовать циклы для обработки каждого элемента коллекции.

    Для получения количества таблиц в документе воспользуемся коллекцией Tables.

    'получаем количество таблиц в документе
    TableWord.Cell(4, 2).Range.Text = "Таблиц - " & DocWord.Tables.Count


    После этого вы можете получить доступ к любой таблице в данном документе, то есть ко всем её элементам также как мы это делали выше (с небольшим изменением конечно).

    'печатаем текст в ячейке с адресом
    '(номер_строки, номер_столбца)
    DocWord.Tables(1).Cell(5, 2).Range.Text = "Привет"

    Наверх

67. Работа с Word - Работа с таблицами в Word (часть 2)

    Автор: Валерий Назаров


    При работе с таблицами часто возникает необходимость изменить вид ячеек, объединить их между собой. Это позволяет визуально распределить вводимую информацию в таблице, а также улучшить внешний вид в целом (естественно при продуманном применении данной возможности).

    Однако нужно помнить и о "подводных камнях" при использовании данного кода в программировании. Основное что нужно помнить, это то что при объединении ячеек одна ячейка как бы "поглащает" другую ячейку (или ячейки). При этом не только изменится общее количество ячеек (уменьшится), но и "поглащенные" ячейки как бы перестанут существовать. Поэтому при обращении к "поглащенной" ячейке произойдёт ошибка. Например: при объединении ячейки 1,2 с ячейкой 1,1 останется ячейка 1,1 , а ячейка 1,2 перестанет существовать. При объединении ячеек 1,1; 2,1; 3,1 в итоге останется только ячейка 1,1.


    'объеденяем ячейку 1,1 с ячейкой 1,2
    TableWord.Cell(1, 1).Merge TableWord.Cell(2, 1)

    'объеденяем ячейку 4,2 с ячейкой 4,1
    TableWord.Cell(4, 2).Merge TableWord.Cell(4, 1)


    По умолчанию (при создании таблицы) толщина линий, разделяющая ячейки, строки и столбцы одинакова, и зависит от настроек Word-a. Для изменения толщины линий вы можете воспользоваться данным кодом:

    'делаем верхнюю линию (границу) ячейки толщиной 6 пт
    TableWord.Cell(5, 1).Borders(wdBorderTop).LineWidth = wdLineWidth600pt

    'делаем слева линию (границу) ячейки толщиной 3 пт
    TableWord.Cell(6, 1).Borders(wdBorderLeft).LineWidth = wdLineWidth300pt

    'делаем нижнюю линию (границу) ячейки толщиной 2,25 пт
    TableWord.Cell(7, 1).Borders(wdBorderBottom).LineWidth = wdLineWidth225pt

    'делаем справа линию (границу) ячейки толщиной 3 пт
    TableWord.Cell(8, 1).Borders(wdBorderRight).LineWidth = wdLineWidth300pt


    В ходе работы с таблицей вам может понадобиться разукрасить линии разным цветом для придания более красочного вида таблице. Для этого вы можете воспользоваться разными программными кодами.

    В первом примере кода мы используем встроенные константы для определения цвета линии. Синтаксис можно вольно перевести так: <объект_ТАБЛИЦА>.<ЯЧЕЙКА>(номер_строки, номер_столбца).<ГРАНИЦЫ>(верхняя_граница).<ЦВЕТ> = <константа_ЦВЕТ_СИНИЙ> После знака равно вы можете подставить любую встроенную цветовую константу VB.

    'делаем цвет верхней линии (границы) ячейки синим
    TableWord.Cell(9, 1).Borders(wdBorderTop).Color = wdColorBlue


    Если среди встроенных цветовых констант вам не удалось найти нужного вам цвета, то вы всегда можете воспользоваться функцией RGB и задать необходимый вам цвет в цифровом коде.

    'делаем цвет верхней линии (границы) ячейки произвольным
    TableWord.Cell(10, 1).Borders(wdBorderTop).Color = RGB(100, 200, 50)


    Кроме толщины и цвета линий вы можете оформить таблицу разными стилями линий. В Word встроено множество стилей оформления линий. Рассмотрим большинство из них (вы всегда можете поэкспериментировать с другими константами).

    'изменим стиль линий используя разные константы
    TableWord.Cell(6, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDashDotDot
    TableWord.Cell(7, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDashDotStroked
    TableWord.Cell(8, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDashLargeGap
    TableWord.Cell(9, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDashSmallGap
    TableWord.Cell(10, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDot
    TableWord.Cell(11, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDouble
    TableWord.Cell(12, 2).Borders(wdBorderTop).LineStyle = wdLineStyleDoubleWavy
    TableWord.Cell(13, 2).Borders(wdBorderTop).LineStyle = wdLineStyleEmboss3D
    TableWord.Cell(14, 2).Borders(wdBorderTop).LineStyle = wdLineStyleEngrave3D
    'Невидимая при печати линия
    TableWord.Cell(15, 2).Borders(wdBorderTop).LineStyle = wdLineStyleNone
    TableWord.Cell(16, 2).Borders(wdBorderTop).LineStyle = wdLineStyleSingleWavy
    TableWord.Cell(17, 2).Borders(wdBorderTop).LineStyle = wdLineStyleThickThinLargeGap
    TableWord.Cell(18, 2).Borders(wdBorderTop).LineStyle = wdLineStyleThickThinMedGap
    TableWord.Cell(19, 2).Borders(wdBorderTop).LineStyle = wdLineStyleThickThinSmallGap
    TableWord.Cell(20, 2).Borders(wdBorderTop).LineStyle = wdLineStyleTriple


    После того как вы измените стиль линии, вы можете изменять цвет и толщину, как это было показано в коде выше.

    При работе с таблицами, уже после её создания вам может не хватить строк, столбцов или ячеек для ввода информации. Тогда вам будет необходимо динамически добавить нужное количество элементов в таблицу. В принципе это не сложно, за исключением некоторых оговорок. Напрямую объект Tables не поддерживает динамическое добавление элементов. Но от лома нет приёма, если нет другого лома. Поэтому добавлять элементы к таблице мы будем через другие объекты. Смысл этого приёма состоит в том, что объекты Word.Application и его "дочерний объект " Word.Document позволяют производить такие действия над своими потомками, которые сами эти объекты не поддерживают. Мы должны для начала выбрать необходимый нам для работы элемент "дочернего" объекта, а уже после этого произвести необходимые действия через объект - "родитель". Но необходимо помнить и о "подводных камнях" данного приёма. Конкретно для таблиц это значит, что как я уже упоминал выше, при объединении строк происходит "поглощение" ячеек. Из этого следует, что если вы попытаетесь выбрать столбец или строку которые содержат "поглощённые" ячейки, то вызовете ошибку. Если вы выберете ячейку ("нормальную"), то вы избежите предыдущую ошибку, но так как добавляемые столбцы и строки наследуют свойства строки и столбца родителя вы получите результат, который вам не понравиться. Ведь столбец потомок наследует объединенную строку и её формат, при этом ячейка "вылезет" за границы таблицы. Из этого следует, что желательно добавлять такие строки и столбцы, родители которых не имеют объединенных ячеек, строк и столбцов. Перейдём к коду.

    'Выделяем (выбираем) 1-ю строку
    'TableWord.Rows(1).Select
    'Выделяем (выбираем) 1-й столбец
    'TableWord.Columns(1).Select

    'Выделяем (выбираем) ячейку
    TableWord.Cell(20, 2).Select

    'добавляем столбец справа от выбранного
    DocWord.Application.Selection.InsertColumnsRight
    'или WordApp.Selection.InsertColumnsRight

    'добавляем столбец слева от выбранного
    DocWord.Application.Selection.InsertColumns
    'или WordApp.Selection.InsertColumns

    'Выделяем (выбираем) ячейку
    TableWord.Cell(20, 2).Select

    'добавляем строку выше (как параметр можно указать сколько строк вставить)
    DocWord.Application.Selection.InsertRowsAbove 2

    'добавляем строку ниже (как параметр можно указать сколько строк вставить)
    DocWord.Application.Selection.InsertRowsBelow 2

    'Выделяем (выбираем) ячейку
    TableWord.Cell(24, 2).Select

    'вставим ячейку (c применением параметров)
    ' 3 - вставить целый столбец
    ' 2 - вставить целую строку
    ' 1 - вставить со смещением вниз
    ' 0 - вставить со смещением вправо
    DocWord.Application.Selection.InsertCells (3)
    Наверх

68. Как запретить запуск второй копии программы

    Автор: Валерий Назаров


    В предыдущей статье были рассмотрены способы динамического добавления строк и столбцов. Но вам может понадобиться и обратная операция, удаление. Поэтому рассмотрим данный код:


    'Удаляем 3-й столбец
    TableWord.Columns(3).Delete

    'Удаляем 20-ю строку
    TableWord.Rows(20).Delete

    'Удаляем ячейку
    TableWord.Cell(19, 1).Delete


    Для оформления внешнего вида таблицы в Word-e часто используется заливка ячеек цветом. Мы тоже не обойдём вниманием эту возможность и добавим код в программу.

    'произведём заливку ячейки с помощью константы
    TableWord.Cell(8, 1).Shading.BackgroundPatternColor = wdColorGold

    'произведём заливку ячейки с помощью функции RGB
    TableWord.Cell(8, 2).Shading.BackgroundPatternColor = RGB(100, 200, 50)

    'произведём заливку столбца
    TableWord.Columns(3).Shading.BackgroundPatternColor = wdColorOrange

    'произведём заливку строки
    TableWord.Rows(10).Shading.BackgroundPatternColor = wdColorTan

    'произведём заливку всей таблицы
    'TableWord.Shading.BackgroundPatternColor = wdColorBlue


    Основным действием в ходе работы с таблицами является добавление текста в ячейки. Для простого добавления текста хватает и кода TableWord.Cell(4, 2).Range.Text = "", но здесь есть некоторые нюансы. Например при использовании данного кода вы всегда будете обновлять содержимое ячейки, то есть уничтожать предыдущий текст. И самое неприятное это то что при изменении свойств текста вы изменяете свойства всего текста в ячейке. Рассмотрим на примере:

    'печатаем текст в ячейку (в две строки)
    TableWord.Cell(10, 1).Range.Text = "Назаров" & vbCrLf & "GGG"
    'меняем цвет текста в ячейке
    TableWord.Cell(10, 1).Range.Font.Color = wdColorBlue
    'делаем текст размером 14 пт.
    TableWord.Cell(10, 1).Range.Font.Size = 14
    'переключаем на полужирный текст
    TableWord.Cell(10, 1).Range.Font.Bold = wdToggle


    Для того чтобы обойти эти ограничения мы воспользуемся способом, описанным в предыдущей статье.

    'выбираем ячейку
    TableWord.Cell(10, 2).Select


    Если после этого кода мы не вставим команду "снять выделение", то текст, который был в ячейке, уничтожится и вместо него напечатается новый. Для того чтобы этого избежать, введите код:

    'снимаем выделение
    'DocWord.Application.Selection.EndOf


    После этого вы можете добавлять и изменять текст. Для изменения свойств текста вводите код для изменения свойств, перед тем как добавите текст. Свойства можно изменять почти так же, как описано в предыдущих статьях за исключением операторов TypeText и TypeParagraph.

    'добавляем в её текст
    DocWord.Application.Selection.TypeText "Первый текст"
    'начинаем новую строку
    DocWord.Application.Selection.TypeParagraph
    'делаем её шрифт синим
    DocWord.Application.Selection.Font.Color = wdColorBlue
    'добавляем текст
    DocWord.Application.Selection.TypeText "Вторая строка текста."
    'начинаем новую строку
    DocWord.Application.Selection.TypeParagraph
    'делаем текст размером 14 пт.
    DocWord.Application.Selection.Font.Size = 14
    'меняем цвет текста
    DocWord.Application.Selection.Font.Color = wdColorOrange
    'переключаем на полужирный текст
    DocWord.Application.Selection.Font.Bold = wdToggle
    'добавляем текст
    DocWord.Application.Selection.TypeText "Третья строка текста."


    Одним из способов оформления таблиц является "авто формат", то есть готовые стили оформления встроенные в Word. Их в 2000 целых 43 штуки. Вы можете поэкспериментировать с ними, введя следующий код и нажимая кнопку для переключения стилей. Предупреждение - изменение стиля производите в начале работы с таблицей, иначе все ваши изменения в оформлении ячеек пропадут!

    'изменяем счетчик и сбрасываем его при достижении 43
    Shet = Shet + 1
    If Shet = 43 Then Shet = 0

    'форматировать таблицу выбраным стилем
    TableWord.AutoFormat Shet


    Интересной возможностью Word-a является возможность добавлять (почти) сколько угодно вложенных таблиц. Работать с ними можно также, как это было описано выше.

    'выбираем ячейку
    TableWord.Cell(15, 2).Select
    'снимаем выделение (для нормальной работы следующего кода)
    DocWord.Application.Selection.EndOf

    'добавляем вложенную таблицу
    Set TableWord2 = DocWord.Tables.Add(DocWord.Application.Selection.Range, 5, 3)

    'печатаем текст в ячейку
    TableWord2.Cell(2, 2).Range.Text = "2,2"

    Наверх

69. Сортировка методом Шелла


    Sub ShellSort(vArray As Variant)
    Dim TempVal As Variant
    Dim i As Long, GapSize As Long, CurPos As Long
    Dim FirstRow As Long, LastRow As Long, NumRows As Long
    FirstRow = LBound(vArray)
    LastRow = UBound(vArray)
    NumRows = LastRow - FirstRow + 1
    Do
    GapSize = GapSize * 3 + 1
    Loop Until GapSize > NumRows
    Do
    GapSize = GapSize \ 3
    For i = (GapSize + FirstRow) To LastRow
    CurPos = i
    TempVal = vArray(i)
    Do While CompareResult(vArray(CurPos - GapSize), TempVal)
    vArray(CurPos) = vArray(CurPos - GapSize)
    CurPos = CurPos - GapSize
    If (CurPos - GapSize) < FirstRow Then Exit Do
    Loop
    vArray(CurPos) = TempVal
    Next
    Loop Until GapSize = 1
    End Sub
    Private Function CompareResult(Value1 As Variant, Value2 As Variant)
    CompareResult = (Value1 > Value2)
    End Function

    Наверх

70. Работа с Word - Работа с графическими объектами в Word (часть 1)

    Автор: Валерий Назаров

    Кроме инструментов для работы с таблицами и текстом Word располагает обширным набором функций и методов для работы с графическими объектами. Для этого у Word-a есть встроенный графический редактор, набор инструментов которого вы можете использовать для красочного оформления документов. Вы можете использовать линии, прямоугольники, стрелки, автофигуры и т.д. При этом имеется коллекция ThreeD, для придания практически всем этим графическим элементам, "примитивам", объёма.

    Для создания графического объекта вы можете использовать два метода:
    1) явным объявлением объектной переменной типа Shape, например Dim Line1 As Word.Shape, и последующей её инициализацией.
    2) неявной инициализацией объекта Shape.
    Оба метода имеют свои преимущества и недостатки, например при 2-м методе не нужно объявлять объектную переменную для каждого графического примитива, но в дальнейшем сложнее получать доступ к свойствам и методам этого конкретного объекта. Это происходит потому, что к заранее объявленному и в последствии инициализированному графическому объекту вы обращаетесь напрямую, а при неявной инициализации вам необходимо знать индекс или имя конкретного графического объекта, что довольно сложно, особенно если не Вы создали часть объектов. Из этого следует, что проще (на мой взгляд) при создании новых графических примитивов сначала инициализировать заранее объявленный объект, получить и запомнить его имя или ввести уникальное, а затем уничтожить ссылку на этот объект (если вы хотите переициализировать переменную) и в дальнейшем использовать для доступа к объекту его уникальное имя. Если вы не собираетесь использовать слишком много графических объектов, то ещё проще, просто объявить нужное количество объектных переменных и в последствии спокойно обращаться к ним.

    Следует помнить о том, что новый графический объект создается на текущем листе и принадлежит этому листу, поэтому сначала перейдите на нужный вам лист и только потом инициализируйте примитив. Его координаты задаются от левого верхнего угла листа, а не от этой же части "печатной области", и если вы зададите координаты за пределами листа, то объект создастся, но не будет виден, хотя вы можете впоследствии и передвинуть его в видимую область. Естественно, что координаты задаются в твипах и если вы хотите использовать другие единицы, то должны будете использовать встроенные функции, например CentimetersToPoints(Х,хх). Также нужно (в дальнейшем) пре необходимости изменять координаты графического объекта, помнить о том, что после создания примитива он автоматически привязывается к ближайшей от своей верхней границы текстовой строке и его свойство .Top и .Left будет отсчитываться от начала этой строки. Это сделано для того, чтобы при перемещении "привязанной" строки перемещались и связанные с ней графические объекты. При этом они (объекты) могут перейти при недостатке места на текущем листе на соседний лист, чего вы не сможете сделать, просто изменяя координаты графического объекта.
    Остановимся на общем принципе построения графических объектов для понимания принципа работы с ними. Любой Г.О. это (в принципе) квадрат в котором находиться изображение какого ни будь примитива, поэтому у него есть только ширина и высота. Если вы зададите равными ширину и высоту для "овала", то получите круг и т.д. Если вы объедините несколько примитивов (сгруппируете их), то получите новый квадрат с изображением группы примитивов. Так как ширина и высота не могут быть отрицательными, чтобы изменить, например, координаты концов линии вам потребуется зеркально отобразить изображение линии по вертикали или горизонтали, а уже после этого шириной, высотой, отступом сверху и слева привести её к нужному вам виду и расположению. Сразу понять, что получится от применения того или иного кода, сложно, поэтому я вам предлагаю поэкспериментировать и для этого запустить на выполнение программу пример.



    Работа с линией


    Для начала создадим линию двумя способами:

    1)

    'инициализируем (создадим) линию
    'с координатами (начало_Линии_слева(Х),начало_Линии_сверху(У), 'конец_Линии_слева(Х),конец_Линии_сверху(У)
    Set Line1 = DocWord.Shapes.AddLine(0, 0, CentimetersToPoints(3), CentimetersToPoints(2))
    'изменим цвет линии
    Line1.Line.ForeColor.RGB = RGB(0, 0, 255)
    'изменим толщину линии
    Line1.Line.Weight = 2.25


    2)

    'инициализируем (создадим) линию неявным объявлением
    'и присвоим ей уникальное имя для дольнейшего доступа
    DocWord.Shapes.AddLine(100, 0, 100, 100).Name = "DDD1"
    'изменим цвет линии
    DocWord.Shapes("DDD1").Line.ForeColor.RGB = RGB(255, 0, 0)
    'или DocWord.Shapes.Range("GGG1").Line.ForeColor.RGB = RGB(1, 255, 0)
    'изменим толщину линии
    DocWord.Shapes("DDD1").Line.Weight = 4


    заносим данные в талицу:

    'добавляем данные в таблицу
    TableWord.Cell(2, 1).Range.Text = "Line1"
    'получаем имя объекта "линия"
    TableWord.Cell(2, 2).Range.Text = Line1.Name
    'получяем отступ сверху
    TableWord.Cell(2, 3).Range.Text = Line1.Top
    'получяем отступ слева
    TableWord.Cell(2, 4).Range.Text = Line1.Left
    'получаем ширину несушего квадрата
    TableWord.Cell(2, 5).Range.Text = Line1.Width
    'получаем высоту несушего квадрата
    TableWord.Cell(2, 6).Range.Text = Line1.Height
    'если нужно в сантиметрах
    'Round(Line1.Height / 28.35, 2) & " см"
    'меняем имя линии
    'Line1.Name = "GGG1"

    С помощью этого кода изменим положение линии.

    'Смещаем линию (отступ сверху)
    Line1.Top = Line1.Top + 10

    'Смещаем линию (отступ слева)
    Line1.Left = Line1.Left + 10


    А с помощью этого кода изменим размеры несущего квадрата, то есть его высоту и ширину.

    'изменим ширину несушего квадрата
    Line1.Width = Line1.Width + 10

    'изменяем высоту несушего квадрата
    Line1.Height = Line1.Height + 10


    Зеркально отразим изображение примитива (линии) по вертикали и горизонтали, то есть перевернём картинку.

    'Зеркально отразим по вертикали
    Line1.Flip 1 'msoFlipVertical

    'Зеркально отразим по горизонтали
    Line1.Flip 0 'msoFlipHorizontal


    Для придания объемного вида графическим примитивам вы можете использовать данный код:

    'показать объём
    Line1.ThreeD.Visible = &HFFFFFFFF 'msoTrue

    'скрыть объём
    Line1.ThreeD.Visible = 0 'msoFalse

    'переключить видимость объёма
    Line1.ThreeD.Visible = &HFFFFFFFD 'msoTriStateToggle

    'изменим стиль изображения объёма
    Line1.ThreeD.SetThreeDFormat 1
    Наверх

71. Работа с Word - Работа с графическими объектами в Word (часть 2)

    Автор: Валерий Назаров


    Эту статью я хочу начать с того, что все методы и код который я описал в предыдущей статье, применимы практически для всех графических объектов в Word. А также и все ограничения, которые я отразил ранее, поэтому я не буду подробно останавливаться на них. И так продолжим:
    Рассмотрим создание объекта "ОВАЛ" и используем уже известные нам свойства (небольшую часть, остальные добавьте сами из прошлой статьи).


    'Добавляем объект овал (константа=9,отступ_слева,отступ_справа,ширина,высота)
    Set Oval1 = DocWord.Shapes.AddShape(9, 200, 200, 100, 100)

    'цвет линии
    Oval1.Line.ForeColor.RGB = RGB(0, 0, 255)

    'толщина линии
    Oval1.Line.Weight = 2.25

    'добавляем цвет заливки
    Oval1.Fill.ForeColor.RGB = RGB(255, 255, 95)


    В объекты с границами (имеющими замкнутый контур) вы можете добавлять текст.

    'добавляем простой текст выбрав объект по имени
    DocWord.Shapes(Oval1.Name).TextFrame.TextRange.Select
    DocWord.Application.Selection.TypeText ".Name"
    DocWord.Application.Selection.TypeParagraph
    DocWord.Application.Selection.TypeText Oval1.Name
    DocWord.Application.Selection.EndOf

    ' 'изменим стиль изображения объёма
    'Oval1.ThreeD.SetThreeDFormat 1


    Следующий часто употребляемый графический объект - это ПРЯМОУГОЛЬНИК. Его часто используют для создания рамок на листах в рефератах. Вы при необходимости можете написать программу, которая будет оформлять документ, заключая все листы в рамки. А теперь перейдём к коду.

    'Добавляем объект квадрат (квадрат=1, отступ_слева, отступ_справа, ширина, высота)
    Set Kyb1 = DocWord.Shapes.AddShape(1, 350, 200, 100, 80)


    В этой секции кода мы рассмотрим общий для многих графических объектов способ изменения порядка отображения графического элемента в документе, а также способ поворота на произвольный угол.

    'изменим порядок отображения
    Kyb1.ZOrder 5
    'используйте данные значения констант
    '0 - на передний план
    '1 - на задний план
    '2 - переместить вперёд
    '3 - переместить назад
    '4 - поместить перед текстом
    '5 - поместить за текстом

    'повернуть на произвольный угол (можно на отрицательный)
    Kyb1.IncrementRotation 45



    Следующий объект - это НАДПИСЬ. При его создании вы можете с помощью констант определить как в нем будет располагаться текст; горизонтально, вертикально, перевернуто и т.д.

    'Добавляем объект надпись (текст_горизонтальный=1,отступ_слева,отступ_справа,ширина,высота)
    Set Textbox1 = DocWord.Shapes.AddTextbox(1, 270, 200, 100, 100)

    'цвет линии (белый)
    Textbox1.Line.ForeColor.RGB = RGB(255, 255, 255)
    'толщина линии
    Textbox1.Line.Weight = 2.25
    'добавляем цвет заливки
    Textbox1.Fill.ForeColor.RGB = RGB(255, 255, 95)


    Для оформления документа вы можете использовать объект WordArt. Его основные графические свойства задаются при создании.

    'Добавляем объект WordArt (стиль,текст,шрифт,его размер,полужырный(да,нет),
    'курсив(да,нет),отступ_слева,отступ_справа,ширина,высота)
    Set TextEffect1 = DocWord.Shapes.AddTextEffect(3, "Просто текст", "Arial", 20, 1, 0, 100, 350)

    'добавляем цвет заливки
    TextEffect1.Fill.ForeColor.RGB = RGB(255, 255, 95)
    'цвет линии
    TextEffect1.Line.ForeColor.RGB = RGB(255, 0, 255)


    Следующие объекты прекрасно подходят для создания линейных графиков в вашем документе. Это объекты СПЛАЙН (кривая) и ПОЛИЛИНИЯ. Объявляются они одинаково, единственное отличие это применение разных констант при добавлении точек.

    'создадим кривые ( СПЛАИН и ПОЛИЛИНИЯ)
    'инициализируем и вводим координаты первой точки
    With WordApp.ActiveDocument.Shapes.BuildFreeform(0, 80, 160)
    'добавляем следующие точки (в стиле сплаин "сглаживание")
    .AddNodes 1, 0, 100, 170
    .AddNodes 1, 0, 120, 150
    .AddNodes 1, 0, 140, 170
    .AddNodes 1, 0, 160, 150
    .AddNodes 1, 0, 180, 170
    'добавляем следующие точки (в стиле полилинии)
    .AddNodes 1, 1, 250, 170
    .AddNodes 1, 1, 280, 150
    .AddNodes 1, 1, 310, 170
    .AddNodes 1, 1, 340, 150
    .AddNodes 1, 1, 370, 170
    'заканчиваем создание и выбираем созданный объект
    .ConvertToShape.Select
    End With

    'переименовываем. ВНИМАНИЕ если нажмете на кнопку ещё раз,
    'то вызовете ошибку, так как объект с таким именем уже есть
    DocWord.ActiveWindow.Selection.ShapeRange.Name = "XXX1"
    'меняем цвет линии
    DocWord.Shapes.Range("XXX1").Line.ForeColor.RGB = RGB(1, 255, 0)
    'и т.д.


    Вам может понадобиться сгруппировать несколько объектов в один. Для этого вы можете использовать следующий код.
    ВНИМАНИЕ: для избежание ошибки сначала создайте все объекты.

    'выбираем несколько объектов
    DocWord.Application.ActiveDocument.Shapes.Range(Array(Oval1.Name, Kyb1.Name, Textbox1.Name, "XXX1")).Select
    'WordApp.ActiveDocument.Shapes.Range(Array()).Select

    'группируем все объекты (выбранные)
    DocWord.ActiveWindow.Selection.ShapeRange.Group.Select

    'переименовываем созданный объект если нажмете на кнопку ещё раз,
    'то вызовете ошибку так как объект с таким именем уже есть
    DocWord.ActiveWindow.Selection.ShapeRange.Name = "DDD1"
    'и т.д.

    'разгруппируем группу
    'DocWord.Shapes.Range("DDD1").Ungroup.Select


    И последний код - вставка рисунка.

    'вставим рисунок
    DocWord.Application.ActiveDocument.Shapes.AddPicture(App.Path & "\Образец.jpg").Select

    Наверх

61. Как запретить запуск второй копии программы

    'Добавьте этот код в загрузку формы:

    If App.PrevInstance Then End

    Наверх

72. Использование Visual Basic 6.0 для управления внешними устройствами и приём внешней информации (температура, давление, напряжение, ток и т.п.) через LPT порт

    Автор: Инженер-энергетик, Михаил Пирогов



    Введение

    Любое внешнее устройство подключается к компьютеру через порты. Например, LTP, COM, USB. Наиболее просто – программирование LTP порта. Общий принцип компьютерной системы контроля выглядит так:

    Компьютерная программа посылает определенные сигналы через LTP порт на коммутатор, на основании полученных сигналов коммутатор подключает к аналого-цифровому преобразователю датчики. Данные с АЦП поступают в коммутатор, LTP и обрабатываются нашей волшебной программой написанной на VB 6.0. Это – развитая промышленная система контроля и управления, которую я, Божьей помощью рассчитываю создать. Если вы хотите научиться включать свет в своём туалете с помощью PC, узнавать температуру воды в вашей ванне, то надо начинать с системы попроще.


    ШАГ 1: Изучение работы LTP порта

    Для тех, кто не знает, что есть LTP, скажу – это то «отверстие» куда ты подключаешь принтер старой модели. Широкий разъём. LTP порт имеет следующую структуру:

    Он состоит из отсеков (адресов) H378, H37a. Есть еще другие, но для создания компьютерного управления чайником на кухне тебе знать о них необязательно. Адреса H378, H37a могут выдавать и принимать сигналы, работают двунаправлено. Как правило, H37a служит для управления коммутирующим устройством, а H378 для отправки и приёма сигналов. Под понятием сигнал надо понимать присутствие или отсутствие напряжения (5В) на порте. Например, если вы хотите включать/выключать всего 12 (8+4) лампочек или чайников (или светомузыки), то вы можете отказаться от коммутатора и АЦП. Просто программой необходимо подать, например, напряжение 5В адреса H378, ножки 2. Эта ножка, например, связана с реле, которое включает более мощное реле (можно и полупроводниковое) и энергия подаётся на вашу лампочку. Вот и весь принцип. Главное программой указать компьютеру, на какую ножку, какого адреса подать или убрать напряжение. Можно сделать устройство, которое определит, например, горит ли у вас свет на кухне. Для этого необходимо сделать простенькое устройство, которое подаёт напряжение на LTP (5В). После программа читает порт и делает вывод, какое реле подаёт сигнал (1, 2, 3…) и делает вывод что работает (TRUE) или что не работает (FALSE). В зависимости от полученного результата, например, объект Shape меняет цвет. Важно, чтобы коммутирующие устройства имели качественную гальваническую развязку с компьютером, иначе спалите PC.


    ШАГ 2: Научимся считать в системах…BIN, HEX, DEC

    BIN – цифровая форма записи числа (10111011 – байт), или бинарная система исчисления (слыхал о цифровой технике…?). HEX – долго объяснять, если есть желание возьми и изучи булеву алгебру. Просто позже поймешь, как использовать HEX. Абстрактно – на этих числах работает электроника компьютера и команды управления, часто задаются в этой системе исчисления. DEC – привычные нам числа, один, три целых шесть десятых. Любое число, которое вы видите в учебнике по математике за 7 класс. Нам надо уметь пользоваться этой системой исчисления, для того чтобы составлять команды для LTP порта, какую ножку ему «зажечь или потушить». Научимся сначала «зажигать». Например, ты хочешь чтобы третья ножка адреса H378 загорелась. В бинарной системе это выглядит так: 00000100. Согласен? Третья справа имеет на выходе единицу (5В). Запускаем калькулятор, меню «ВИД», пункт «ИНЖЕНЕРНЫЙ» или качаем понятную, специальную программу-конвертер изображенную снизу.

    Если ты всё-таки хочешь использовать калькулятор Билла Гейтса, то укажи опцию BIN и введи число:

    100 – это 00000100 за минусом передних нулей. После этого просто переключи опцию на HEX и ты получишь число 4. После от FF отними 4 и получишь FB. Это и есть число, которое надо послать в адрес H378, порта LTP чтобы на третьей ножке компьютер вывел напряжение 5 вольт.
    Если ты хочешь зажечь 1,2,5,7 ножку то операция формирования команды выглядит так:
    BIN – 01010011
    HEX – (FF-53) = AC
    А привычное нам число – 83
    Помни, что команда формируется не программой, а программистом (в простых системах).
    Да забыл сказать, у нас адрес H378 имеет восемь выходов (битов), поэтому опция на калькуляторе 8-бит.
    Пока не изучишь системы исчисления, не поймешь как получаются HEX. А пока, просто умей определять команду.



    ШАГ 3: Понятие дискретного сигнала

    Дискретный сигнал это – бит. Например, ты хочешь знать включена ли лампочка в ванне. Эта лампочка зажигается от реле, контакт которого соединен с третьей ножкой порта. В данном случае вас интересует, есть ли на 3-й ножке 5 вольт. Это и есть дискретный сигнал (один бит). Аналогично, если вы подаёте единицу на 4-ю ножку чтобы включить четвертую лампочку, можно расценивать это как дискретный сигнал (один бит).


    ШАГ 4: Обработка дискретного сигнала

    Мы уже представляем принцип формирования команды на LTP порт. Как принять и понять, есть ли на определенной ножке напряжение (единица или включена ли ваша лампочка).
    Принцип следующий:
    Читаем порт, и получаем число, например DATA
    Оценка результатов


    ШАГ 5. Написание программы

    Для того, чтобы VB мог работать с LTP портом, необходимо скачать специальный драйвер. Установите этот драйвер у себя на компьютере (Setup прилагается). Напишем программу, которая будет «зажигать» ножки LTP порта, или тушить их, а также определять на какую ножку приходит единица (5Вольт) с внешнего устройства и использовать результат для нашей программы. Запустите VB 6.0 и создайте проект. Создайте форму по примеру:

    На кнопках в скобках указан номер ножки на порте, а до скобки номер ножки на нашем рисунке, в CHECK указан номер ножки на порте. Например при нажатии кнопки 2(3) на 3-й разъём порта подаётся 5 вольт. В случае адреса H37а рассмотрен другой вариант реализации запуск/остановка ножек. Там происходит автоматическое формирование команды, которая в последствии записывается в порт. При нажатии кнопки ПРОЧИТАТЬ АДРЕС H378, производится считывание с порта и в зависимости от того, на какой ножке есть единица, та линия и окрашивается в красный цвет. Если Вы хотите что-либо считывать с порта, то Вам необходимо переключить режим работы порта компьютера в режим EPP (Enhanced Parallel Port – режим двунаправленной передачи данных). Это делается в BIOS. Во время загрузки компьютера когда появится надпись Press DEL to enter setup, нажмите DEL, чтобы попасть в меню BIOS. Затем выберите раздел INTEGRATED PERIPHERALS и там выберите строку PARALLEL PORT MODE: измените режим работы Вашего порта на EPP или SPP/EPP. Сохраните сделанные изменения. Теперь декларируем в модуле:

    Public Declare Function DlPortReadPortUchar Lib "dlportio.dll" _
    (ByVal Port As Long) As Byte
    Public Declare Function DlPortReadPortUshort Lib "dlportio.dll" _
    (ByVal Port As Long) As Integer
    Public Declare Function DlPortReadPortUlong Lib "dlportio.dll" _
    (ByVal Port As Long) As Long

    Public Declare Sub DlPortReadPortBufferUchar Lib "dlportio.dll" _
    (ByVal Port As Long, Buffer As Any, ByVal Count As Long)
    Public Declare Sub DlPortReadPortBufferUshort Lib "dlportio.dll" _
    (ByVal Port As Long, Buffer As Any, ByVal Count As Long)
    Public Declare Sub DlPortReadPortBufferUlong Lib "dlportio.dll" _
    (ByVal Port As Long, Buffer As Any, ByVal Count As Long)

    Public Declare Sub DlPortWritePortUchar Lib "dlportio.dll" _
    (ByVal Port As Long, ByVal Value As Byte)
    Public Declare Sub DlPortWritePortUshort Lib "dlportio.dll" _
    (ByVal Port As Long, ByVal Value As Integer)
    Public Declare Sub DlPortWritePortUlong Lib "dlportio.dll" _
    (ByVal Port As Long, ByVal Value As Long)

    Public Declare Sub DlPortWritePortBufferUchar Lib "dlportio.dll" _
    (ByVal Port As Long, Buffer As Any, ByVal Count As Long)
    Public Declare Sub DlPortWritePortBufferUshort Lib "dlportio.dll" _
    (ByVal Port As Long, Buffer As Any, ByVal Count As Long)
    Public Declare Sub DlPortWritePortBufferUlong Lib "dlportio.dll" _
    (ByVal Port As Long, Buffer As Any, ByVal Count As Long)


    Представте, что к адресу Н378 подключена схема:

    В кнопку прочитать адрес H378:

    Dim data as Integer
    data = DlPortReadPortUchar(&H378)) '(читаем порт,
    'полученное значение присваиваем переменной)
    'а теперь, проверяем наличие сигнала на каждой ножке
    'и в зависимости от этого выполняем действие
    If (data And &H1) > 0 Then Line1.BorderColor = &HFF& Else Line1.BorderColor = &H0&
    If (data And &H2) > 0 Then Line2.BorderColor = &HFF& Else Line2.BorderColor = &H0&
    If (data And &H4) > 0 Then Line3.BorderColor = &HFF& Else Line3.BorderColor = &H0&
    If (data And &H8) > 0 Then Line4.BorderColor = &HFF& Else Line4.BorderColor = &H0&
    If (data And &H10) > 0 Then Line5.BorderColor = &HFF& Else Line5.BorderColor = &H0&
    If (data And &H20) > 0 Then Line6.BorderColor = &HFF& Else Line6.BorderColor = &H0&
    If (data And &H40) > 0 Then Line7.BorderColor = &HFF& Else Line7.BorderColor = &H0&
    If (data And &H80) > 0 Then Line8.BorderColor = &HFF& Else Line8.BorderColor = &H0&


    Для работы с Check, необходимо объявить глобальную переменную:

    Public nojka As Integer

    Код выглядит следующим образом:

    Private Sub Check10_Click()
    If Check10.Value = 1 Then nojka = nojka + &H10 Else nojka = nojka - &H10
    DlPortWritePortUlong &H37A, nojka
    End Sub

    Private Sub Check11_Click()
    If Check11.Value = 1 Then nojka = nojka + &H2 Else nojka = nojka - &H2
    DlPortWritePortUlong &H37A, nojka
    End Sub

    Private Sub Check12_Click()
    If Check12.Value = 1 Then nojka = nojka + &H4 Else nojka = nojka - &H4
    DlPortWritePortUlong &H37A, nojka
    End Sub

    Private Sub Check13_Click()
    If Check13.Value = 1 Then nojka = nojka + &H8 Else nojka = nojka - &H8
    DlPortWritePortUlong &H37A, nojka
    End Sub


    Вы видите, что в адрес H37a записывается команда nojka, которая формируется математически в зависимости от состояния Check-ов. Если к LTP порту вы подключите лампочки (с резистором), то вы увидите, как они загораются или тухнут (чертеж для адреса &H378).

    Вот и всё, портом управлять вы умеете, собирайте схему и работайте…

    ШАГ 6: Очень важные мелочи…

    Для персонального обучения управлению LTP вам необязательно собирать внешние устройства (лампочки, реле и т.п.). Можно самостоятельно записывать данные в порт ('DlPortWritePortUlong Val(&H378), "&H" & "bf"), где "&H" & "bf" сформированная команда. Причем данные останутся записанными в порте и вы можете прочитать их:

    Private Sub Command2_Click()
    Dim Value As Long
    Value = DlPortReadPortUchar((&H378)
    TextValue = "&H" + Hex(Value)
    Text1.Text = Value
    End Sub


    Или обработать данные по принципу кнопки «прочитать адрес H378».
    Учтите, что в случае, когда вы самостоятельно записываете команду в порт и потом читаете порт, данные после чтения удаляются. А в случае, когда данные подаются на порт внешним устройством, читать можно хоть сто раз, данные с порта не исчезнут, так как подаются внешним, независимым от компьютера устройством. Знайте, что при использовании неэкранированного кабеля для приёма/передачи данных, в нём могут возникать наводки (так мы как-то регистрировали частоту 33кГц) – это нарушит работу сложной системы коммутатор-АЦП (я с этим сталкивался…). Это устраняется внесением сглаживающего блокирования в схему. Но это другая история…


    ШАГ 7: Приём сигналов с АЦП, коммутаторов и т.п.

    Расписывать подробно не буду, так как в домашних условиях вряд ли кто будет собирать АЦП или коммутатор. Скажу обобщенно. АЦП бывает 4, 6, 8, 16 и т.п. разрядный + тип. В зависимости от этого ( и от датчиков и всей системы подачи/отправки данных) необходимо определить коэффициент пересчёта. Пересчёт данных с порта выглядит обобщенно так: Результат = ((«Верхняя граница измерения» - «Нижняя граница измерения»)/»Разрядность АЦП»)*«data» + «Нижний предел измерения» Разрядность АЦП – 256 (если выдаёт восемь бит), 64 (если 4 бит) и т.д. АЦП – аналого-цифровой преобразователь. Это устройство можно собрать самостоятельно. Устройство достаточно сложное, ориентировочный срок изготовления 25-40 дней. Например, вы хотите передать на компьютер силу тока и отобразить её где-нибудь. Ток в измеряемой цепи колеблется от 0 до 100А. В этом случае мы поступаем как я нарисовал на схеме:

    Схема упрощена, так как в ней отсутствует коммутирование к АЦП нескольких датчиков Это может казаться сложно, но это очень просто, просто нужно знать, что за система, с какими параметрами она передаёт данные. Скажу одно, эту систему можно (обычно это так и делается!) простым паяльником. Если есть вопросы, то я с удовольствием всегда вас проконсультирую по электронной почте о приёме «аналогового сигнала».


    ШАГ 8: Область применения

    На этом принципе можно собрать светомузыку для дискотек, управление и контроль за работой любого оборудования, принимать и отображать на компьютере данные по току, давлению, температуре, потреблению газа, воды, воздуха и т.п. И всё это можно сделать на VB 6.0 используя его возможности. Главное, отправить и принять/обработать данные с порта и как вы видели, это так же просто, как и работа с элементом Label.

    Изложены основные принципы, проверенные на практике!
    Нужна схема коммутатора? Жду, пиши…

    Вы можете также посетить мой сайт: www.energoarhiv.narod.ru.
    Наверх

73. Как написать игру на Visual Basic

    Статья как написать игру на VB + исходник.

    Наверх | Скачать статью + исходник

74. Как расшарить программно ресурс (несколько способов)

    Самый простой способ:
    1. Способ Помести это в загрузку формы:
    Shell "net share " & "c" & "=C:\"

    2 Способ. Через АПИ:

    Кинь на форму 1 кнопку, и 5 текстовых полей
    Вот код:

    Option Explicit
    Private Const NERR_SUCCESS As Long = 0&

    'типы шар
    Private Const STYPE_ALL As Long = -1 'note: my const
    Private Const STYPE_DISKTREE As Long = 0
    Private Const STYPE_PRINTQ As Long = 1
    Private Const STYPE_DEVICE As Long = 2
    Private Const STYPE_IPC As Long = 3
    Private Const STYPE_SPECIAL As Long = &H80000000

    'разрешения
    Private Const ACCESS_READ As Long = &H1
    Private Const ACCESS_WRITE As Long = &H2
    Private Const ACCESS_CREATE As Long = &H4
    Private Const ACCESS_EXEC As Long = &H8
    Private Const ACCESS_DELETE As Long = &H10
    Private Const ACCESS_ATRIB As Long = &H20
    Private Const ACCESS_PERM As Long = &H40
    Private Const ACCESS_ALL As Long = ACCESS_READ Or ACCESS_WRITE Or ACCESS_CREATE Or ACCESS_EXEC Or ACCESS_DELETE Or ACCESS_ATRIB Or ACCESS_PERM

    Private Type SHARE_INFO_2
    shi2_netname As Long
    shi2_type As Long
    shi2_remark As Long
    shi2_permissions As Long
    shi2_max_uses As Long
    shi2_current_uses As Long
    shi2_path As Long
    shi2_passwd As Long
    End Type

    Private Declare Function NetShareAdd Lib "netapi32" (ByVal servername As Long, ByVal level As Long, buf As Any, parmerr As Long) As Long

    Private Sub Form_Load()
    Text1.Text = "\\" & Environ$("COMPUTERNAME")
    Text2.Text = "c:\program files\adobe"
    Text3.Text = "vbnetdemo"
    Text4.Text = "VBnet demo test share"
    Text5.Text = ""
    End Sub

    Private Sub Command1_Click()
    Dim success As Long
    success = ShareAdd(Text1.Text, Text2.Text, Text3.Text, Text4.Text, Text5.Text)
    Select Case success
    Case 0: MsgBox "share created successfully!"
    Case 2118: MsgBox "share name already exists"
    Case Else: MsgBox "create error " & success
    End Select
    End Sub

    Private Function ShareAdd(sServer As String, sSharePath As String, sShareName As String, sShareRemark As String, sSharePw As String) As Long

    Dim dwServer As Long
    Dim dwNetname As Long
    Dim dwPath As Long
    Dim dwRemark As Long
    Dim dwPw As Long
    Dim parmerr As Long
    Dim si2 As SHARE_INFO_2

    'получаем указатели на сервер, ресурс и путь
    dwServer = StrPtr(sServer)
    dwNetname = StrPtr(sShareName)
    dwPath = StrPtr(sSharePath)

    'Если описание или пароль указаны,
    'то также получаем указатели на них
    If Len(sShareRemark) > 0 Then
    dwRemark = StrPtr(sShareRemark)
    End If

    If Len(sSharePw) > 0 Then
    dwPw = StrPtr(sSharePw)
    End If

    'подготавливаем структуру SHARE_INFO_2
    With si2
    .shi2_netname = dwNetname
    .shi2_path = dwPath
    .shi2_remark = dwRemark
    .shi2_type = STYPE_DISKTREE
    .shi2_permissions = ACCESS_ALL
    .shi2_max_uses = -1
    .shi2_passwd = dwPw
    End With
    'расшариваем ресурс
    ShareAdd = NetShareAdd(dwServer, 2, si2, parmerr)
    End Function

    3. Способ
    Еще можно через реесстр:
    Вот исходник: http://vbrus.narod.ru/MyProgs/Share.zip
    Наверх

75. Как узнать сколько памяти жрет указанный процесс?

    'Помести вот этот код в модуль:

    Public Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" (ByVal hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS, ByVal cb As Long) As Long
    Public Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
    Public Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
    Public Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long
    Public Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
    Public Declare Function EnumProcesses Lib "PSAPI.DLL" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
    Public Declare Function GetModuleFileNameExA Lib "PSAPI.DLL" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
    Public Declare Function EnumProcessModules Lib "PSAPI.DLL" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
    Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
    Public Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
    Public Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Public Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Public Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)


    Public Const PROCESS_QUERY_INFORMATION = 1024
    Public Const PROCESS_VM_READ = 16
    Public Const MAX_PATH = 260
    Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
    Public Const SYNCHRONIZE = &H100000
    Public Const PROCESS_ALL_ACCESS = &H1F0FFF
    Public Const TH32CS_SNAPPROCESS = &H2&
    Public Const hNull = 0
    Public Const WIN95_System_Found = 1
    Public Const WINNT_System_Found = 2
    Public Const Default_Log_Size = 10000000
    Public Const Default_Log_Days = 0
    Public Const SPECIFIC_RIGHTS_ALL = &HFFFF
    Public Const STANDARD_RIGHTS_ALL = &H1F0000

    Type MEMORYSTATUS
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
    End Type

    Type PROCESS_MEMORY_COUNTERS
    cb As Long
    PageFaultCount As Long
    PeakWorkingSetSize As Long
    WorkingSetSize As Long
    QuotaPeakPagedPoolUsage As Long
    QuotaPagedPoolUsage As Long
    QuotaPeakNonPagedPoolUsage As Long
    QuotaNonPagedPoolUsage As Long
    PagefileUsage As Long
    PeakPagefileUsage As Long
    End Type

    Public 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 * 260
    End Type

    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 Function GetProcesses(ByVal EXEName As String)
    Dim booResult As Boolean
    Dim lngLength As Long
    Dim lngProcessID As Long
    Dim strProcessName As String
    Dim lngSnapHwnd As Long
    Dim udtProcEntry As PROCESSENTRY32
    Dim lngCBSize As Long
    Dim lngCBSizeReturned As Long
    Dim lngNumElements As Long
    Dim lngProcessIDs() As Long
    Dim lngCBSize2 As Long
    Dim lngModules(1 To 200) As Long
    Dim lngReturn As Long
    Dim strModuleName As String
    Dim lngSize As Long
    Dim lngHwndProcess As Long
    Dim lngLoop As Long
    Dim b As Long
    Dim c As Long
    Dim e As Long
    Dim d As Long
    Dim pmc As PROCESS_MEMORY_COUNTERS
    Dim lret As Long
    Dim strProcName2 As String
    Dim strProcName As String
    On Error GoTo Error_handler
    booResult = False
    EXEName = UCase$(Trim$(EXEName))
    lngLength = Len(EXEName)
    Select Case getVersion()
    Case WIN95_System_Found
    Case WINNT_System_Found
    lngCBSize = 8
    lngCBSizeReturned = 96
    Do While lngCBSize <= lngCBSizeReturned
    DoEvents
    lngCBSize = lngCBSize * 2
    ReDim lngProcessIDs(lngCBSize / 4) As Long
    lngReturn = EnumProcesses(lngProcessIDs(1), lngCBSize, lngCBSizeReturned)
    Loop
    lngNumElements = lngCBSizeReturned / 4
    'Loop thru each process
    For lngLoop = 1 To lngNumElements
    DoEvents
    'Get a handle to the Process and Open
    lngHwndProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lngProcessIDs(lngLoop))
    If lngHwndProcess <> 0 Then
    'Get an array of the module handles for the specified process
    lngReturn = EnumProcessModules(lngHwndProcess, lngModules(1), 200, lngCBSize2)
    'If the Module Array is retrieved, Get the ModuleFileName
    If lngReturn <> 0 Then
    'Buffer with spaces first to allocate memory for byte array
    strModuleName = Space(MAX_PATH)
    'Must be set prior to calling API
    lngSize = 500
    'Get Process Name
    lngReturn = GetModuleFileNameExA(lngHwndProcess, lngModules(1), strModuleName, lngSize)
    'Remove trailing spaces
    strProcessName = Left(strModuleName, lngReturn)
    'Check for Matching Upper case result
    strProcessName = UCase$(Trim$(strProcessName))
    strProcName2 = GetElement(Trim(Replace(strProcessName, Chr$(0), "")), "\", 0, 0, GetNumElements(Trim(Replace(strProcessName, Chr$(0), "")), "\") - 1)
    If strProcName2 = EXEName Then
    'Get the Site of the Memory Structure
    pmc.cb = LenB(pmc)
    lret = GetProcessMemoryInfo(lngHwndProcess, pmc, pmc.cb)
    MsgBox EXEName & "::" & CStr(pmc.WorkingSetSize / 1024)
    End If
    End If
    End If
    'Close the handle to this process
    lngReturn = CloseHandle(lngHwndProcess)
    DoEvents
    Next
    End Select
    IsProcessRunning_Exit:
    'Exit early to avoid error handler
    Exit Function
    Error_handler:
    Err.Raise Err, Err.Source, "ProcessInfo", Error
    Resume Next
    End Function

    Private Function getVersion() As Long
    Dim osinfo As OSVERSIONINFO
    Dim retvalue As Integer
    osinfo.dwOSVersionInfoSize = 148
    osinfo.szCSDVersion = Space$(128)
    retvalue = GetVersionExA(osinfo)
    getVersion = osinfo.dwPlatformId
    End Function

    Private Function StrZToStr(s As String) As String
    StrZToStr = Left$(s, Len(s) - 1)
    End Function

    Public Function GetElement(ByVal strList As String, ByVal strDelimiter As String, ByVal lngNumColumns As Long, ByVal lngRow As Long, ByVal lngColumn As Long) As String
    Dim lngCounter As Long
    ' Append delimiter text to the end of the list as a terminator.
    strList = strList & strDelimiter
    ' Calculate the offset for the item required based on the number of columns the list
    ' 'strList' has i.e. 'lngNumColumns' and from which row the element is to be
    ' selected i.e. 'lngRow'.
    lngColumn = IIf(lngRow = 0, lngColumn, (lngRow * lngNumColumns) + lngColumn)
    ' Search for the 'lngColumn' item from the list 'strList'.
    For lngCounter = 0 To lngColumn - 1
    ' Remove each item from the list.
    strList = Mid$(strList, InStr(strList, strDelimiter) + Len(strDelimiter), Len(strList))
    ' If list becomes empty before 'lngColumn' is found then just
    ' return an empty string.
    If Len(strList) = 0 Then
    GetElement = ""
    Exit Function
    End If
    Next lngCounter
    ' Return the sought list element.
    GetElement = Left$(strList, InStr(strList, strDelimiter) - 1)
    End Function

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Function GetNumElements (ByVal strList As String,
    ' ByVal strDelimiter As String)
    ' As Integer
    '
    ' strList = The element list.
    ' strDelimiter = The delimiter by which the elements in
    ' 'strList' are seperated.
    '
    ' The function returns an integer which is the count of the
    ' number of elements in 'strList'.
    '
    ' Author: Roger Taylor
    '
    ' Date:26/12/1998
    '
    ' Additional Information:
    '
    ' Revision History:
    '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Public Function GetNumElements(ByVal strList As String, ByVal strDelimiter As String) As Integer
    Dim intElementCount As Integer
    If Len(strList) = 0 Then
    GetNumElements = 0
    Exit Function
    End If
    strList = strList & strDelimiter
    While InStr(strList, strDelimiter) > 0
    intElementCount = intElementCount + 1
    strList = Mid$(strList, InStr(strList, strDelimiter) + 1, Len(strList))
    Wend
    GetNumElements = intElementCount
    End Function

    'Теперь на форме создай кнопку, вот к ней код:
    GetProcesses "explorer.exe"

    Наверх

76. Сделать картинку светлей или темней

    Создание плагина для Winamp

    Автор: Max V. Irgiznov
    www.vbrussian.com

    Данная статья расскажет вам о том, как можно создавать свои плагины для популярного мультимедиа плеера Winamp.

    Вступление
    В 2002 году я работал в одной компании системным администратором, и по долгу службы 80% времени мне приходилось находится в окружении серверов FreeBSD. У меня был еще в распоряжении был сервер с Windows на котором крутилась музыка чтобы не скучать, и было не удобно менять треки в плейлисте да и вообще работать с винампом (по некоторым причинам я не мог пользоваться такими вещами как Terminal Service, переключатели мониторов, и.т.п.), и я задался целью сделать управляющую программу для Винампа. Языком программирования был выбран VB, т.к. на этом языке я решения такой задачки не встречал и это мой любимый язык, также нужна была быстрота разработки.
    Для программирования под API Winamp`а нам потребуется:

    Winamp SDK http://www.winamp.com/nsdn/winamp2x/dev/sdk/
    Visual Basic 5.0/6.0 желательно с установленным SP5
    Col_Rjl GenWrapper - Обвертка позволяющая использовать ActiveX DLL в Винампе http://www.winamp.com/nsdn/vault/GenWrapper.exe, http://www.winamp.com/nsdn/vault/WinAMP_VB.jhtml
    Немного API для работы с сообщениями Windows
    Правда есть небольшое ограничение, этим набором можно создавать только основные (gen_*) плагины.

    Данный текст рассчитан на программистов уже имеющих опыт работы в VB с сетевыми приложениями и WinAPI.

    Часть 1. Пишем простую управляющую программу.

    Для начала напишем простую программу (не плагин) для управления винампом. Например программу которая будет принимать команду на определенном TCP порту и транслировать ее Винампу.
    Запускаем VB и создаем новый проект Standard EXE и добавляем в проект Microsoft Winsock Control 6.0, несколько API функций и констант, больше нам ничего не потребуется.
    Вот декларации функций, которые нам понадобятся:
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( ByVal lpClassName As String,ByVal lpWindowName As String ) As Long

    функция возвращает хендл на окно с заданным классом и/или строкой заголовка;

    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 Sleep Lib "kernel32" ( _
    ByVal dwMilliseconds As Long _
    )

    функция позволяющая процессу <уснуть> (система не выделяет процессу процессорного времени) на указанное число миллисекунд;

    Размещаем эти функции в секции General, также нам потребуются следующие управляющие сообщения винампа (полный их список есть в SDK к нему) и системы:

    'system
    Private Const WM_USER = &H400
    Private Const WM_COMMAND = &H111
    'winamp
    Private Const WM_Raise_Volume = 40058 'increase 1%
    Private Const WM_Lower_Volume = 40059 'decrease 1%
    Private Const WM_Close_Winamp = 40001
    Private Const WM_Previous = 40044
    Private Const WM_Next = 40048
    Private Const WM_Play = 40045
    Private Const WM_Pause_Unpause = 40046
    Private Const WM_Stop = 40047
    Private Const WM_Toggle_Shuffle = 40023
    Private Const WA_SETVOLUME = 122

    Также добавляем пару переменных уровня формы:

    Dim Response As String
    Dim Connections As Long

    первая переменная потребуется для принятия строки от клиента, вторая для счета числа подключений. Внешними они сделаны по той причине, что они могут вам потребоваться в других методах, если нет, то переменную Response можно убрать в метод DataArrival.
    Закончив с секцией General переходим к форме и основному коду.
    Размещаем на форме Winsock и задаем ему имя wnsServer и устанавливаем его свойство Index = 0, в событие Form_Load пишем следующий код:

    wnsServer(0).Protocol = sckTCPProtocol
    wnsServer(0).LocalPort = 806
    wnsServer(0).Listen

    Тут указываем что будем использовать только протокол TCP и указываем что для приема данных используем порт с номером 806.
    Начинаем писать обработчики событий винсока,
    первое - опишем процесс подключения клиента:
    Private Sub wnsServer_ConnectionRequest(index As Integer, ByVal requestID As Long)
    If index = 0 Then
    Connections = Connections + 1
    Load wnsServer(Connections) 'Load New control
    wnsServer(Connections).LocalPort = 0
    wnsServer(Connections).Accept requested
    end if
    DoEvents
    End Sub

    вот, мы приняли (принимает запросы только сокет с индексом 0) входящие соединение и выделили для его обслуживания отдельный сокет. При этом основной сокет может принять следующего клиента. LocalPort = 0 применено для того чтобы клиенту порт выделился динамически из числа свободных.

    Ну и наконец ядро программы собственно обработка команд поступаемых в сокет:

    Private Sub wnsServer_DataArrival(index As Integer, ByVal bytesTotal As Long)
    Dim hWnd As Long

    hWnd = FindWindow("Winamp v1.x", vbNullString)
    'если к нам подконектились и если у нас присутствует
    'винамп, ждем команду для отправки
    If bytesTotal <> 0 Then
    wnsServer(index).GetData Response 'получаем данные

    'если нет винампа то можно только выходить
    If hWnd = 0 Then
    Exit Sub
    End If
    'обработка поступившей команды
    'Next Track
    If InStr(1, Response, "next", vbTextCompare) <> 0 Then
    SendMessage hWnd, WM_COMMAND, WM_Next, vbNull
    Exit Sub
    End If
    'Previous Track
    If InStr(1, Response, "previous", vbTextCompare) <> 0 Then
    SendMessage hWnd, WM_COMMAND, WM_Previous, vbNull
    Exit Sub
    End If
    'Play
    If InStr(1, Response, "play", vbTextCompare) <> 0 Then
    SendMessage hWnd, WM_COMMAND, WM_Play, vbNull
    Exit Sub
    End If
    'Stop
    If InStr(1, Response, "stop", vbTextCompare) <> 0 Then
    SendMessage hWnd, WM_COMMAND, WM_Stop, vbNull
    Exit Sub
    End If
    'Shuffle
    If InStr(1, Response, "shuffle", vbTextCompare) <> 0 Then
    SendMessage hWnd, WM_COMMAND, WM_Toggle_Shuffle, vbNull
    Exit Sub
    End If
    'Pause/UnPause
    If InStr(1, Response, "pause", vbTextCompare) <> 0 Then
    SendMessage hWnd, WM_COMMAND, WM_Pause_Unpause, vbNull
    Exit Sub
    End If
    'Close
    If InStr(1, Response, "close", vbTextCompare) <> 0 Then
    SendMessage hWnd, WM_COMMAND, WM_Close_Winamp, vbNull
    Exit Sub
    End If
    'Volume inc
    If InStr(1, Response, "+", vbTextCompare) <> 0 Then
    If Response = "+" Then Response = "+1"
    Volume hWnd, CInt(Mid$(Response, InStr(1, Response, "+") + 1, 3)), 1
    Exit Sub
    End If
    'Volume dec
    If InStr(1, Response, "-", vbTextCompare) <> 0 Or
    InStr(1, Response, "0", vbTextCompare) <> 0 Then
    If Mid$(Response, InStr(1, Response, "-") + 1, 3) < "A" Then
    If Response = "-" Then Response = "-1"
    Volume hWnd, CInt(Mid$(Response, InStr(1, Response, "-") + 1, 3)), -1
    End If
    End If
    End If 'bytes
    End Sub

    Метод проверяет загружен ли Винамп и если да то переходит к обработке пришедших данных.

    Рассмотрим чуть подробнее один из блоков проверок приведенного кода:

    If InStr(1, Response, "next", vbTextCompare) <> 0 Then
    SendMessage hWnd, WM_COMMAND, WM_Next, vbNull
    CloseSocket Index
    Exit Sub
    End If

    собственно говоря это простейший вариант проверки поступивший команды и отправка сообщения Винампу. Параметры функции SendMessage: hWnd это хендл на окно винампа определенный в начале метода, WM_COMMAND - системное сообщение показывающие что в последующем параметре функции идет команда, WM_Next - собственно сама команда для окна винампа и последний параметр это дополнительные данные для Винампа или например параметры команды посылаемой окну. После отработки команды закроем сокет (для обеспечения сбалансированной нагрузки) и выйдем из метода.
    Данный код является простейшей проверкой поступивших данных в сокет, в идеале нужно проверять соответствие команды определенному формату.
    Ну и последние несколько вспомогательных методов:
    Посылка команды увеличения или уменьшения (зависимости от параметра incdec) громкости.

    Private Sub Volume(hWnd As Long, percent As Integer, incdec As Long)
    Dim i As Long
    For i = 0 To percent - 1
    Select Case incdec
    Case -1
    SendMessage hWnd, WM_COMMAND, WM_Lower_Volume, vbNull
    Case 1
    SendMessage hWnd, WM_COMMAND, WM_Raise_Volume, vbNull
    End Select
    Next i
    End Sub

    Событие происходит когда клиенту переданы все данные, как только оно возникает, выдерживаем <контрольный> интервал и закрываем сокет.

    Private Sub wnsServer_SendComplete(index As Integer)
    Sleep 1000

    CloseSocket index
    End Sub

    'Само закрытие сокета и выгрузка его из памяти.
    Private Sub CloseSocket(index As Integer)
    wnsServer(index).Close
    Unload wnsServer(Connections)
    Connections = Connections - 1
    DoEvents
    End Sub

    Ну вот, теперь если все сделано без ошибок проект успешно откомпилируется и запустится сервер на ожидающий подключение на 806 порту, транслирующий команды Винампу. Для проверки его работы можно воспользоваться программкой TRCClient из каталога src, любители языка Perl могут воспользоваться управляющим скриптом от моего плагина VbTRC для Винампа.
    Надеюсь это не стало для вас затруднением и на этом закончим первую часть нашей статьи.


    Часть 2. От простой программы к настоящему плагину.
    Ну вот мы освоились с простейшим управлением Винампом через TCP сокет, настало время создать настоящий плагин. Используем наши предыдущие исходники над которыми мы работали как шаблон.

    Распаковываем скаченный GenWrapper.exe, оттуда нам понадобятся файлы GenWrapper.dll и GenWrapper.tlb, а также из каталога Template класс Plugin.cls. Создаем проект ActiveX DLL с именем tcpctrl удаляем из него Class1.cls и добавляем распакованный Plugin.cls. После добавления открываем пункт меню Project->References и добавляем ссылку на GenWrapper.tlb, не забыв также добавить компонент Microsoft Winsock Control. Ядро плагина мы создали, теперь мы можем использовать сокеты так как делали это в нашей первой программе, для любителей WinAPI скажу сразу что в данном случае лучше пользоваться сокетами напрямую через АПИ в этом случае можно будет отказаться от использования формы-контейнера.

    Итак приступим к работе.

    Создадим модуль main.bas, он нам понадобится для того чтобы корректно загрузить форму на которой будут располагаться наши элементы управления. Напрямую форму инициализировать нельзя, т.к. Винамп не поддерживает отображение форм на этапе своей загрузки и инициализации(даже когда она скрыта). В модуль поместим декларации АПИ функций из первой программы, а также добавим одну глобальную переменную Global This As Plugin (Где Plugin это имя нашего класса, его необходимо будет запомнить) для создания указателя на класс плагина.
    Также в модуль добавляем следующий метод для загрузки нашей скрытой формы(ее параметры описываются ниже):

    Public Sub ld()
    Load frmHidden
    End Sub

    Открываем класс Plugin и следуем в метод IRjlWinAmpGenPlugin_Configure он вызывается при нажатии кнопочки Configure в диалоге настроек плагинов Винампа, т.к. в простейшем случае у нас параметров плагина нет, то просто выведем описание плагина: MsgBox App.FileDescription.

    Следующий метод Info() вызывается при нажатии кнопочки "About" в диалоге настроек плагинов Винампа, тут может быть все что вам угодно я например вывожу такой MsgBox:

    MsgBox "Plugin Description: " & vbCrLf & m_Wrapper.Description & vbCrLf & _
    "WinAmp Window Handle: 0x" & Hex(m_Wrapper.HWndParent) _
    , vbInformation, "tcpctrl Information"


    Метод заслуживающий отдельного внимания: IRjlWinAmpGenPlugin_Initialize он вызывается при загрузке винампа и инициализации его списка плагинов, в нем мы поменяем строчку - описание для списка найденных плагинов, например на такую: m_Wrapper.Description = "tcpctrl Plugin v." & App.Major & "." & App.Minor & "." & App.Revision & " (gen_tcpctrl.dll)". Как я уже и говорил напрямую Load frmHidden тут сделать нельзя из-за особенностей работы винампа, поэтому придется сделать косвенный вызов установив при этом ссылку на наш класс: If Not This Is Nothing Then
    Err.Raise vbObjectError + 1, , "Already have a plugin instance"
    Exit Sub
    End If
    Set This = Me
    main.ld

    все, форма загружена и инициализирована.


    В методе IRjlWinAmpGenPlugin_Quit все просто, выгружаем нашу форму Unload frmHidden.

    Вот и все, с классом мы закончили, приступим к созданию формы-контейнера для контролов. Добавляем форму в проект, даем ей имя frmHidden и устанавливаем ее свойство Visible равное False. Помещаем на нее Winsock с именем аналогичным как в первой программе, также помещаем сюда те же константы и переменные.

    Событие Load формы будет выглядеть так:

    Private Sub Form_Load()
    On Error Resume Next
    Me.Visible = False
    wnsServer(0).Protocol = sckTCPProtocol
    wnsServer(0).LocalPort = 806
    wnsServer(0).Listen
    End Sub

    Код для события Unload:
    Private Sub Form_Unload(Cancel As Integer)
    Dim i As Long
    If Connections > 0 Then
    For i = Connections To 1
    wnsServer(i).Close
    Unload wnsServer(Connections)
    Next i
    End If
    DoEvents
    End Sub

    Код в данных местах практически идентичен коду в первом приложении, поступим также и с остальными методами, т.е можно просто скопировать следующие методы и функции: wnsServer_ConnectionRequest, wnsServer_DataArrival, Volume, wnsServer_SendComplete, СloseSocket.
    Компилируем, надеюсь все прошло замечательно? Нет, тогда исправляем ошибки.
    Теперь самое интересное, т.к. Винамп не понимает ActiveX DLL, то мы воспользовались обверткой , которая требует чтобы ее DLL переименовали следующим образом, например наша DLL называется tcpctrl.dll, а класс плагина называется Plugin, то GenWrapper.dll переименовываем так: gen_tcpctrl.Plugin.dll. И наконец обе библиотеки копируем в каталог Plugins Винампа.
    Все поздравляю вы получили простейший рабочий плагин, а также необходимые знания и шаблоны для вашей дальнейшей деятельности.
    Желаю удачи и творческих успехов.

    P.S В своем плагине vbTRC я реализовал дополнительные функции управления Винампом такие как: работа с пультом ДУ от ТВ-Тюнера AverMedia(основные клавиши управления плюс любимые треки и предпрослушка треков), добавил также веб-интерфейс для управления и конфигурирования, простейшие списки доступа, автостарт после загрузки, запись NP и Uptime в файл для вставки в другие программы и другие разные улучшения и нововведения. Базовое ядро я использовал то же, что и приведено в данной статье плюс мои дополнения.

    Наверх

77. Проигрыватель файлов AVI и WAV

    На форме размести компонент Microsoft Multimedia Control 6.0
    И присвой ему имя MMControlCDPlayer.
    Затем, элемент управленияMicrosoft Common Dialog Control 6.0, присвойте ему имя
    cdPlayer И кнопку "открыть". Назови эту кнопку cbFindFile
    Код:

    Private Sub Form_Load()
    MMControlCDPlayer.Notify=False
    MMControlCDPlayer.Wait=True
    MMControlCDPlayer.Shareable=False
    MMControl.CDPlayer.DeviceType="WaveAudio"
    MMControlCDPlayer.DeviceType="AVIVideo"
    End Sub

    Private Sub cbFindFile_Click()
    cdPlayer.ShowOpen
    MMControlCDPlayer.FileName=cdPlayer.FileName
    MMControlCDPlayer.Command="Open"
    MMControlCDPlayer.hWndDisplay=PicView.hWnd
    FormPlayer.picView.SetFocus
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
    MMControlCDPlayer.Command="Close"
    End Sub

    После компиляции нажми открыть, выбери файл и нажми кнопку проиграть.

    Команды управления элемента MMControl:
    Open - открывает файл (устройство) для работы
    Close - закрывает файл (устройство) для работы
    Prev - Переходит в начало предыдущего трека. Если первый трек, или файл, то
    переход осуществляется в начало этого трека, файла.
    Next - Переходит в нач. след. трека.
    Step - Переходит на кадр назад по треку
    Back - Переходит назад
    Pause - Приостанавливает проигрывание
    Play - Проигрывает
    Record - Записывает (Внимание любителям подслушивать!)
    Stop - Останавливает
    Eject - Извлекает носитель (диск)
    Save - Сохраняет
    Seek - Находит позицию

    Наверх

78. Как защитить свою программу от взломщиков - VB

    Автор: Роман Ройтер

    Я решил написать статью о том, как защитить свои программы от взлома. Оговорюсь сразу, практически невозможно создать такую защиту, которая могла бы противостоять опытному взломщику. Но можно попытаться создать такую защиту, которая окажется не по зубам около 90% взломщиков. Все мои идеи по защите основаны на личных наблюдениях, и они могут не быть достоверными, но могут быть полезными против большинства новичков и продвинутых взломщиков. Сейчас я расскажу, какие инструменты использует средний взломщик:

    Во-первых, самый незаменимый инструмент это дебагер, то есть программа, которая позволяет трассировать код чужой программы в живую. Список этих программ варьируется от простого debug'а до продвинутого Soft-Ice'а.

    Во-вторых, программа дизассемблер, которая превращает байты программы в команды ассемблера, тем самым позволяет просмотреть, где и как действует защита. Причем хороший дизассемблер показывает еще и где, какие строки используются в программе. Далее идут всевозможные утилиты, для мониторинга реестра, файлов, определители компилятора и упаковщика, распаковщики, дамперы памяти, генераторы кряков и т.д. Ну и конечно самое главное это мозги взломщика, ведь во многом результат взлома зависит от его сообразительности или идиотизма.

    Короче наша задача, обмануть все эти средства, и самое главное запутать взломщика. И вот как мы это сделаем, я буду идти по приведенному списку и буду объяснять, как защитится от этих средств и от взломщика. Начнем с дебагеров. Вообще-то, многие взломщики недолюбливают VB, потому что он работает благодаря своим библиотекам, и естественно взломщику потребуется очень много времени, чтобы разобраться, где код программы, а где вызовы библиотечных функций (проверено на опыте). Но это случается, только тогда когда программа была скомпилирована в P-код, то есть в псевдокод. Значит первое кольцо защиты, должно быть компилирование в псевдокод. Если вы думаете, что на этом все закончилось, то глубоко ошибаетесь. На свете есть дебагер именуемый P-Code Loader, и он позволяет фильтровать вызовы библиотек и показывать непосредственно код программы. Конечно, не у всех он есть, но если есть, то не стоит слишком надеяться на то, что взломщик откажется от взлома. Поэтому P-код не должен быть главной ставкой программиста. Конечно, с псевдокодом придется таскать кучу библиотек но, как говориться здоровье дороже.

    Иногда программы используют различные приемы против дебагеров, основанные на их свойстве выполнять команды до их фактического выполнения. То есть теоретически можно создать команду, которая отправит дебагер в тартарары, в то время как процессор проигнорирует эту команду из-за системы прогнозирования переходов. Я не умею это делать, поэтому упоминаю это только потому, что однажды встретился с этим приемом.

    Копаясь с АПИ справочнике, я обнаружил замечательную функцию IsDebuggerPresent, которая возвращает True, если в системе стоит системный дебагер типа SofIce'а.

    Функция работает, начиная с NT и Win98:

    Declare Function IsDebuggerPresent Lib "kernel32" () As Long

    Далее, дизассемблеры. В инструментарии взломщика дисассемблер занимает почетно место. Редко взломщик изучает программу без дизассемблера. Дизассемблер дает не только информацию о коде программы, но и показывает имена используемых функций и строковые выражения, использующиеся в программе, а также предоставляет удобную навигацию по вызовам функций и прыжкам. Дизассемблер можно обмануть несколькими путями. С начала, что значит обмануть? Обмануть значить не дать дизассемблеру показать истинный код программы. Этого достигнуть можно следующим способом, программу можно упаковать каким-нибудь упаковщиком типа Aspack, UPX и т.п.

    В этом случае дизассемблер сможет показать разве что код упаковщика и более ничего. Но ведь существуют и распаковщики, поэтому всегда есть вероятность того, что у взломщика найдется подходящий распаковщик, и он получит готовенький код вашей программы. Что бы предотвратить это, нет никаких способов. Разве что пользоваться несколькими упаковщиками или использовать нестандартный, мало кому известный упаковщик. Это серьезно затруднит взломщиков, но особенно настырных это не сможет остановить (ведь теоретически можно найти то место где упаковщик передает программе управление и провести кое-какие манипуляции с кодом).

    Кроме того, есть ещё один способ усложнить взломщику жизнь. Для этого я расскажу, как производится обычный взлом с помощью дизассемблера. Берется жертва, дизассемблируется. Первое на что смотрит взломщик, это какие строки использует программа. Допустим, программа при вводе неверного серийного номера показывает что-то типа "Сорри, но ваш серийник не подходит нам". Взломщик первым делом ищет эту строчку, и если находит, то у него уже появляется точка старта взлома, так как он сможет в большинстве случаев найти, то место где вызывается это сообщение, и соответственно найти место проверки серийника. Значит, наша задача убрать эту возможность для взломщика, то есть убрать все важные сообщения из программы. Это можно сделать, если вынести все сообщения во внешний файл и читать их оттуда во время рантайма. В этом случае дизассемблер покажет разве что имя вызываемого файла. Особенно хорошо загрузить сообщения в начале программы, чтобы взломщик не смог связать их с каким-нибудь важным местом в программе. Ну и я думаю понятно, что самая глупая ошибка это писать прямо в программе правильный пароль. Это сводит на нет всю защиту.

    Есть ещё один способ повысить безопасность программы, правда я не знаю, как это сделать на VB, но смысл состоит в следующем: Надеюсь всем известно о компьютерных регистрах. Также вам известно, что на ассемблере можно вызвать процедуру по адресу находящемуся в регистре. Так вот, дизассемблер не может сказать какое значение будет в регистре в тот или иной момент, поэтому можно вызвать окно с сообщением через регистр, и тогда ни один дизассемблер не сможет сказать, откуда вызвана та или иная функция. Иногда я замечал, что некоторые программы подвешивали дизассемблер при попытке чтения файла. Я не знаю, как это делают, но подозреваю, это происходит из-за несущественно испорченной структуры файла. Как обмануть мониторы реестра и файлов я не знаю, но могу посоветовать спрятать иголку в стогу сена (опять же встречались случаи падения мониторов при запуске некоторых программ). То есть запрятать чтение данных пользователя в кучу ненужных вызовов. Также желательно не давать очевидных имен типа "Code" или "User Name". Вообще чтение данных, является слабым местом любой защиты, так как большинство программистов полагают раз прочтенные данные правильные, то значит, все в порядке и бросают все свои силы на защиту процедуры подсчитывания пароля, забывая о том важном месте, где программа устанавливает, куплена она или нет. Поэтому настоятельно советую не забывать ни об одном месте, где программа делает решающий выбор. Кстати подавляющее число программ использует одну и туже функцию для этой цели. Это оказалось фатальным для этих программ. Нельзя, повторяю ни в коем случае нельзя пользоваться одной и той же функцией. Её легко вычислить и тогда она теряет свой смысл. Помните самая хорошая защита, это защита которую нельзя обнаружить. Желательно пользоваться разными функциями, причем желательно рабочими (чтобы их корректировка привела к не работоспособности программы). Также лучше пользоваться разными переменными, чтобы нельзя было отследить адрес в памяти. Далее сверяйте переменные, и если они не равны, то лучше программе аварийно выйти, чем дать взломщику продолжить работу.

    Поставьте таймер, который проверяет каждые 10 минут право пользователя на работу. Причем если вы используете чистые проверки (без мусора), то взломщик может заметить это, и использовать это. Поэтому проверяйте пользователя в месте с мусором, чтобы ваша проверка не бросалась в глаза. Кстати тот же таймер (или другой с меньшим интервалом) подскажет вам, трассируют ли вашу программу или нет.

    Дело в том, что во время трассирования программы, время в Windows останавливается (системный таймер блокируется), то есть вы засекаете время, и если через 20 секунд оно не сдвинулось, то это означает, что либо материнская плата полетела, либо вашу программу взламывают. Кстати есть смысл хранить данные зашифрованными в реестре или файле, чтобы взломщик не сразу вычислил, где вы храните их. И конечно очень глупо записать где-нибудь строчку типа Registered=0, я думаю, что даже младенец поймет, что надо сделать. Но это можно использовать это как прикрытие, то есть если Registered=1, то можно показать сообщение типа <Попался грязный хакер!!!> и форматнуть ему комп (шутка). Но, в самом деле, идея не плохая.

    Вообще все чем я вам пудрю мозги, рассчитано на то, чтобы запутать взломщика.

    Но это были цветочки, теперь ягодки.

    Как вам известно, проверка пароля самая важная в защите, так как именно ей приходится выдерживать удары тяжелой артиллерии и поэтому у нее должна быть защита, как у банковского сейфа.

    Для начала я объясню, как взломщик начинает взлом. У него обычно есть два выбора начать с начала или с конца. Это значит, что он может начать исследовать программу с самого ввода пароля или начать с того момента, когда программа показывает сообщение о неверном пароле. У обоих методов есть свои плюсы и минусы. Если идти с начала, то можно узнать, где хранится введенное имя и пароль, и что с ним делают. Но с другой стороны приходится фильтровать кучу мусора, чтобы найти что-то стоящее. Если идти с конца, то есть шанс посмотреть код вышестоящий вызова сообщения или если это отдельная процедура выйти к месту проверки. Но и здесь есть свои трудности, иногда программа не использует стандартные функции показа сообщений, поэтому её нельзя поймать, или после показа сообщения программа не возвращается туда, откуда оно вызывалось, и поэтому тоже не узнаешь, что там случилось. Наша задача сделать так чтобы взломщик не понял где вообще проверка и не смог её подсмотреть. Так как в большинстве случаев взломщики идут первым путем, то и мы пойдем их путем. Я не вижу способа прочитать имя и пароль без вызова hmemcpy, эта стандартная функция Windows которая вызывается всюду без нашего разрешения, так что здесь у взломщика есть преимущество. Но кто сказал, что нам обязательно проверять пароль, тут же не отходя от кассы. Мы можем сказать <так и так учтем вашу просьбу, подождите ответа> и спокойно записать данные где-нибудь, и тут же использовать вышеописанный таймер и если нас просматривали, то выходим без лишних сообщений. Если нет то, где-нибудь через 20 кликов мышки, проверить тихо мирно чего нам подсунули.

    Желательно закодировать и имя и пароль по какому-нибудь крепкому алгоритму и сверить результаты. Причем сверять надо по букве, чередуя с мусором, а то программа типа Smartcheck запишет <сверялись такие и такие символы> и если их не спрятать, то можно догадаться, где это творится. Кстати если результат не верный то не надо ругаться, можно спокойно продолжать работу, так как взломщик может подловить на этом сообщении программу. И как я уже говорил, используйте разные функции всюду.

    Кстати, я недавно прочитал книжку по хакингу, крэкингу, и фрикингу. Так вот там автор утверждал, что надежность защиты определяется надежностью её самого слабого звена. Это утверждение применимо и в нашем деле. Насколько я понимаю самая слабая точка в защите, это то место где программа решает как её вести себя дальше, то есть купили её или нет. Это является очень критической точкой, так как большинство начинающих и ленивых взломщиков, часто трассируют огромные куски кода ради вышеописанного места в программе. Значит надо внимательно следить за этим, и лучше завести несколько дублей переменной и сверять их.

    Иногда программы используют CRC, то есть число уникальное для каждой программы которое определяет её целостность. Его можно хранить где-нибудь и подсчитывать заново каждый раз, и если числа не совпадают, то или на компе вирус или взломщик копался в коде программы. Если копался то лучше выйти. И ещё лучше выйти без сообщений. Я советую вообще воздержаться от каких либо сообщений по поводу защиты. А все потому что нельзя давать взломщику хоть малейший шанс подловить программу на чём либо. Функций для показа сообщений не так уж и много и они довольно известны, а вот функция, которая используется для выхода программы, не очень известна, и есть шанс, что взломщик не поймет что делать.

    Я перечитал то что написал и понял что так и не объяснил что, значит, подловить программу. Сейчас объясню. Программы бывают большими, и защита бывает тоже не маленькая. Поэтому чтобы не ворочать зря горы, взломщики используют точки останова. То есть в VB допустим, чтобы показать сообщение msgbox используется функция rtcMsgBox, взломщик может сказать дебагеру (если знает эту функцию), останови программу, если она вызовет rtcMsgBox. И когда ваша программа возмутится из-за неверного пароля, взломщик сможет начать свое исследование гораздо ближе к важному месту защиты, чем надо. Поэтому я считаю, что лучше всего вообще не давать взломщику лишнего шанса, проникнуть в программу.

    Часто взломщики не просто банально меняют нужный код, а исследуют алгоритм создания пароля и пишут генераторы серийных номеров. Поэтому необходимо хорошо защитить этот алгоритм. Желательно использовать какой-нибудь криптостойкий алгоритм типа RSA или MD5. В Интернете можно найти методы работы с ними. Также, чтобы затруднить взломщика желательно разбить генерирование пароля на несколько этапов, разбить по функциям (желательно рабочим, чтобы чаще вызывались не только из-за пароля), и в промежутках между вызовами этих функций проверять на исследование вашу программу. И ещё помните что когда ваша программа под дебагером, она не может выполнять параллельно несколько вещей, то есть если она проверит на наличие дебагера, взломщик может это заметить и выключить. Поэтому не давайте никому этого шанса, относитесь к каждому пользователю как к потенциальному взломщику. Ну вот и все, что я хотел рассказать

    Я написал эту статью по нескольким причинам:

    Мне захотелось поделиться с людьми своими знаниями. Мне нечего было делать. Мне надоело смотреть, как все кому не лень издеваются над слабыми защитами программистов, которые используют схемы защит 20-летней давности, и я решил по мере своих сил исправить положение. Я заметил, что когда объясняешь кому-нибудь, что-то, то начинаешь сам лучше понимать. Все приведенные методы используйте, как хотите. Ну и конечно тому, кому лень защищать свое детище, или он отмахивается тем, что программу все равно сломают, не стоило даже и читать эту статью. Я буду рад любым комментариям, замечаниям и любым отзывам. Вы можете прислать их мне на noobsaibott@hotmail.com.
    Наверх

79. Как запустить Screen saver? - VB


    Очередной совет на тему: как запустить Screen saver. Всё очень просто. Объявите функцию SendMessage и две константы: WM_SYSCOMMAND и SC_SCREENSAVE. Вот собственно и всё. Осталось только в нужный момент вызвать эту функцию и заставка запустится!

    Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Private Const WM_SYSCOMMAND = &H112&
    Private Const SC_SCREENSAVE = &HF140&

    Sub Start()
    Dim Ret As Long
    Ret = SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
    End Sub

    Наверх

80. Использование специальной клавиши клавиатуры - VB

    На многих клавиатурах есть специальная кнопка со значком WINDOWS. Данный пример
    с помощью API функции эмулирует нажатие на эту клавишу и дополнительную клавишу,
    вызывая определенную процедуру в системе.

    В событии Form_Load() показан один пример: эмулирование нажатие клавиши ПУСК. В
    качестве параметра функции Launch вы можете использовать любую константу из
    StartMenuItems.

    Private Declare Sub keybd_event Lib "User32" (ByVal bVk As Byte, ByVal bScan As
    Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Const VK_LWIN = &H5B, KEYEVENTF_KEYUP = &H2, VK_APPS = &H5D

    Public Enum StartMenuItems
    strtExplorer 'запустить ПРОВОДНИК
    strtFind 'окно "ПОИСК ФАЙЛОВ"
    strtMinimize 'минимизировать все окна
    strtRun 'вызвать окно "ЗАПУСК ПРОГРАММ" (ПУСК | ВЫПОЛНИТЬ...)
    strtStartMenu 'эмулировать нажатие клавиши ПУСК
    strtHelp 'вызвать справочную систему
    End Enum

    Public Sub Launch(func As StartMenuItems)
    Dim VK_ACTION As Long
    Select Case func
    Case strtExplorer: VK_ACTION = &H45
    Case strtFind: VK_ACTION = &H46
    Case strtMinimize: VK_ACTION = &H4D
    Case strtRun: VK_ACTION = &H52
    Case strtStartMenu: VK_ACTION = &H5B
    Case strtHelp: VK_ACTION = &H70
    End Select
    Call keybd_event(VK_LWIN, 0, 0, 0)
    Call keybd_event(VK_ACTION, 0, 0, 0)
    Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
    End Sub

    Private Sub Form_Load()
    Call Launch(strtStartMenu)
    End Sub

    Наверх

Далее>>

Hosted by uCoz