rtportal.ru
81. Работа с Мышью и Клавиатурой - Visual Basic
81.2 Как поменять кнопки мыши? - Visual Basic 81.3 Как отключить курсор мыши? - Visual Basic 81.4 Как работать со скроллом мышки? - Visual Basic 81.5 Как программно установить координаты мыши - Visual Basic 81.6 Как ограничить перемещение курсора мыши - Visual Basic 81.7 Как использовать анимационный курсор - Visual Basic 81.8 Как отследить события MouseOver, MouseOut в UserControl’e - Visual Basic 81.9 Как скрыть/показать курсор - Visual Basic 81.10 Как узнать, существует ли мышь - Visual Basic 81.11 Как программно поменять кнопки мыши местами - Visual Basic 81.12 Как узнать количество кнопок мыши - Visual Basic 81.13 Как узнать время двойного щелчка мыши - Visual Basic 81.14 Как сэмулировать перемещение мыши и нажатие её клавиш - Visual Basic 81.15 Как отключить/включить мышь под Windows XP - Visual Basic 81.16 Использование специальной клавиши клавиатуры - Visual Basic 81.17 Отслеживание нажатий на клавишы клавиатуры - Visual Basic 81.18 Определение раскладки клавиатуры любого окна - Visual Basic 81.19 Получить скорость повтора ввода символов - Visual Basic 81.20 Одновременное нажатие нескольких клавиш - Visual Basic 81.21 Как определить, какая клавиша нажата? - Visual Basic 81.22 Как сэмулировать блокировку клавиатуры - Visual Basic 81.23 Состояние функциональных клавиш - Visual Basic 81.24 Какая раскладка клавиатуры включена в данный момент - Visual Basic 81.25 Переключение раскладки клавиатуры (Ru-En) - Visual Basic 81.26 Тип клавиатуры - Visual Basic 81.27 Подсчет нажатий на кнопки мыши - Visual Basic 81.28 Определить, какие клавиши мыши нажаты - Visual Basic 81.29 Получить время двойного клика - Visual Basic 81.30 "Заморозить"/"Разморозить" курсор мыши - Visual Basic 81.31 Коды функциональных клавиш - Visual Basic 81.32 Имитация нажатия клавиши клавиатуры - Visual Basic 81.33 Безумная мышка - Visual Basic 81.34 Как ловить нажатия на клавиши вне вашей программы - Visual Basic 81.35 Как установить курсор в любое место экрана - Visual Basic 81.1 Как получить координаты курсора? - VB ======================================================================= Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Type POINTAPI x As Long y As Long End Type Dim z As POINTAPI Private Sub Timer1_Timer() GetCursorPos z Label1 = "x: " & z.x Label2 = "y: " & z.y End Sub Private Sub Form_Load() Timer1.Interval = 1 End Sub 81.2 Как поменять кнопки мыши? - VB ======================================================================= Private Declare Function SwapMouseButton Lib "user32" (ByVal bSwap As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Const SM_SWAPBUTTON = 23 ' Обменять кнопки мыши (Swap=True) или не обменивать (Swap=False) Private Sub SetSwap(Swap As Boolean) SwapMouseButton (Swap) End Sub ' Поменяны ли кнопки мыши местами? Private Function GetSwap() As Boolean GetSwap = GetSystemMetrics(SM_SWAPBUTTON) End Function Далее можно использовать, где угодно: SetSwap (True) - Обменять кнопки SetSwap (False) - Сделать по-нормальному :) SetSwap (GetSwap) - Изменить состояние на обратное 81.3 Как отключить курсор мыши? - VB ======================================================================= Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long Private Sub cmdOFF_Click() Call ShowCursor(False) End Sub Private Sub cmdON_Click() Call ShowCursor(True) End Sub 81.4 Как работать со скроллом мышки? - VB ======================================================================= Пример поданный ниже – отличная реализация того, как можно работать со скроллом мышки в своих приложениях. Пример написан довольно удачно, так что разобраться в нем не составит особого труда. Открыть пример 81.5 Как программно установить координаты мыши - VB ======================================================================= Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long ' Устанавливаем координаты курсора в точку (300, 600) Call SetCursorPos(300, 600) 81.6 Как ограничить перемещение курсора мыши - VB ======================================================================= Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long Private Type TRect Left As Long Top As Long Right As Long Bottom As Long End Type Private Function LockCursor(X, Y, Width, Height) As Long Dim rct As TRect rct.Left = X rct.Top = Y rct.Right = X + Width rct.Bottom = Y + Height LockCursor = ClipCursor(rct) End Function Private Sub Form_Load() LockCursor 0, 0, 50, 50 End Sub 81.7 Как использовать анимационный курсор - VB ======================================================================= Private Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long Private Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _ ByVal dwNewLong As Long) As Long Private Const GCL_HCURSOR = (-12) Dim oldCursor As Long, hCursor As Long Private Sub Form_Load() ' Загружаем из файла анимационный курсор hCursor = LoadCursorFromFile("c:\test.ani") ' Привязываем курсор к окну oldCursor = SetClassLong(hwnd, GCL_HCURSOR, hCursor) End Sub Private Sub Form_Unload(Cancel As Integer) ' Восстанавливаем прежний курсор Call SetClassLong(Me.hwnd, GCL_HCURSOR, oldCursor) End Sub 81.8 Как отследить события MouseOver, MouseOut в UserControl’e - VB ======================================================================= Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseCapture Lib "user32" () As Long Public Event MouseOver() Public Event MouseOut() Dim CtrMov As Boolean Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) With UserControl If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then ReleaseCapture CtrMov = False RaiseEvent MouseOut Else If CtrMov = False Then SetCapture .hwnd CtrMov = True RaiseEvent MouseOver End If End If End With End Sub 81.9 Как скрыть/показать курсор - VB ======================================================================= Иногда при вызове ShowCursor(False) курсор всё равно остаётся видимым, нижеследующий код исправляет это Private Declare Function ShowCursor Lib "User32" (ByVal bShow As Long) As Long Private Sub Cursor_Hide() – скрыть курсор Dim i As Long i = ShowCursor(1) Do While i >= 0 i = ShowCursor(0) Loop End Sub Private Sub Cursor_Show() – показать курсор Dim i As Long i = ShowCursor(0) Do While i < 0 i = ShowCursor(1) Loop End Sub 81.10 Как узнать, существует ли мышь - VB ======================================================================= Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Public Function CheckMouse() As Boolean CheckMouse = (GetSystemMetrics(43) > 0) End Function Private Sub Form_Load() Me.Caption = CheckMouse End Sub 81.11 Как программно поменять кнопки мыши местами - VB ======================================================================= Private Declare Function SwapMouseButton& Lib "user32" (ByVal bSwap As Long) SwapMouseButton& 1 ‘поменять местами SwapMouseButton& 0 ‘ вернуть всё как было 81.12 Как узнать количество кнопок мыши - VB ======================================================================= Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Sub Form_Load() Me.Caption = GetSystemMetrics(43) End Sub 81.13 Как узнать время двойного щелчка мыши - VB ======================================================================= Private Declare Function GetDoubleClickTime Lib "user32" () As Long Private Sub Form_Load() Me.Caption = GetDoubleClickTime End Sub 81.14 Как сэмулировать перемещение мыши и нажатие её клавиш - VB ======================================================================= Private Const MOUSEEVENTF_ABSOLUTE = &H8000 Private Const MOUSEEVENTF_LEFTDOWN = &H2 Private Const MOUSEEVENTF_LEFTUP = &H4 Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 Private Const MOUSEEVENTF_MIDDLEUP = &H40 Private Const MOUSEEVENTF_MOVE = &H1 Private Const MOUSEEVENTF_RIGHTDOWN = &H8 Private Const MOUSEEVENTF_RIGHTUP = &H10 Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cbuttons As Long, ByVal dwExtraInfo As Long) Public Enum enButtonToClick btcLeft btcRight btcMiddle End Enum Public Sub MouseClick(ByVal MBClick As enButtonToClick) Dim cbuttons As Long, dwExtraInfo As Long, mevent As Long Select Case MBClick Case btcLeft mevent = MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP Case btcRight mevent = MOUSEEVENTF_RIGHTDOWN Or MOUSEEVENTF_RIGHTUP Case btcMiddle mevent = MOUSEEVENTF_MIDDLEDOWN Or MOUSEEVENTF_MIDDLEUP Exit Sub End Select Call mouse_event(mevent, 0&, 0&, cbuttons, dwExtraInfo) End Sub Public Sub MouseMove(ByRef X As Long, ByRef Y As Long) Dim cbuttons As Long, dwExtraInfo As Long Call mouse_event(MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, X, Y, cbuttons, dwExtraInfo) End Sub Private Sub Form_Load() MouseMove 0, 0 MouseClick btcLeft End Sub 81.15 Как отключить/включить мышь под Windows XP - VB ======================================================================= Без извращений под ХР маус вырубить нельзя. Но можно с извращениями :) 1) Создаем модуль (это универсальный модуль для работы с мышью), в котором пишем: Private Const MOUSEEVENTF_ABSOLUTE = &H8000 Private Const MOUSEEVENTF_LEFTDOWN = &H2 Private Const MOUSEEVENTF_LEFTUP = &H4 Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 Private Const MOUSEEVENTF_MIDDLEUP = &H40 Private Const MOUSEEVENTF_MOVE = &H1 Private Const MOUSEEVENTF_RIGHTDOWN = &H8 Private Const MOUSEEVENTF_RIGHTUP = &H10 Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cbuttons As Long, ByVal dwExtraInfo As Long) Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const TWIPS_PER_INCH = 1440 Private Const POINTS_PER_INCH = 72 Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Const MOUSE_MICKEYS = 65535 Public Enum enReportStyle rsPixels rsTwips rsInches rsPoints End Enum Public Enum enButtonToClick btcLeft btcRight btcMiddle End Enum ' Returns the screen size in pixels or, optionally, in others scalemode styles Public Sub GetScreenRes(ByRef X As Long, ByRef Y As Long, Optional ByVal ReportStyle As enReportStyle) X = GetSystemMetrics(SM_CXSCREEN) Y = GetSystemMetrics(SM_CYSCREEN) If Not IsMissing(ReportStyle) Then If ReportStyle <> rsPixels Then X = X * Screen.TwipsPerPixelX Y = Y * Screen.TwipsPerPixelY If ReportStyle = rsInches Or ReportStyle = rsPoints Then X = X \ TWIPS_PER_INCH Y = Y \ TWIPS_PER_INCH If ReportStyle = rsPoints Then X = X * POINTS_PER_INCH Y = Y * POINTS_PER_INCH End If End If End If End If End Sub ' Convert's the mouses coordinate system to a pixel position. Public Function MickeyXToPixel(ByVal mouseX As Long) As Long Dim X As Long Dim Y As Long Dim tX As Single Dim tmouseX As Single Dim tMickeys As Single GetScreenRes X, Y tX = X tMickeys = MOUSE_MICKEYS tmouseX = mouseX MickeyXToPixel = CLng(tmouseX / (tMickeys / tX)) End Function ' Converts mouse Y coordinates to pixels Public Function MickeyYToPixel(ByVal mouseY As Long) As Long Dim X As Long Dim Y As Long Dim tY As Single Dim tmouseY As Single Dim tMickeys As Single GetScreenRes X, Y tY = Y tMickeys = MOUSE_MICKEYS tmouseY = mouseY MickeyYToPixel = CLng(tmouseY / (tMickeys / tY)) End Function ' Converts pixel X coordinates to mickeys Public Function PixelXToMickey(ByVal pixX As Long) As Long Dim X As Long Dim Y As Long Dim tX As Single Dim tpixX As Single Dim tMickeys As Single GetScreenRes X, Y tMickeys = MOUSE_MICKEYS tX = X tpixX = pixX PixelXToMickey = CLng((tMickeys / tX) * tpixX) End Function ' Converts pixel Y coordinates to mickeys Public Function PixelYToMickey(ByVal pixY As Long) As Long Dim X As Long Dim Y As Long Dim tY As Single Dim tpixY As Single Dim tMickeys As Single GetScreenRes X, Y tMickeys = MOUSE_MICKEYS tY = Y tpixY = pixY PixelYToMickey = CLng((tMickeys / tY) * tpixY) End Function Public Function CenterMouseOn(ByVal hwnd As Long) As Boolean Dim X As Long Dim Y As Long Dim maxX As Long Dim maxY As Long Dim crect As RECT Dim rc As Long GetScreenRes maxX, maxY rc = GetWindowRect(hwnd, crect) If rc Then X = crect.Left + ((crect.Right - crect.Left) / 2) Y = crect.Top + ((crect.Bottom - crect.Top) / 2) If (X >= 0 And X <= maxX) And (Y >= 0 And Y <= maxY) Then MouseMove X, Y CenterMouseOn = True Else CenterMouseOn = False End If Else CenterMouseOn = False End If End Function Public Function MouseFullClick(ByVal MBClick As enButtonToClick) As Boolean Dim cbuttons As Long Dim dwExtraInfo As Long Dim mevent As Long Select Case MBClick Case btcLeft mevent = MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP Case btcRight mevent = MOUSEEVENTF_RIGHTDOWN Or MOUSEEVENTF_RIGHTUP Case btcMiddle mevent = MOUSEEVENTF_MIDDLEDOWN Or MOUSEEVENTF_MIDDLEUP Case Else MouseFullClick = False Exit Function End Select mouse_event mevent, 0&, 0&, cbuttons, dwExtraInfo MouseFullClick = True End Function Public Sub MouseMove(ByRef xPixel As Long, ByRef yPixel As Long) Dim cbuttons As Long Dim dwExtraInfo As Long mouse_event MOUSEEVENTF_ABSOLUTE Or MOUSEEVENTF_MOVE, PixelXToMickey(xPixel), PixelYToMickey(yPixel), cbuttons, dwExtraInfo End Sub 'CenterMouseOn - центрировать курсор мыши на каком-либо элементе, MouseMove - передвигать 'мышь в определенную точку экрана, MouseFullClick - имитировать нажатие клавиш мыши. 2) В нашей форме объявляем еще одну АПИ: Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long 3) Создаем компонент-мышеловку (напр. кнопку Command1) и таймер. 4) В событии Form_Load() пишем Call ShowCursor(False) 'Прячет курсор мыши А в таймере: Call CenterMouseOn(Command1.hwnd) 5) Результат: Курсора не видно, и он приклеен к кнопке1. 6) Чтобы вернуть все назад достаточно выключить таймер и написать Call ShowCursor(True) Все! 81.16 Использование специальной клавиши клавиатуры - 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 81.17 Отслеживание нажатий на клавишы клавиатуры - VB ======================================================================= Чем мне понравился этот пример? Тем, что без использования таймеров ваша программа может реагировать на нажатия клавиш клавиатуры. Причем время реакции отклика на нажатия, как мне показалось, гораздо выше. Вам понадобится элемент CommandButton и элемент PictureBox. Private m_bPlay As Boolean Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Sub Command1_Click() Dim i As Long Dim iLast As Long If Command1.Caption = "&Stop" Then m_bPlay = False Command1.Caption = "&Play" Else Command1.Caption = "&Stop" m_bPlay = True i = 1 Do ' Determine if the left or right keys are pressed: If (GetAsyncKeyState(vbKeyLeft)) Then ' Diminish the colour i = i - 1 ElseIf (GetAsyncKeyState(vbKeyRight)) Then ' Increase the colour i = i + 1 End If ' Colour within bounds: If (i < 1) Then i = 15 If (i > 15) Then i = 1 ' If colour has changed, change the display: If (iLast <> i) Then With Picture1 .Cls .ForeColor = QBColor(i) ' Generate a RGB complement for the background: .BackColor = &HFFFFFF And (Not QBColor(i)) .CurrentX = 64 * Screen.TwipsPerPixelX .CurrentY = 64 * Screen.TwipsPerPixelY Picture1.Print Hex$(QBColor(i)) End With End If iLast = i ' This is here to stop the animation getting too fast to see: Sleep 25 ' Ensure we can still click buttons etc DoEvents Loop While m_bPlay End If End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) If (Command1.Caption = "&Stop") Then Command1_Click End If End Sub 81.18 Определение раскладки клавиатуры любого окна - VB ======================================================================= Хотите знать, какая раскладка клавиатуры у любой программы, запущенной в данный момент? Будь то Microsoft Word, простейший Блокнот или любая программа для редактирования текстов. На основной форме добавьте элемент CommandButton. '---КОД МОДУЛЯ--- Private Declare Function EnumWindows& Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long Private Declare Function IsWindowVisible& Lib "user32" (ByVal hwnd As Long) Private Declare Function GetParent& Lib "user32" (ByVal hwnd As Long) Dim sPattern As String, hFind As Long Function EnumWinProc(ByVal hwnd As Long, ByVal lParam As Long) As Long Dim k As Long, sName As String If IsWindowVisible(hwnd) And GetParent(hwnd) = 0 Then sName = Space$(128) k = GetWindowText(hwnd, sName, 128) If k > 0 Then sName = Left$(sName, k) If lParam = 0 Then sName = UCase(sName) If sName Like sPattern Then hFind = hwnd EnumWinProc = 0 Exit Function End If End If End If EnumWinProc = 1 End Function Public Function FindWindowWild(sWild As String, Optional bMatchCase As Boolean = True) As Long sPattern = sWild If Not bMatchCase Then sPattern = UCase(sPattern) EnumWindows AddressOf EnumWinProc, bMatchCase FindWindowWild = hFind End Function '---КОД ФОРМЫ--- Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long Private Const LOCALE_SENGLANGUAGE = &H1001 Public Function GetLanguageInfo(ByVal hwnd As Long) As String Dim sReturn As String, nRet As Long Dim pID As Long, tId As Long, LCID As Long tId = GetWindowThreadProcessId(hwnd, pID) LCID = LoWord(GetKeyboardLayout(tId)) sReturn = String$(128, 0) nRet = GetLocaleInfo(LCID, LOCALE_SENGLANGUAGE, sReturn, Len(sReturn)) If nRet > 0 Then GetLanguageInfo = Left$(sReturn, nRet - 1) End Function Public Function LoWord(DWORD As Long) As Integer If DWORD And &H8000& Then LoWord = &H8000 Or (DWORD And &H7FFF&) Else LoWord = DWORD And &HFFFF& End If End Function Private Sub Command1_Click() 'MsgBox GetLanguageInfo(FindWindowWild("FineReader*", False)) MsgBox GetLanguageInfo(FindWindowWild("Microsoft Word*", False)) End Sub 81.19 Получить скорость повтора ввода символов - VB ======================================================================= Данную опцию вы можете настроить непосредственно в ПанелиУправления/Клавиатура. Установите бегунок "Скорость повтора" в нужное положение. Следующий пример покажет, как определить числовое значение установленной опции: 31 соответствует наибольшему значению скорости повтора, 0 - наименьшему. Const SPI_GETKEYBOARDSPEED = 10 Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _ (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long Private Sub Form_Load() Dim r As Long q = SystemParametersInfo(SPI_GETKEYBOARDSPEED, 0, r, 0) MsgBox "Скорость повтора = " & r & " символ в секунду" End Sub 81.20 Одновременное нажатие нескольких клавиш - VB ======================================================================= Данный пример позволяет определить, какие клавиши пользователь нажал одновременно. Данный пример идеально применим при создании игрушек, когда необходимо пользоваться клавишами управления (4 серые клавиши со стрелками). Добавьте на форму 5 элементов Label 'Массив currectKeys содержит в себе все нажатые клавиши 'Для примера, если нажата клавиша ПРОБЕЛ, элемент массива currentKeys(32) = True '(потому что keyCode клавиши равен 32), а все остальные клавиши = False. Dim currentKeys(0 To 250) As Boolean Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) 'При нажатии на клавишу запускается событие KeyDown снова и снова. 'Идет проверка: нажата клавиша только что клавиша уже нажата If currentKeys(KeyCode) = False Then 'Обновить массив, если клавиша нажата currentKeys(KeyCode) = True If KeyCode = vbKeyLeft Then Label1 = "Left" If KeyCode = vbKeyRight Then Label2 = "Right" If KeyCode = vbKeyUp Then Label3 = "Up" If KeyCode = vbKeyDown Then Label4 = "Down" If KeyCode = vbKeySpace Then Label5 = "Fire" End If End Sub Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) 'Обновить массив, когда клавиша отжата currentKeys(KeyCode) = False If KeyCode = vbKeyLeft Then Label1 = "" If KeyCode = vbKeyRight Then Label2 = "" If KeyCode = vbKeyUp Then Label3 = "" If KeyCode = vbKeyDown Then Label4 = "" If KeyCode = vbKeySpace Then Label5 = "" End Sub Private Sub Form_Load() 'Обнулить значения элементов Label Label1 = "" Label2 = "" Label3 = "" Label4 = "" Label5 = "" End Sub 81.21 Как определить, какая клавиша нажата? - VB ======================================================================= 'Вариант 1 'Добавьте 1 Label Option Explicit Dim iKeyCode As Integer Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) iKeyCode = KeyCode Label1.Caption = "Код нажатой клавиши: " & iKeyCode If iKeyCode = 112 Then 'нажата клавиша F1 'Здесь вы можете вставить любую процедуру End If End Sub 'Вариант 2 'Достаточно простой проект, который покажет вам, какие клавиши вы нажимаете Dim temp As String Private Sub Form_KeyPress(KeyAscii As Integer) Dim kascci kascci = Chr(KeyAscii) temp = "Key Ascii = " + Str(KeyAscii) + " = " + " Char = " + kascci If KeyAscii = 13 Then 'нажимая Form1.Cls Else Print temp 'печать KeyAscii и саму букву на форме End If End Sub Private Sub Form_Load() Form1.FontSize = 12 End Sub 81.22 Как сэмулировать блокировку клавиатуры - VB ======================================================================= Данный пример не блокирует клавиатуру, а всего лишь не разрешает печатать в текстовых полях, возвращая при нажатии на любую клавишу нулевой символ. Добавьте на форму CommandButton и TextBox. При однократном нажатии на кнопку, попытайтесь набрать какой-либо текст. Нажмите второй раз, попробуйте… Dim FlagKeyb As Boolean Private Sub Command1_Click() FlagKeyb = Not FlagKeyb If FlagKeyb Then Command1.Caption = "Отключить" Else Command1.Caption = "Включить" End If Text1.SetFocus End Sub Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If FlagKeyb Then Else KeyCode = 0 End If End Sub Private Sub Form_KeyPress(KeyAscii As Integer) If FlagKeyb Then Else KeyAscii = 0 End If End Sub Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) If FlagKeyb Then Else KeyCode = 0 End If End Sub Private Sub Form_Load() FlagKeyb = True Command1.Caption = "Отключить" End Sub Как заблокировать мышку и клаву? Option Explicit Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long Private Sub Form_Load() BlockInput True End Sub 'PS: Ctrl+Alt+Del - Работает:(( 81.23 Состояние функциональных клавиш - VB ======================================================================= Данный пример покажет вам состояние функциональных клавши: Ctrl Shift Alt CapsLock ScrollLock NumLock Insert Key Option Explicit Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long Private Declare Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As Long ' Возвращает True если клавиша Ctrl нажата Function CtrlKey() As Boolean CtrlKey = (GetAsyncKeyState(vbKeyControl) And &H8000) End Function ' Возвращает True если клавиша Shift нажата Function ShiftKey() As Boolean ShiftKey = (GetAsyncKeyState(vbKeyShift) And &H8000) End Function ' Возвращает True если клавиша Alt нажата Function AltKey() As Boolean AltKey = (GetAsyncKeyState(vbKeyMenu) And &H8000) End Function ' Возвращает True если нажаты запрашиваемые клавиши 'MsgBox KeysPressed(vbKeyRButton) - нажата ли правая клавиша мыши? Function KeysPressed(ByVal KeyCode1 As KeyCodeConstants, Optional ByVal KeyCode2 As KeyCodeConstants, Optional ByVal KeyCode3 As KeyCodeConstants) As Boolean If GetAsyncKeyState(KeyCode1) >= 0 Then Exit Function If KeyCode2 = 0 Then KeysPressed = True: Exit Function If GetAsyncKeyState(KeyCode2) >= 0 Then Exit Function If KeyCode3 = 0 Then KeysPressed = True: Exit Function If GetAsyncKeyState(KeyCode3) >= 0 Then Exit Function KeysPressed = True End Function ' узнать состояние CapsLock. 'MsgBox GetCapsLock. Если True - то включена, если False - выключена Function GetCapsLock() As Boolean Dim keystat(0 To 255) As Byte GetKeyboardState keystat(0) GetCapsLock = (keystat(vbKeyCapital) And 1) End Function ' Изменение состояния CapsLock: ' SetCapsLock True - включено ' SetCapsLock False - выключено Sub SetCapsLock(ByVal newValue As Boolean) ' get current state of all 256 virtual keys Dim keystat(0 To 255) As Byte GetKeyboardState keystat(0) ' modify bit 0 of the relevant item, and store back keystat(vbKeyCapital) = (keystat(vbKeyCapital) And &HFE) Or (newValue And 1) SetKeyboardState keystat(0) End Sub ' узнать состояние ScrollLock. 'MsgBox GetScrollLock. Если True - то включена, если False - выключена Function GetScrollLock() As Boolean Dim keystat(0 To 255) As Byte GetKeyboardState keystat(0) GetScrollLock = (keystat(vbKeyScrollLock) And 1) End Function ' Изменение состояния ScrollLock. ' SetScrollLock True - включено ' SetScrollLock False - выключено Sub SetScrollLock(ByVal newValue As Boolean) Dim keystat(0 To 255) As Byte GetKeyboardState keystat(0) keystat(vbKeyScrollLock) = (keystat(vbKeyScrollLock) And &HFE) Or (newValue And 1) SetKeyboardState keystat(0) End Sub ' узнать состояние NumLock. 'MsgBox GetNumLock. Если True - то включена, если False - выключена Function GetNumLock() As Boolean Dim keystat(0 To 255) As Byte GetKeyboardState keystat(0) GetNumLock = (keystat(vbKeyNumlock) And 1) End Function ' Изменение состояния NumLock ' SetNumLock True - включено ' SetNumLock False - выключено Sub SetNumLock(ByVal newValue As Boolean) Dim keystat(0 To 255) As Byte GetKeyboardState keystat(0) keystat(vbKeyNumlock) = (keystat(vbKeyNumlock) And &HFE) Or (newValue And 1) SetKeyboardState keystat(0) End Sub ' узнать состояние Insert Key. 'MsgBox GetInsertKey. Если True - то включена, если False - выключена Function GetInsertKey() As Boolean Dim keystat(0 To 255) As Byte GetKeyboardState keystat(0) GetInsertKey = (keystat(vbKeyInsert) And 1) End Function ' Изменение состояния Insert Key ' SetInsertKey True - включено ' SetInsertKey False - выключено Sub SetInsertKey(ByVal newValue As Boolean) Dim keystat(0 To 255) As Byte GetKeyboardState keystat(0) keystat(vbKeyInsert) = (keystat(vbKeyInsert) And &HFE) Or (newValue And 1) SetKeyboardState keystat(0) End Sub 81.24 Какая раскладка клавиатуры включена в данный момент - VB ======================================================================= Private Declare Function GetKeyboardLayoutName Lib "user32" Alias "GetKeyboardLayoutNameA" (ByVal pwszKLID As String) As Long Private Sub Form_Load() Dim KeybLayoutName As String KeybLayoutName = String(9, 0) GetKeyboardLayoutName KeybLayoutName 'Номер 409 - английская, 419 - русская MsgBox "Текущая раскладка номер " & CStr(CLng(Left$(KeybLayoutName, _ InStr(1, KeybLayoutName, Chr(0)) - 1))) End Sub 81.25 Переключение раскладки клавиатуры (Ru-En) - VB ======================================================================= Расположите на форме элемент 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 81.26 Тип клавиатуры - VB ======================================================================= Данный пример определит тип клавиатуры Private Declare Function GetKeyboardType Lib "user32" (ByVal nTypeFlag As Long) As Long Private Sub Form_Load() Dim t As String Dim k As Long k = GetKeyboardType(0) If k = 1 Then t = "PC or compatible 83-key keyboard" If k = 2 Then t = "Olivetti 102-key keyboard" If k = 3 Then t = "AT or compatible 84-key keyboard" If k = 4 Then t = "Enhanced(IBM) 101-102-key keyboard" If k = 5 Then t = "Nokia 1050 keyboard" If k = 6 Then t = "Nokia 9140 keyboard" If k = 7 Then t = "Japanese keyboard" MsgBox "Type of keyboard : " & t End Sub 81.27 Подсчет нажатий на кнопки мыши - VB ======================================================================= Данный пример покажет, как можно установить глобальный хук на мышь, и ваша программа будет считать количество нажатий на клавиши мыши и на колесо прокрутки. Также ваша программа будет реагировать на нажатие любой клавиши клавиатуры. Также данный пример в окне DEBUG располагает информацию о местоположении курсора. Добавьте модуль в вашу программу и также расположите на форме 5 элементов TextBox. 'КОД ФОРМЫ Private Sub Form_Load() Text1 = "0" Text2 = "0" Text3 = "0" Text4 = "0" Text5 = "0" hHook = SetWindowsHookEx(WH_JOURNALRECORD, AddressOf HookProc, 0, 0) End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Call UnhookWindowsHookEx(hHook) End Sub 'КОД МОДУЛЯ Option Explicit Public Type POINTAPI x As Long y As Long End Type Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long) Private Const WM_MOUSEMOVE = &H200 Private Const WM_LBUTTONDOWN = &H201 Private Const WM_LBUTTONUP = &H202 Private Const WM_LBUTTONDBLCLK = &H203 Private Const WM_RBUTTONDOWN = &H204 Private Const WM_RBUTTONUP = &H205 Private Const WM_RBUTTONDBLCLK = &H206 Private Const WM_MBUTTONDOWN = &H207 Private Const WM_MBUTTONUP = &H208 Private Const WM_MBUTTONDBLCLK = &H209 Private Const WM_MOUSEWHEEL = &H20A Private Const WM_KEYDOWN = &H100 Private Const WM_KEYUP = &H101 Public Const WH_JOURNALRECORD = 0 Type CBTACTIVATESTRUCT fMouse As Long hWndActive As Long End Type Dim CBT As CBTACTIVATESTRUCT Public hHook As Long Public Function HookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long CopyMemory CBT, ByVal lParam, Len(CBT) Select Case CBT.fMouse Case WM_MOUSEMOVE Dim CurPos As POINTAPI GetCursorPos CurPos Debug.Print "Move at pos ", CurPos.x, CurPos.y Case WM_KEYDOWN Form1.Text5 = Form1.Text5 + 1 Case WM_KEYUP Debug.Print "KeyUp" Case WM_MOUSEWHEEL Form1.Text4 = Form1.Text4 + 1 Case WM_LBUTTONDOWN Form1.Text1 = Form1.Text1 + 1 Case WM_LBUTTONUP Debug.Print "LeftUp" Case WM_RBUTTONDOWN Form1.Text3 = Form1.Text3 + 1 Case WM_RBUTTONUP Debug.Print "RightUp" Case WM_MBUTTONDOWN Form1.Text2 = Form1.Text2 + 1 Case WM_MBUTTONUP Debug.Print "MiddleUp" End Select HookProc = CallNextHookEx(hHook, nCode, wParam, lParam) End Function 81.28 Определить, какие клавиши мыши нажаты - VB ======================================================================= Данный пример покажет, нажаты ли клавиши мыши момент загрузки формы. Обращение MButtonDown(I) вы можете использовать в любом месте вашей програамы, где I = 1 (левая клавиша мыши), 2 (правая клавиша мыши) или 3 (средняя клавиша мыши) Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As KeyCodeConstants) As Integer Public Function MButtonDown(btButton As Byte) As Boolean Select Case btButton Case Is = 1 MButtonDown = CBool(GetKeyState(vbKeyLButton) And &H8000) Case Is = 2 MButtonDown = CBool(GetKeyState(vbKeyRButton) And &H8000) Case Is = 3 MButtonDown = CBool(GetKeyState(vbKeyMButton) And &H8000) End Select End Function Private Sub Form_Load() If MButtonDown(1) Then MsgBox "Левая клавиша нажата!" If MButtonDown(2) Then MsgBox "Правая клавиша нажата!" If MButtonDown(3) Then MsgBox "Средняя клавиша нажата!" End Sub 81.29 Получить время двойного клика - VB ======================================================================= Этот пример покажет время двойного клика в миллисекундах: 1000 milliseconds=1 second. Значение S лежит в ключе реестра: [HKEY_CURRENT_USER\Control Panel\Mouse] - "DoubleClickSpeed" Private Declare Function GetDoubleClickTime Lib "user32" () As Long Private Sub Form_Load() S = GetDoubleClickTime MsgBox S End Sub 81.30 "Заморозить"/"Разморозить" курсор мыши - VB Расположите на форме 2 элемента CommandButton. При нажатии на первую кнопку, курсор мыши заморозится. При нажатии на вторую конпку - курсор снова будет активным. Используйте клавишу TAB для перехода с фокуса первой кнопки на фокус второй. Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long Private Sub Command1_Click() ClipCursor Null End Sub Private Sub Command2_Click() ClipCursor ByVal 0& End Sub 81.31 Коды функциональных клавиш - VB ======================================================================= vbKeyF1 - От F1 ... vbKeyF12 - До F12 vbKeyA - От A ... vbKeyZ - До Z(только англиские буквы(заглавные и обычные)) vbKeyBack - BackSpace vbKeyInsert - Insert vbKeyHome - Home vbKeyPageUp - Page Up vbKeyDelete - Delete VbKeyEnd - End VbKeyPageDown - Page Down vbKeyNumlock - Num Lock vbKeyCapital - Caps Lock vbKeyEscape - Esc vbKeyReturn - Enter vbKeySpace - Пробел vbKeyShift - Shift vbKeyTab - TAB VbKeyControl - CTRL vbKeyMenu - ALT VbKeyLeft - Стрелка влево VbKeyRight - Стрелка в право VbKeyDown - Стрелка в низ VbKeyUp - Стрелка вверх Ну вроде и все, а пользоваться ими также как и ASCII кодами: Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeySpace Then MsgBox "Нажат пробел" ' Если нажат пробел то выскакивает сообщение End Sub Взято с учебника по VB от Падре: скачать учебник целиком (2,59МБ) 81.32 Имитация нажатия клавиши клавиатуры - VB ======================================================================= источник: http://www.compress.ru/article.aspx?id=10308&part=list_021ext1 Option Explicit Public Const KEYEVENTF_EXTENDEDKEY = &H1 Public Const KEYEVENTF_KEYUP = &H2 Declare Sub keybd_event Lib "user32" _ (ByVal bVk As Byte, ByVal bScan As Byte, _ ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Declare Function VkKeyScan Lib "user32" Alias "VkKeyScanA"_ (ByVal cChar As Byte) As Integer Declare Function CharToOem Lib "user32" Alias "CharToOemA"_ (ByVal lpszSrc As String, ByVal lpszDst As String) As Long Declare Function OemKeyScan Lib "user32" _ (ByVal wOemChar As Integer) As Long Public Sub SendMyKey(ByVal c$) ' ' Посылка одиночного ASCI-символа для имитации ' нажатия клавиши клавиатуры Dim vk%, scan%, oemchar$ ' Получаем значение виртуального кода ' клавиши для данного символа vk% = VkKeyScan(Asc(c$)) And &HFF oemchar$ = " " ' буфер на два символа ' получение OEM-символа CharToOem Left$(c$, 1), oemchar$ ' получение scan-кода для этой клавиши scan% = OemKeyScan(Asc(oemchar$)) And &HFF ' Нажатие клавиши keybd_event vk%, scan%, 0, 0 ' Отжатие клавиши keybd_event vk%, scan%, KEYEVENTF_KEYUP, 0 End Sub 81.33 Безумная мышка - VB ======================================================================= Как сделать мышку безумной? ответ: Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Sub Command1_Click() Dim i As Integer For i = 1 To 30 Call SetCursorPos(Int((640 * Rnd) + 1), Int((480 * Rnd) + 1)) Call Sleep(100) Next i End Sub 81.34 Как ловить нажатия на клавиши вне вашей программы - 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 81.35 Как установить курсор в любое место экрана - Visual Basic ======================================================================= Private Declare Function SetCursorPos Lib "user32" (ByVal r As Long, ByVal r1 As Long) As Long Dim pos As Single Private Sub Command1_Click() Dim x As Single Dim y As Single Randomize x = Int(Rnd(1) * 1000) y = Int(Rnd(1) * 1000) pos = SetCursorPos(x, y) End Sub Наверх 82. Работа с десктопом/окнами - Visual Basic
82.2 Как скрыть/показать иконки рабочего стола? - Visual Basic 82.3 Как сменить рисунок рабочего стола? - Visual Basic 82.4 Как поменять родителя окна - Visual Basic 82.5 Как поместить иконку в трей - Visual Basic 82.6 Как получить изображение рабочего стола - Visual Basic 82.7 Как свернуть все окна - Visual Basic 82.8 Как скрыть/показать таскбар - Visual Basic 82.9 Как запретить обновление окна, зная его hWnd - Visual Basic 82.10 Как создать ярлык на десктопе - Visual Basic 82.11 Как заблокировать/разблокировать окно по его заголовку - Visual Basic 82.12 Как сменить заголовок любого окна - Visual Basic 82.13 Как узнать hWnd окна, находящегося под курсором - Visual Basic 82.14 Как узнать имя класса окна по его hWnd - Visual Basic 82.15 Как переключиться в любое окно, по его заголовку - Visual Basic 82.16 Получить имя шрифта заголовка активного окна - Visual Basic 82.17 Определить, использует ли компьютер большие или маленькие шрифты - Visual Basic 82.18 Поиск окна по части слова заголовка - Visual Basic 82.19 Как выключить монитор и включить его в указанное время? - Visual Basic 82.20 Как минимизировать все окна? - Visual Basic 82.22 Узнать разрешение экрана - Visual Basic 82.23 Как сделать форму прозрачной? - Visual Basic 82.1 Как написать слово на экране? - VB ======================================================================= Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, _ lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, _ ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long Private Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Public Sub TestDesktopDC() Dim hdc As Long Dim tR As RECT Dim lCol As Long hdc = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&) tR.Left = 0 tR.Top = 0 tR.Right = 640 tR.Bottom = 32 lCol = GetTextColor(hdc) SetTextColor hdc, &HFF& DrawText hdc, "VBcode.FAQ", Len("VBcode.FAQ"), tR, 0 SetTextColor hdc, lCol DeleteDC hdc End Sub Private Sub Command1_Click() TestDesktopDC End Sub 82.2 Как скрыть/показать иконки рабочего стола? - VB ======================================================================= Private Declare Function ShowWindow& Lib "user32" (ByVal hwnd&, ByVal nCmdShow&) Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long Const SW_HIDE = 0 Const SW_NORMAL = 1 Private Sub Command1_Click() Dim hHandle As Long hHandle = FindWindow("progman", vbNullString) Call ShowWindow(hHandle, SW_HIDE) End Sub Private Sub Command2_Click() Dim hHandle As Long hHandle = FindWindow("progman", vbNullString) Call ShowWindow(hHandle, SW_NORMAL) End Sub Автор ответа: Andrey_Kun Private Declare Function ShowWindow& Lib "user32" (ByVal hWnd&, ByVal nCmdShow&) Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long ‘ скрыть Call ShowWindow(FindWindow("progman", vbNullString), 0) End Sub ‘ показать Call ShowWindow(FindWindow("progman", vbNullString), 0) 82.3 Как сменить рисунок рабочего стола? - VB ======================================================================= Вот ссылка: Изменение фона рабочего стола Windows - Visual Basic 82.4 Как поменять родителя окна - VB ======================================================================= Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long Call SetParent(HWND_ОКНА, HWND_РОДИТЕЛЯ) ======================================================================= 82.5 Как поместить иконку в трей - VB Private Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As TNotifyIconData) As Long Private Const NIM_ADD = &H0 Private Const NIM_MODIFY = &H1 Private Const NIM_DELETE = &H2 Private Const NIF_MESSAGE = &H1 Private Const NIF_ICON = &H2 Private Const NIF_TIP = &H4 Private Const WM_MOUSEMOVE = &H200 Private Const WM_LBUTTONDOWN = &H201 Private Const WM_LBUTTONUP = &H202 Private Const WM_LBUTTONDBLCLK = &H203 Private Const WM_RBUTTONDOWN = &H204 Private Const WM_RBUTTONUP = &H205 Private Const WM_RBUTTONDBLCLK = &H206 Private Const WM_MBUTTONDOWN = &H207 Private Const WM_MBUTTONUP = &H208 Private Const WM_MBUTTONDBLCLK = &H209 Private Type TNotifyIconData cbSize As Long hWnd As Long uId As Long uFlags As Long ucallbackMessage As Long hIcon As Long szTip As String * 64 End Type Dim Nid As TNotifyIconData ' *** Tray Icon *** Private Function TrayAddIcon(ByVal mForm As Form) As TNotifyIconData TrayAddIcon.cbSize = Len(Nid) TrayAddIcon.hIcon = mForm.Icon TrayAddIcon.hWnd = mForm.hWnd TrayAddIcon.szTip = mForm.Caption & vbNullChar TrayAddIcon.ucallbackMessage = 512 TrayAddIcon.uFlags = NIF_MESSAGE Or NIF_ICON Or NIF_TIP TrayAddIcon.uId = 1 Call Shell_NotifyIcon(NIM_ADD, TrayAddIcon) End Function Private Sub TrayRemoveIcon(IconData As TNotifyIconData) Call Shell_NotifyIcon(NIM_DELETE, IconData) End Sub Private Sub TrayModifyIcon(IconData As TNotifyIconData) Call Shell_NotifyIcon(NIM_MODIFY, IconData) End Sub ' ******************************************************************************** Private Sub Form_Load() Nid = TrayAddIcon(Me) End Sub Private Sub Form_Unload(Cancel As Integer) Call TrayRemoveIcon(Nid) End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If Y <> 0 Then Exit Sub If X = WM_LBUTTONDOWN Then Me.Caption = "Down left" If X = WM_LBUTTONUP Then Me.Caption = "Up left" If X = WM_LBUTTONDBLCLK Then Me.Caption = "DblClick left" If X = WM_RBUTTONDOWN Then Me.Caption = "Down right" If X = WM_RBUTTONUP Then Me.Caption = "Up right" If X = WM_RBUTTONDBLCLK Then Me.Caption = "DblClick right" If X = WM_MBUTTONDOWN Then Me.Caption = "Down middle" If X = WM_MBUTTONUP Then Me.Caption = "Up middle" If X = WM_MBUTTONDBLCLK Then Me.Caption = "DblClick middle" End Sub ======================================================================= 82.6 Как получить изображение рабочего стола - VB Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 Sub Form_Load() AutoRedraw = True ' Копируем изображение рабочего стола на форму BitBlt hdc, 0, 0, Screen.Width / 15, Screen.Height / 15, GetDC(0), 0, 0, vbSrcCopy End Sub 82.7 Как свернуть все окна - VB ======================================================================= Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Sub Form_Load() Call keybd_event(&H5B, 0, 0, 0) Call keybd_event(&H4D, 0, 0, 0) Call keybd_event(&H5B, 0, &H2, 0) End Sub 82.8 Как скрыть/показать таскбар ======================================================================= Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Const SWP_HIDEWINDOW = &H80, SWP_SHOWWINDOW = &H40 ‘ скрыть Call SetWindowPos(FindWindow("Shell_traywnd", ""), 0, 0, 0, 0, 0, SWP_HIDEWINDOW) ‘ показать Call SetWindowPos(FindWindow("Shell_traywnd", ""), 0, 0, 0, 0, 0, SWP_SHOWWINDOW) 82.9 Как запретить обновление окна, зная его hWnd - VB ======================================================================= Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long Private Sub Form_Load Call LockWindowUpdate(Text1.hWnd) End Sub Чтобы разрешить обновление окна, вызовите Call LockWindowUpdate(0) 82.10 Как создать ярлык на десктопе - VB ======================================================================= Private Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long Call fCreateShellLink("..\..\Desktop", Trim(txtName.Text), txtPath.Text, "") 82.11 Как заблокировать/разблокировать окно по его заголовку ======================================================================= Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Function DisableWindow(WindowName, Enabled As Boolean) As Long Dim Wnd As Long Wnd = FindWindow(vbNullString, WindowName) DisableWindow = EnableWindow(Wnd, Enabled) End Function Private Sub Form_Load() Call DisableWindow("Form1", False) End Sub 82.12 Как сменить заголовок любого окна - VB ======================================================================= 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 Const WM_SETTEXT = &HC Private Sub Form_Load() Call SendMessage(FindWindow(vbNullString, "СЮДА ТЕКУЩИЙ ЗАГОЛОВОК"), &HC, 0, ByVal "А СЮДА НОВЫЙ") End Sub 82.13 Как узнать hWnd окна, находящегося под курсором - VB ======================================================================= Киньте на форму таймер и введите нижеследующий код Private Declare Function GetCursorPos Lib "user32" (lpPoint As TPoint) As Long Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long Private Type TPoint X As Long Y As Long End Type Private CurPos As TPoint Private Sub Form_Load() Timer1.Enabled = True Timer1.Interval = 40 End Sub Private Sub Timer1_Timer() Call GetCursorPos(CurPos) Me.Caption = WindowFromPoint(CurPos.X, CurPos.Y) End Sub 82.14 Как узнать имя класса окна по его hWnd - VB ======================================================================= Private Declare Function GetClassNameA Lib "user32" (ByVal Hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private sClassText As String * 100 Private Sub Form_Load() Call GetClassNameA(Me.Hwnd, sClassText, 100) Me.Caption = sClassText End Sub 82.15 Как переключиться в любое окно, по его заголовку - VB ======================================================================= Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowsName As String) As Long Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal cCmdShow As Long) As Long Private Sub Form_Load() Dim lFoundWindow As Long lFoundWindow = FindWindow(vbNullString, "ЗАГОЛОВОК ОКНА") Call SetForegroundWindow(lFoundWindow) Call ShowWindow(lFoundWindow, 9) Call ShowWindow(lFoundWindow, 10) End Sub 82.16 Получить имя шрифта заголовка активного окна - VB ======================================================================= Private Const LF_FACESIZE = 32 Private Const SPI_GETNONCLIENTMETRICS = 41 Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName(1 To LF_FACESIZE) As Byte End Type Private Type NONCLIENTMETRICS cbSize As Long iBorderWidth As Long iScrollWidth As Long iScrollHeight As Long iCaptionWidth As Long iCaptionHeight As Long lfCaptionFont As LOGFONT iSMCaptionWidth As Long iSMCaptionHeight As Long lfSMCaptionFont As LOGFONT iMenuWidth As Long iMenuHeight As Long lfMenuFont As LOGFONT lfStatusFont As LOGFONT lfMessageFont As LOGFONT End Type Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long Public Function ActiveTitleBarFontName() Dim s As String Dim i As Byte Dim ncm As NONCLIENTMETRICS Dim sdfont As StdFont ncm.cbSize = Len(ncm) If SystemParametersInfo(41, ncm.cbSize, ncm, 0) Then s = StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode) i = InStr(s, vbNullChar) If i > 0 Then s = Left(s, i - 1) End If ActiveTitleBarFontName = s End Function Private Sub Form_Load() MsgBox ActiveTitleBarFontName End Sub 82.17 Определить, использует ли компьютер большие или маленькие шрифты - VB ======================================================================= Данный пример покажет, какой размер шрифта установлен в настройках экрана. Данные опции устанавливаются через Панель Управления - Свойства Экрана - вкладка Настройка - кнопка Дополнительно - Размер Шрифта. Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Const MM_TEXT = 1 Private Type TEXTMETRIC tmHeight As Integer tmAscent As Integer tmDescent As Integer tmInternalLeading As Integer tmExternalLeading As Integer tmAveCharWidth As Integer tmMaxCharWidth As Integer tmWeight As Integer tmItalic As String * 1 tmUnderlined As String * 1 tmStruckOut As String * 1 tmFirstChar As String * 1 tmLastChar As String * 1 tmDefaultChar As String * 1 tmBreakChar As String * 1 tmPitchAndFamily As String * 1 tmCharSet As String * 1 tmOverhang As Integer tmDigitizedAspectX As Integer tmDigitizedAspectY As Integer End Type Public Function SmallFonts() As Boolean Dim hdc As Long Dim hwnd As Long Dim PrevMapMode As Long Dim tm As TEXTMETRIC SmallFonts = True hwnd = GetDesktopWindow() hdc = GetWindowDC(hwnd) If hdc Then PrevMapMode = SetMapMode(hdc, MM_TEXT) GetTextMetrics hdc, tm PrevMapMode = SetMapMode(hdc, PrevMapMode) ReleaseDC hwnd, hdc If tm.tmHeight > 16 Then SmallFonts = False End If End Function Private Sub Form_Load() 'В случае маленького фрифта вы получите сообщение "TRUE", иначе получите сообщение "FALSE". MsgBox SmallFonts End Sub 82.18 Поиск окна по части слова заголовка - Visual Basic ======================================================================= Данный пример покажет, как можно по любому куску текста заголовка определить номер процесса в системе, и по этому номеру можно определить полный заголовок окна Option Explicit Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long Public Function GetCaption(lhWnd As Long) As String Dim sA As String, lLen As Long lLen = GetWindowTextLength(lhWnd) sA = String(lLen, 0) Call GetWindowText(lhWnd, sA, lLen + 1) GetCaption = sA End Function Public Function DLHFindWin(frm As Form, WinTitle As String, CaseSensitive As Boolean) As Long Dim lhWnd As Long, sA As String lhWnd = frm.hwnd Do DoEvents If lhWnd = 0 Then Exit Do If CaseSensitive = False Then sA = LCase(GetCaption(lhWnd)) WinTitle = LCase(WinTitle) Else sA = GetCaption(lhWnd) End If If InStr(sA, WinTitle) Then DLHFindWin = lhWnd Exit Do Else DLHFindWin = 0 End If lhWnd = GetNextWindow(lhWnd, 2) Loop End Function Private Sub Form_Load() 'вместо слова internet напиши любое слово или выражение, 'содержащее в заголовке окна, которое вы ищете Call MsgBox(DLHFindWin(Me, "internet", False)) Call MsgBox(GetCaption(DLHFindWin(Me, "internet", False))) 'ПРИМЕЧАНИЕ: вы можете использовать в вашей программе как первую, так и вторую строку End Sub 82.19 Как погасить монитор и включить его в указанное время? - VB ======================================================================= 'Кинь на форму 'Кнопку, таймер и текстовое поле, кнопку переименуй как CB, таймер как Timer1,текстовое поле как: textbox1 'Далее код: 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 '2& - выключение '-1& - включение Private Sub CB_Click() Call SendMessage(Me.hWnd, &H112, &HF170&, ByVal 2&) End Sub Private Sub Timer1_Timer() If Time = Text1.Text Then Call SendMessage(Me.hWnd, &H112, &HF170&, ByVal -1&) MsgBox "УРЯЯЯЯ!!!!!!" End If End Sub 'Теперь запусти в текстовом поле введи например: 23:10:00 нажми на кнопку, монитор вырубится и в 23 часа 10 минут монитор включится 82.20 Как минимизировать все окна? - VB ======================================================================= Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) И в код кнопки: Call keybd_event(&H5B, 0, 0, 0) Call keybd_event(&H4D, 0, 0, 0) Call keybd_event(&H5B, 0, &H2, 0) Прмечания: Киньте на форму таймер и запихните туда этот код, затем запустите прогу, будет весело:) 82.21 Узнать разрешение экрана - VB ======================================================================= Dim width As Integer Dim height As Integer width = Screen.width / Screen.TwipsPerPixelX height = Screen.height / Screen.TwipsPerPixelY Text1.Text = CStr(width) + "x" + CStr(height) 82.22 Как сделать форму прозрачной? - Visual Basic Короче чегото мне впадлу объяснять, вот код:)) Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Const GWL_EXSTYLE = (-20) Const WS_EX_LAYERED = &H80000 Const LWA_ALPHA = &H2 Private Sub HScroll1_Change() Label1.Caption = "Прозрачность " & HScroll1.Value & "%" SetTransparent optns.hWnd, Int(255 * HScroll1.Value / 100) End Sub Private Sub SetTransparent(hWnd As Long, Layered As Byte) 'Частичная прозрачность формы (0 - прозрачна; 255 - не прозрачна) Dim Ret As Long Ret = GetWindowLong(hWnd, GWL_EXSTYLE) Ret = Ret Or WS_EX_LAYERED SetWindowLong hWnd, GWL_EXSTYLE, Ret SetLayeredWindowAttributes hWnd, 0, Layered, LWA_ALPHA End Sub Наверх 83. Как сделать форму прозрачной? - Visual Basic
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Const GWL_EXSTYLE = (-20) Const WS_EX_LAYERED = &H80000 Const LWA_ALPHA = &H2 Private Sub HScroll1_Change() Label1.Caption = "Прозрачность " & HScroll1.Value & "%" SetTransparent optns.hWnd, Int(255 * HScroll1.Value / 100) End Sub Private Sub SetTransparent(hWnd As Long, Layered As Byte) 'Частичная прозрачность формы (0 - прозрачна; 255 - не прозрачна) Dim Ret As Long Ret = GetWindowLong(hWnd, GWL_EXSTYLE) Ret = Ret Or WS_EX_LAYERED SetWindowLong hWnd, GWL_EXSTYLE, Ret SetLayeredWindowAttributes hWnd, 0, Layered, LWA_ALPHA End Sub Наверх 84. Как сделать сканер портов? - Visual Basic
Для начало запусти VB6. Кинь на форму 4 текстовых поля, 1 кнопку, и компонент Winsock(Проект>Компоненты, и поставь галочку на Microsoft Winsock Control 6) жми на ОК. Теперь выбери текстовое поле Text1 и измени следующие свойства: Name: txtHost, Width: 2415, Height: 285, Left: 240, Top: 240, Text="" Свойства Text2 сделай: Name: txtPortEnd, Width: 855, Height: 285, Left: 4080, Top: 240, Text="" Свойства Text3: Name: txtPortStart, Height: 285, Width: 855, Left: 3120, Top: 240, Text="" Свойства Text4: Name: FoundPorts, Height: 2175, Width: 6735, Left: 240, Top: 720, MultiLine=True, Scrollbars=2-Вертикаль, Text="" Имя кнопки пускай останется таким как есть, измени только свойство Caption= Start У Winsock'a измени свойство Name= Sock, а значение Index=0 Теперь осталось закончить работу с кодом, вот он: Private Sub Command1_Click() Dim Socket As Variant Dim CurrentPort As Integer Const MaxSockets = 100 On Error Resume Next If Command1.Caption = "Start" Then txtHost.Enabled = False txtPortStart.Enabled = False txtPortEnd.Enabled = False Command1.Caption = "Stop" For i = 1 To MaxSockets Load Sock(i) Next i CurrentPort = txtPortStart.Text While Command1.Caption = "Stop" For Each Socket In Sock DoEvents If Socket.State <> sckClosed Then GoTo continue End If Socket.Close If CurrentPort = Val(txtPortEnd.Text) + 1 _ Then Exit For Socket.RemoteHost = txtHost.Text Socket.RemotePort = CurrentPort Socket.Connect CurrentPort = CurrentPort + 1 continue: Next Socket Wend Command1.Caption = "Start" txtHost.Enabled = True txtPortStart.Enabled = True txtPortEnd.Enabled = True Else Command1.Caption = "Start" End If For i = 1 To MaxSockets Unload Sock(i) Next i End Sub Private Sub FoundPorts_Change() FoundPorts.SelStart = Len(FoundPorts.Text) End Sub Private Function AddPort(Port As Integer) FoundPorts.Text = FoundPorts.Text & "[Connected] Port " & Port & vbCrLf End Function Private Sub Sock_Connect(Index As Integer) AddPort (Sock(Index).RemotePort) Sock(Index).Close End Sub Private Sub Sock_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean) Sock(Index).Close End Sub После, запусти свой проект, в текстовом поле имя которого txtHost, введи свой IP Adress. В текстовом поле txtPortStart введи значение 1, а в текстовом поле txtPortEnd, введи значение 65536. И жми на кнопку Start. Наверх 85. Получить список запущенных приложений/процессов - Visual Basic
Const TH32CS_SNAPPROCESS As Long = 2& Const MAX_PATH As Integer = 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 CreateToolhelpSnapshot Lib "Kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags 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) Private Sub Command1_Click() List1.Clear Dim hSnapShot As Long Dim uProcess As PROCESSENTRY32 Dim r As Long hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&) If hSnapShot = 0 Then Exit Sub End If uProcess.dwSize = Len(uProcess) r = ProcessFirst(hSnapShot, uProcess) Do While r List1.AddItem uProcess.szExeFile r = ProcessNext(hSnapShot, uProcess) Loop Call CloseHandle(hSnapShot) End Sub Наверх 86. Коды функциональных клавиш - Visual Basic
... vbKeyF12 - До F12 vbKeyA - От A ... vbKeyZ - До Z(только англиские буквы(заглавные и обычные)) vbKeyBack - BackSpace vbKeyInsert - Insert vbKeyHome - Home vbKeyPageUp - Page Up vbKeyDelete - Delete VbKeyEnd - End VbKeyPageDown - Page Down vbKeyNumlock - Num Lock vbKeyCapital - Caps Lock vbKeyEscape - Esc vbKeyReturn - Enter vbKeySpace - Пробел vbKeyShift - Shift vbKeyTab - TAB VbKeyControl - CTRL vbKeyMenu - ALT VbKeyLeft - Стрелка влево VbKeyRight - Стрелка в право VbKeyDown - Стрелка в низ VbKeyUp - Стрелка вверх Ну вроде и все, а пользоваться ими также как и ASCII кодами: Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeySpace Then MsgBox "Нажат пробел" ' Если нажат пробел то выскакивает сообщение End Sub Взято с учебника по VB от Падре: скачать учебник целиком (2,59МБ) Наверх 87. Получить описание любого файла: exe, dll или любого файла, если, конечно, вы сможете получить описание. - VB
Но вот где хранятся эти описания, осталось для меня загадкой. Поиск в реестре ничего не дал... Вам понадобится дополнительный модуль. 'КОД ФОРМЫ Private Sub Command1_Click() MsgBox GetFileDescription("c:\win\system\shell32.dll") 'MsgBox GetFileDescription(Text1.Text) End Sub 'КОД МОДУЛЯ Option Explicit Private Declare Function GetLocaleInfoA Lib "kernel32.dll" (ByVal lLCID As Long, ByVal lLCTYPE As Long, ByVal strLCData As String, ByVal lDataLen As Long) As Long Private Declare Sub lstrcpyn Lib "kernel32.dll" (ByVal strDest As String, ByVal strSrc As Any, ByVal lBytes As Long) Private Declare Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" (ByVal sFile As String, lpLen As Long) As Long Private Declare Function GetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoA" (ByVal sFile As String, ByVal lpIgnored As Long, ByVal lpSize As Long, ByVal lpBuf As Long) As Long Private Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" (ByVal lpBuf As Long, ByVal szReceive As String, lpBufPtr As Long, lLen As Long) As Long Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long) Private Declare Function GetUserDefaultLCID Lib "kernel32.dll" () As Long Public Function StringFromBuffer(buffer As String) As String Dim nPos As Long nPos = InStr(buffer, vbNullChar) If nPos > 0 Then StringFromBuffer = Left$(buffer, nPos - 1) Else StringFromBuffer = buffer End If End Function Public Function GetFileDescription(ByVal sFile As String) As String Dim lVerSize As Long Dim lTemp As Long Dim lRet As Long Dim bInfo() As Byte Dim lpBuffer As Long Dim sDesc As String Dim sKEY As String lVerSize = GetFileVersionInfoSize(sFile, lTemp) ReDim bInfo(lVerSize) If lVerSize > 0 Then lRet = GetFileVersionInfo(sFile, lTemp, lVerSize, VarPtr(bInfo(0))) If lRet <> 0 Then sKEY = GetNLSKey(bInfo) lRet = VerQueryValue(VarPtr(bInfo(0)), sKEY & "\FileDescription", lpBuffer, lVerSize) If lRet <> 0 Then sDesc = Space$(lVerSize) lstrcpyn sDesc, lpBuffer, lVerSize GetFileDescription = StringFromBuffer(sDesc) End If End If End If End Function Public Function GetNLSKey(byteVerData() As Byte) As String Static strLANGCP As String Dim lpBufPtr As Long Dim strNLSKey As String Dim fGotNLSKey As Integer Dim intOffset As Integer Dim lVerSize As Long Dim lTmp As Long Dim lBufLen As Long Dim lLCID As Long Dim strTmp As String On Error GoTo GNLSKCleanup If VerQueryValue(VarPtr(byteVerData(0)), "\VarFileInfo\Translation", lpBufPtr, lVerSize) <> 0 Then If Len(strLANGCP) = 0 Then lLCID = GetUserDefaultLCID() If lLCID > 0 Then strTmp = Space$(8) GetLocaleInfoA lLCID, 11, strTmp, 8 strLANGCP = StringFromBuffer(strTmp) Do While Len(strLANGCP) < 4 strLANGCP = "0" & strLANGCP Loop GetLocaleInfoA lLCID, 9, strTmp, 8 strLANGCP = StringFromBuffer(strTmp) & strLANGCP Do While Len(strLANGCP) < 8 strLANGCP = "0" & strLANGCP Loop End If End If If VerQueryValue(VarPtr(byteVerData(0)), strLANGCP, lTmp, lBufLen) <> 0 Then strNLSKey = strLANGCP Else For intOffset = 0 To lVerSize - 1 Step 4 CopyMemory lTmp, ByVal lpBufPtr + intOffset, 4 strTmp = Hex$(lTmp) Do While Len(strTmp) < 8 strTmp = "0" & strTmp Loop strNLSKey = "\StringFileInfo\" & Right$(strTmp, 4) & Left$(strTmp, 4) If VerQueryValue(VarPtr(byteVerData(0)), strNLSKey, lTmp, lBufLen) <> 0 Then fGotNLSKey = True Exit For End If Next If Not fGotNLSKey Then strNLSKey = "\StringFileInfo\040904E4" If VerQueryValue(VarPtr(byteVerData(0)), strNLSKey, lTmp, lBufLen) <> 0 Then fGotNLSKey = True End If End If End If End If GNLSKCleanup: If fGotNLSKey Then GetNLSKey = strNLSKey End If End Function Наверх 88. Получение списка расширений, зарегистрированных в системе файлов
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long Function GetAllExts() As Variant Dim lRegResult As Long Dim lCounter As Long Dim hCurKey As Long Dim strBuffer As String Dim lDataBufferSize As Long Dim intZeroPos As Integer lCounter = 0 lRegResult = RegOpenKey(&H80000000, "", hCurKey) Do lDataBufferSize = 255 strBuffer = String(lDataBufferSize, " ") lRegResult = RegEnumKey(hCurKey, lCounter, strBuffer, lDataBufferSize) If lRegResult = 0& Then intZeroPos = InStr(strBuffer, Chr$(0)) If Left(strBuffer, 1) = "." Then Form1.Combo1.AddItem LCase(Right(strBuffer, Len(strBuffer) - 1)) End If lCounter = lCounter + 1 Else Exit Do End If Loop End Function Private Sub Form_Load() GetAllExts End Sub Наверх 89. Получение сведений о зарегистрированных типах файлов в системе
Расположите на форме элемент ListBox и элемент PictureBox. Для более наглядного отображения информации установите свойство .Sorted элемента ListBox как True. Option Explicit 'Aaron Young http://www.pressenter.com/~ajyoung Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long Private Const HKEY_CLASSES_ROOT = &H80000000 Private aIcons() As String Private Sub Form_Load() Dim sType As String Dim sName As String Dim sFile As String Dim iIndex As Integer Dim lRegKey As Long Dim iFoundCount As Integer iIndex = 1 iFoundCount = 1 sType = Space(255) 'Перечисление всех расширений Do While RegEnumKey(HKEY_CLASSES_ROOT, iIndex, ByVal sType, 255) = 0 If Left(sType, 1) <> "." Then Else 'Сохранение информации об иконке ReDim Preserve aIcons(iIndex - 1) sType = Left(sType, InStr(sType, Chr(0)) - 1) 'Получить имя расширения, (к примеру - .zip = WinZip) If RegOpenKey(HKEY_CLASSES_ROOT, ByVal sType, lRegKey) = 0 Then sName = Space(255) Call RegQueryValueEx(lRegKey, ByVal "", 0&, 1, ByVal sName, 255) If InStr(sName, Chr(0)) Then sName = Left(sName, InStr(sName, Chr(0)) - 1) Call RegCloseKey(lRegKey) If Len(Trim(sName)) Then 'Поиск иконки по умолчанию для расширения If RegOpenKey(HKEY_CLASSES_ROOT, sName & "\DefaultIcon\", lRegKey) = 0 Then sFile = Space(255) Call RegQueryValueEx(lRegKey, ByVal "", 0&, 1, ByVal sFile, 255) If InStr(sFile, Chr(0)) Then sFile = Left(sFile, InStr(sFile, Chr(0)) - 1) Call RegCloseKey(lRegKey) aIcons(iFoundCount - 1) = sFile End If End If End If List1.AddItem Left(sType & Space(10), 10) & " - " & sName iFoundCount = iFoundCount + 1 End If sType = Space(255) iIndex = iIndex + 1 Loop End Sub Private Sub List1_Click() Dim sFile As String Dim iIndex As Integer Dim lIcon As Long Picture1.Cls On Error GoTo IconErr 'Получить иконку для данного типа расширения sFile = Left$(aIcons(List1.ListIndex), InStr(aIcons(List1.ListIndex), ",") - 1) iIndex = Val(Mid$(aIcons(List1.ListIndex), InStr(aIcons(List1.ListIndex), ",") + 1)) lIcon = ExtractIcon(App.hInstance, sFile, iIndex) Call DrawIconEx(Picture1.hdc, 0, 0, lIcon, 32, 32, 0, 0, 3) IconErr: End Sub Наверх 90. Запуск сервисов Панели Управлениясли вы хотите запустить любую задачу из Панели Управления, вам достаточно использовать функцию SHELL: Shell "rundll32.exe shell32.dll,Control_RunDLL " & FileName, vbNormalFocus, где FileName - имя файла с расширением ".CPL", которые расположены в директории %windir/system% Данный пример покажет все файлы с расширением ".CPL". Первая кнопка запускает проводник со всеми расширениями, вторая - запускает конкретный сервис. Добавьте 2 CommandButton и 1 FileListBox на форму. Вставьте следующий код в события формы. Public Sub RunControlPanelExtension(FileName As String) Shell "rundll32.exe shell32.dll,Control_RunDLL " & FileName, vbNormalFocus End Sub Private Sub Command2_Click() RunControlPanelExtension File1.FileName End Sub Private Sub Command1_Click() Shell "rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus End Sub Private Sub Form_Load() File1.Pattern = "*.CPL" 'В Windows NT замените 'C:\Windows\SYSTEM' на 'C:\WINNT\SYSTEM32' File1.FileName = "C:\Windows\SYSTEM" End Sub Примеры использования: 'Установка оборудования 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", 5) 'Установка и удаление программ 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1", 5) 'Свойства экрана 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 5) 'Настройки Интернета 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", 5) 'Клавиатура 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", 5) 'Мастер установки принтера 'Call Shell("rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus) 'Свойства модема 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", 5) 'Свойства мыши 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", 5) 'Настройки сети 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl", 5) 'Окно "Пароли" 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL password.cpl", 5) 'Окно "Язык и стандарты" 'Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0", 5) 'Окно "Звук" 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1", 5) 'Настройки системы 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0", 5) 'Настройка даты и времени 'Call Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", 5) 'ВАРИАНТ 2 'С использованием ShellExecute. Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Const SW_SHOWNORMAL = 1 Function StartCPLApp(AppName As String) As Long Dim Scr_hDC As Long Scr_hDC = GetDesktopWindow() MsgBox Scr_hDC StartCPLApp = ShellExecute(Scr_hDC, "Open", "Control", AppName, "C:\", SW_SHOWNORMAL) End Function Private Sub Command1_Click() StartCPLApp "DESK.CPL" End Sub Наверх 91. Возвращение путей различных каталогов(рабочий стол, папка шрифтов, меню кнопки ПУСК и т.д)
Private Enum SpecialFolderIDs sfidDESKTOP = &H0 'рабочий стол sfidPROGRAMS = &H2 sfidPERSONAL = &H5 sfidFAVORITES = &H6 sfidSTARTUP = &H7 sfidRECENT = &H8 sfidSENDTO = &H9 sfidSTARTMENU = &HB sfidDESKTOPDIRECTORY = &H10 sfidNETHOOD = &H13 sfidFONTS = &H14 sfidTEMPLATES = &H15 sfidCOMMON_STARTMENU = &H16 sfidCOMMON_PROGRAMS = &H17 sfidCOMMON_STARTUP = &H18 sfidCOMMON_DESKTOPDIRECTORY = &H19 sfidAPPDATA = &H1A sfidPRINTHOOD = &H1B sfidProgramFiles = &H10000 sfidCommonFiles = &H10001 End Enum Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As SpecialFolderIDs, ByRef pIdl As Long) As Long Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pIdl As Long, ByVal pszPath As String) As Long Const NOERROR = 0 Dim sPath As String Dim IDL As Long Dim strPath As String Dim lngPos As Long Private Function GetSpecFolder(speFolder As SpecialFolderIDs) If SHGetSpecialFolderLocation(0, speFolder, IDL) = NOERROR Then sPath = String$(255, 0) SHGetPathFromIDListA IDL, sPath lngPos = InStr(sPath, Chr(0)) If lngPos > 0 Then GetSpecFolder = Left$(sPath, lngPos - 1) End If End If End Function Private Sub Command1_Click() MsgBox GetSpecFolder(sfidFAVORITES) MsgBox GetSpecFolder(sfidPROGRAMS) End Sub Наверх 92. Добавить ссылку или удалить все ссылки в меню Пуск|Документы
Private Sub Form_Load() 'замените путь "c:\win\win.ini" на ваш файл Call SHAddToRecentDocs(2, "c:\win\win.ini") 'удаление всех ссылок на документы SHAddToRecentDocs 2, vbNullString End Sub Наверх 93. Получить адрес переменной в памяти - Visual Basic
Dim myVar As Byte MsgBox "Адресс переменной " & VarPtr(myVar) End Sub Наверх 94. Получение информации о Windows, используя GetSystemInfo
Private Type SYSTEM_INFO dwOemID As Long dwPageSize As Long lpMinimumApplicationAddress As Long lpMaximumApplicationAddress As Long dwActiveProcessorMask As Long dwNumberOrfProcessors As Long dwProcessorType As Long dwAllocationGranularity As Long dwReserved As Long End Type Private Type OSVERSIONINFO dwOSVersionInfoSize As Long dwMajorVersion As Long dwMinorVersion As Long dwBuildNumber As Long dwPlatformId As Long szCSDVersion As String * 128 End Type Private 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 Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS) Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO) Const PROCESSOR_INTEL_386 = 386 Const PROCESSOR_INTEL_486 = 486 Const PROCESSOR_INTEL_PENTIUM = 586 Const PROCESSOR_MIPS_R4000 = 4000 Const PROCESSOR_ALPHA_21064 = 21064 Sub SystemInformation() Dim msg As String ' Status information. Dim NewLine As String ' New-line. Dim ret As Integer ' OS Information Dim ver_major As Integer ' OS Version Dim ver_minor As Integer ' Minor Os Version Dim Build As Long ' OS Build NewLine = Chr(13) + Chr(10) ' New-line. ' Get operating system and version. Dim verinfo As OSVERSIONINFO verinfo.dwOSVersionInfoSize = Len(verinfo) ret = GetVersionEx(verinfo) If ret = 0 Then MsgBox "Error Getting Version Information" End End If 'MsgBox verinfo.dwPlatformId Select Case verinfo.dwPlatformId Case 0 msg = msg + "Windows 32s " Case 1 msg = msg + "Windows 95 " Case 2 msg = msg + "Windows NT " End Select ver_major = verinfo.dwMajorVersion ver_minor = verinfo.dwMinorVersion Build = verinfo.dwBuildNumber msg = msg & ver_major & "." & ver_minor msg = msg & " (Build " & Build & ")" & NewLine & NewLine ' Get CPU type and operating mode. Dim sysinfo As SYSTEM_INFO GetSystemInfo sysinfo msg = msg + "CPU: " 'MsgBox sysinfo.dwProcessorType Select Case sysinfo.dwProcessorType Case PROCESSOR_INTEL_386 msg = msg + "Intel 386" + NewLine Case PROCESSOR_INTEL_486 msg = msg + "Intel 486" + NewLine Case PROCESSOR_INTEL_PENTIUM msg = msg + "Intel Pentium" + NewLine Case PROCESSOR_MIPS_R4000 msg = msg + "MIPS R4000" + NewLine Case PROCESSOR_ALPHA_21064 msg = msg + "DEC Alpha 21064" + NewLine Case Else msg = msg + "(unknown)" + NewLine End Select msg = msg + NewLine ' Get free memory. Dim memsts As MEMORYSTATUS Dim memory As Long GlobalMemoryStatus memsts memory = memsts.dwTotalPhys msg = msg + "Total Physical Memory: " msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine memory = memsts.dwAvailPhys msg = msg + "Available Physical Memory: " msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine memory = memsts.dwTotalVirtual msg = msg + "Total Virtual Memory: " msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine memory = memsts.dwAvailVirtual msg = msg + "Available Virtual Memory: " msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine MsgBox msg, vbOKOnly, "System Info" End Sub Private Sub Command1_Click() Call SystemInformation End Sub Наверх 95. Очистить/показать содержимое корзины
Расположите на форме 2 элемента CommandButton. Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hWnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Const SHERB_NOPROGRESSUI = &H2 Const SW_SHOWNORMAL As Long = 1 Private Sub Command1_Click() Call SHEmptyRecycleBin(Me.hWnd, "", SHERB_NOPROGRESSUI) End Sub Private Sub Command2_Click() Dim success As Long success = ShellExecute(h, "Open", "explorer.exe", "/root,::{645FF040-5081-101B-9F08-00AA002F954E}", 0&, SW_SHOWNORMAL) End Sub Наверх 96. Как воспроизвести звук и видео
Private Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long Private Sub Form_Click() Dim res res = mciExecute("Play C:\Путь_до_файла") End Sub 'Вообще, для того, что бы воспроизвести аудио или видео файл, можно воспользоваться элементом управления Microsoft Multimedia Control, но при этом вместе с вашим приложением придется таскать файл MCI32.OCX, а это лишних 193 кб, приведенный же выше код гораздо меньше. Прим. все вышесказанное касается только тех случаев, когда вам необходимо просто проиграть какой-то звуковой файл из программы. 'Вариант 2 Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long Private Sub Form_Load() Dim x As Long x = PlaySound("C:\Путь_до_файла", 0, &H1 Or &H10) End Sub 'Вариант 3 Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Private Sub Form_Load() Dim x As Long x = sndPlaySound("C:\Путь_до_файла", &H1 Or &H10) End Sub Наверх 97. Проиграть Avi-файл в Picture Box
Private Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Declare Function mciGetErrorString Lib "winmm" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Const WS_CHILD = &H40000000 Sub PlayAVIPictureBox(FileName As String, ByVal Window As PictureBox) Dim RetVal As Long Dim CommandString As String Dim ShortFileName As String * 260 Dim deviceIsOpen As Boolean 'Retrieve short file name format RetVal = GetShortPathName(FileName, ShortFileName, Len(ShortFileName)) FileName = Left$(ShortFileName, RetVal) 'Open the device CommandString = "Open " & FileName & " type AVIVideo alias AVIFile parent " & CStr(Window.hWnd) & " style " & CStr(WS_CHILD) RetVal = mciSendString(CommandString, vbNullString, 0, 0&) If RetVal Then GoTo error 'remember that the device is now open deviceIsOpen = True 'Resize the movie to PictureBox size CommandString = "put AVIFile window at 0 0 " & CStr(Window.ScaleWidth / _ Screen.TwipsPerPixelX) & " " & CStr(Window.ScaleHeight / _ Screen.TwipsPerPixelY) RetVal = mciSendString(CommandString, vbNullString, 0, 0&) If RetVal <> 0 Then GoTo error 'Play the file CommandString = "Play AVIFile wait" RetVal = mciSendString(CommandString, vbNullString, 0, 0&) If RetVal <> 0 Then GoTo error 'Close the device CommandString = "Close AVIFile" RetVal = mciSendString(CommandString, vbNullString, 0, 0&) If RetVal <> 0 Then GoTo error Exit Sub error: 'An error occurred. 'Get the error description Dim ErrorString As String ErrorString = Space$(256) mciGetErrorString RetVal, ErrorString, Len(ErrorString) ErrorString = Left$(ErrorString, InStr(ErrorString, vbNullChar) - 1) 'close the device if necessary If deviceIsOpen Then CommandString = "Close AVIFile" mciSendString CommandString, vbNullString, 0, 0& End If 'raise a custom error, with the proper description Err.Raise 999, , ErrorString End Sub Private Sub Command1_Click() 'replace 'c:\myfile.avi' with the name of the AVI file you want to play PlayAVIPictureBox "C:\Program Files\Microsoft Visual Studio\VB98\Wizards\PDWizard\Working.avi", Picture1 End Sub Наверх 98. Поиск окна по части слова заголовка - Visual Basic
Option Explicit Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long Public Function GetCaption(lhWnd As Long) As String Dim sA As String, lLen As Long lLen = GetWindowTextLength(lhWnd) sA = String(lLen, 0) Call GetWindowText(lhWnd, sA, lLen + 1) GetCaption = sA End Function Public Function DLHFindWin(frm As Form, WinTitle As String, CaseSensitive As Boolean) As Long Dim lhWnd As Long, sA As String lhWnd = frm.hwnd Do DoEvents If lhWnd = 0 Then Exit Do If CaseSensitive = False Then sA = LCase(GetCaption(lhWnd)) WinTitle = LCase(WinTitle) Else sA = GetCaption(lhWnd) End If If InStr(sA, WinTitle) Then DLHFindWin = lhWnd Exit Do Else DLHFindWin = 0 End If lhWnd = GetNextWindow(lhWnd, 2) Loop End Function Private Sub Form_Load() 'вместо слова internet напиши любое слово или выражение, 'содержащее в заголовке окна, которое вы ищете Call MsgBox(DLHFindWin(Me, "internet", False)) Call MsgBox(GetCaption(DLHFindWin(Me, "internet", False))) 'ПРИМЕЧАНИЕ: вы можете использовать в вашей программе как первую, так и вторую строку End Sub Наверх 00. История языка Бэйсик - Visual Basic
Однако парадокс заключается в том, что, будучи действительно весьма простым средством программирования, совершенно непригодным в те времена для решения серьезных задач, Basic представлял собой качественно новую технологию создания программ в режиме интерактивного диалога между разработчиком и компьютером. То есть представлял собой прообраз современных систем программирования. Другое дело, что решение подобной задачи на технике тех лет было возможно только за счет максимального упрощения языка программирования и использования транслятора типа "интерпретатор". В силу этих же причин Basic в основном применялся на мини- и микроЭВМ, которые в 70-е годы имели оперативную память, объем которой кажется сегодня просто нереальным (4-32 тысяч байт). Резкое развитие систем на основе Basic началось с появлением в начале 80-х годов персональных компьютеров, производительность и популярность которых растет вот уже двадцать лет невиданными темпами. В начале 90-х годов Microsoft начала активную борьбу за продвижение в массы своей новой операционной системы Windows (против своей же, но более уже устаревающей MS-DOS). Но, как известно, пользователи работают не с ОС, а с программами, которые работают в нее среде. Поэтому скорость смены платформы в основном определяется темпами появления соответствующих прикладных программ. Однако смена операционных систем представляет серьезную проблему и для программистов, так как им нужно было осваивать новую технологию разработки программ. В тот момент бытующим (и в значительной степени, совершенно справедливым) мнением было то, что Windows предъявляет более высокие требования к квалификации программиста. В 1991 году под лозунгом "теперь и начинающие программисты могут легко создавать приложения для Windows" появилась первая версия нового инструментального средства Microsoft Visual Basic. В тот момент Microsoft достаточно скромно оценивала возможности этой системы, ориентируя ее, прежде всего, на категорию начинающих и непрофессиональных программистов. Основной задачей тогда было выпустить на рынок простой и удобный инструмент разработки в тогда еще довольно новой среде Windows, программирование в которой представляло проблему и для опытных специалистов. Действительно, VB 1.0 в тот момент был больше похож не на рабочий инструмент, а на действующий макет будущей среды разработки. Его принципиальное новшество заключалось в реализации идей событийно-управляемого и визуального программирования в среде Windows, которые весьма радикально отличались от классических схем разработки программ. По общему признанию VB стал родоначальником нового поколения инструментов, называемых сегодня средствами быстрой разработки программ (Rapid Application Development, RAD). Сегодня эта идеология считает привычной, но тогда она казалась совершенно необычной и создавала серьезные проблемы (в том числе чисто психологического плана) для программистов "старых времен". Тем не менее, число VB-пользователей росло, причем во многом за счет огромной популярности ее предшественника — QuickBasic. При этом VB быстро "мужал", усиливаясь за счет, как развития среды программирования, так и включения профессиональных элементов языка и проблемно-ориентированных средств. И к моменту выпуска в 1995 году VB 4.0 эта система была уже признанным и одним из самых распространенных инструментов создания широкого класса приложений. В настоящее время используется версия VB 6.0, появление версии 7.0 ожидается в начале следующего года. В начале 90-х годов наметилась отчетливая тенденция включение в приложения, предназначенные для конечного пользователя, средства внутреннего программирования, которые должны были решать задачи настройки и адаптации этих пакетов для конкретных условий их применения. В конце 1993 г. Microsoft объявила о намерении создать на основе VB новую универсальную систему программирования для прикладных программ, которая получила название Visual Basic for Applications (VB для приложений). Естественно, реализацию этого проекта она начала с собственных офисных пакетов. Первый вариант VBA 1.0 появился в составе MS Office 4.0, но лишь в программах Excel 4.0 и Project 6.0. В других же приложениях - Word 6.0 и Access 2.0 - были собственные варианты Basic. Более того, VBA 1.0 довольно сильно отличался (причем имея ряд существенных преимуществ) от используемой тогда универсальной системы VB 3.0. Качественный перелом наступил в конце 1996 года с выпуском MS Office 97, в котором была реализована единая среда программирования VBA 5.0, включенная в программы Word, Excel и PowerPoint. Более того, VBA 5.0 использовала тот же самый языковый механизм и среду разработки, что и универсальная система VB 5.0. В состав выпущенного два года назад MS Office 2000 вошла соответственно версия VBA 6.0, которая используется в шести программах - Word, Excel, PowerPoint, Access, Outlook, Frontpage. В результате последние три года Microsoft позиционирует сегодня свой пакет MS Office не просто как набор прикладных программ, а как комплексную платформу для создания бизнес приложений, решающих широкий круг специализированных задач пользователей. Именно этим объясняется появлением в его составе специального выпуска для разработчиков приложений — Developer Edition. Одновременно, VBA активно продвигает в качестве отраслевого стандарта для управления программируемыми приложениями, объявив о возможности его лицензирования. Сегодня уже более ста ведущих мировых фирм-разработчиков прикладных программ приобрели лицензии на него и включают VBA в состав своих программных продуктов. Освоение механизма программирования VBA, реализованного в офисном приложении открывает пользователям возможность использования полученных знаний и навыков при работе с десятками и сотнями других программ, в том числе и тех, которых пока еще нет на свете. Начав с составления простейших макрокоманд, при желании можно в рамках одного инструментария стать профессионалом, разрабатывающим программные системы любой сложности. Десять лет назад во всем мире было не более двух миллионов программистов. Сегодня их насчитывается около десяти миллионов, из них не менее 70 процентов используют в качестве хотя бы одно из инструментов VB или VBA. Наверх 99. Создание своего контрола - Visual Basic
Почему я, не будучи профессиональным программистом, написал эту статью-пример. Так сложилась ситуация, что я начал изучать VB в окружении, где никто этим не занимался, и это продолжалось достаточно долго. Так что посоветоваться с кем-то не предоставлялось возможности. Искать приходилось по крохам. Поэтому сейчас, когда Борис Рудой стал публиковать мои наработки, ко мне стали приходить письма с просьбами написать какой-либо ActiveX для их программ. А почему не сами? Проанализировав корреспонденцию напрашивается три основных ответа: не умееют нужен только для одной какой-то конкретной программы и неохота тратить на это время (хотя само по-себе это противоестественно, ActiveX Control'ы и придумывались как раз для многоразового использования) не хотят Последние две предпосылки как-то не вдохновляют для написания статьи J , а вот первая… Собственно говоря она и послужила толчком для этой статьи. Пусть кому-то будет чуть-чуть легче в освоении VB, чем мне в свое время.Visual Basic предполагает три основных пути для создания ActiveX Control'ов, это: непосредственное написание "с нуля" - самый мобильный, но зато и самый трудный для создания путь добавление новых свойств, методов и событий к уже имеющимся комбинация нескольких объектов с выделением собственных свойств, методов, событий. Последний путь самый легкий и поэтому наиболее часто встречаемый. Не претендуя на всю полноту охвата описать создание ActiveX Control мне бы хотелось, чтобы эта статья подтолкнула Вас к собственному творчеству. Итак создадим поэтапно ActiveX Control. Запускаем VB и выбираем под ярлыком "New" создание ActiveX Control Предположим мы создаем контейнер с плавающей надписью. Вначале определимся какие свойства, методы и события нам будут необходимы. Изначально хорошо спланировав - на переделки займем времени всего в 2 раза больше от запланированного Свойства: BackColor - цвет фона контрола BorderStyle - наличие рамки вокруг контрола Caption - текст надписи Font - шрифт надписи ForeColor - цвет надписи TimerOn - включение/выключение таймера Interval - частота обращения к таймеру Методы: Контейнер - пассивный элемент, следовательно нужда в методах отсутствует События: Click - при щелчке по контролу DblClick - при двойном щелчке по контролу CaptionClick - при щелчке по надписи MouseDown - при нажатии клавиши мыши MouseMove - при перемещении курсора над контролом MouseUp - при отпускании клавиши мыши Теперь самое время переназвать проект и сам контрол. Имена не должны повторяться. Щелкнем правой клавишей в окне проектов на имене Project1 и в выпадающем меню выберем Project1 Properties… В открывшемся диалоговом окне под надписью Project Name вписываем свое название проекта - в данном случае - contZygZag, а под надписью Project Description - Контейнер с "плавающей" надписью. Именно эта запись будет появляться у Вас потом, когда Вы будете выбирать свой контрол для установки в приложении. Нажимаем "ОК" Далее вместо UserControl1 в свойстве Name напишем ZigZag, а так же выберем свойство ControlContainer и установим его в True. Помещаем на контрол два стандартных элемента Label (Name = lblCaption, AutoSize = True, BackStyle = 0-Transparent, Caption = ZigZag, Left = 0, Top = 0) и Timer (Interval = 100, Enabled = False). Теперь самое время сохранить проект. Следующим этапом является написание кода. Воспользуемся для этого специальным мастером, предоставляемым нам VB. Выберите меню Add-Ins/Add-In Manager…В диалоговом окне выберите ActiveX Ctrl Interface Wizard. Теперь он появился и в меню. Вызовем его. В первом шаге Wizard'а в правом списке (Selected names) оставим только те свойства и события, которые мы определили выше. Из левого списка туда же добавим те, которые VB не захотел поместить автоматически (Caption, Interval). Перейдем к следующему шагу. Допишем те свойства и события, которым мы дали свои названия (TimerOn - Property и CaptionClick - Event). В следующем шаге определимся в привязке всего выбранного к существующим элементам: Public Name Control Member BackColor UserControl BackColor BorderStyle UserControl BorderStyle Caption lblCaption Caption CaptionClick lblCapton Click Click UserControl Click DblClick UserControl DblClick Font lblCaption Font ForeColor lblCaption ForeColor Interval Timer1 Interval MouseDown UserControl MouseDown MouseMove UserControl MouseMove MouseUp UserControl MouseUp TimerOn Timer1 Enabled Помечены все выбранные свойства и события - нажимаем кнопку "Finish". Код в черновике готов. NB! Для тех кто пишет на VB5 (в VB6 эта ошибка исправлена) - внесите маленькие дополнения: в Private Sub UserControl_ReadProperties(PropBag As PropertyBag) - строка, где описывается Font должна звучать следующим образом - Set lblCaption.Font = PropBag.ReadProperty("Font", Ambient.Font); и аналогично в Private Sub UserControl_WriteProperties(PropBag As PropertyBag) - Call PropBag.WriteProperty("Font", lblCaption.Font, Ambient.Font) Сохраним проект. Теперь самое время посмотреть, что же у нас получилось. Выберем меню File/Add Project и в диалоговом окне - Standart EXE. В окне проектов щелкните правой клавишей мыши на новом проекте и выберите контекстное меню Set As Start Up, чтобы при запуске он стартовал первым. Желательно (но совсем не обязательно) переименовать вновь созданный проект и форму, например prjTest и frmTest соответственно. Теперь на форме можно разместить свой ActiveX Control, выбрав его на панели со стандартными элементами (окно с самим элементом должно быть закрыто). Поиграйте со свойствами - получается? Не все? Будем исправлять. Вызывает некоторое удивление свойство BorderStyle - возможность устанавливать только числовые значения, и то если ввести допустим цифру 2, то возникает ошибка. Конечно можно сделать проверку на ограниченный ввод значений записав это в Property Let. Но давайте ограничим саму возможность ввода с клавиатуры, а сделаем только возможность выбора. Для этого в самом начале листа кодов, сразу после Option Explicit сделаем такую запись: Public Enum constBorderStyle Нет = 0 Окантовка = 1 End Enum , соответственно, изменим первые строки в Property для BorderStyle наPublic Property Get BorderStyle() As constBorderStyle и Public Property Let BorderStyle(ByVal New_BorderStyle As constBorderStyle) А теперь снова откроем frmTest и посмотрим свойство BorderStyle - ну как? нравится? А теперь самое главное опишем передвижение нашего Label по контролу. В области General создадим переменную: Private Motion As Integer. И запишем передвижение: Private Sub MoveZygZag() Select Case Motion Case 1 lblCaption.Move lblCaption.Left - 50, lblCaption.Top - 50 If lblCaption.Left <= 0 Then Motion = 2 ElseIf lblCaption.Top <= 0 Then Motion = 4 End If Case 2 lblCaption.Move lblCaption.Left + 50, lblCaption.Top - 50 If lblCaption.Left >= (UserControl.Width - lblCaption.Width) Then Motion = 1 ElseIf lblCaption.Top <= 0 Then Motion = 3 End If Case 3 lblCaption.Move lblCaption.Left + 50, lblCaption.Top + 50 If lblCaption.Left >= (UserControl.Width - lblCaption.Width) Then Motion = 4 ElseIf lblCaption.Top >= (UserControl.Height - lblCaption.Height) Then Motion = 2 End If Case 4 lblCaption.Move lblCaption.Left - 50, lblCaption.Top + 50 If lblCaption.Left <= 0 Then Motion = 3 ElseIf lblCaption.Top >= (UserControl.Height - lblCaption.Height) Then Motion = 1 End If End Select End Sub Добавим обработку события таймера: Private Sub Timer1_Timer() MoveZygZag End Sub И наконец, заключительный штрих - отцентруем Label и установим начальное направление движения: Private Sub UserControl_Resize() lblCaption.Move (UserControl.Width - lblCaption.Width) _ / 2, (UserControl.Height - lblCaption.Height) / 2 Motion = 1 End Sub И на прощанье "повязываем бантик". Открываем Paint (или любой другой графический редактор) и рисуем картинку форматом 16 х 15 пикселов, сохраняем в формате BMP. Открываем наш UserControl и в свойстве ToolboxBitmap открываем нарисованную картинку. В frmTest добавим командную кнопку и опишем ее событие - включение/выключение таймера: Private Sub Command1_Click() ZygZag1.TimerOn = Not ZygZag1.TimerOn End Sub Нажимаем F5 и тихо млеем над своим произведением. В заключение компилируем наш ActiveX Control (меню File/Make contZygZag…) - одновременно происходит прописывание его в реестр Windows Вашего компьютера. Наверх 100. Как создать ActiveX Control за 21 минуту на Microsoft Visual Basic - Visual Basic
Новая версия Visual Basic значительно расширила возможности разработчиков, пользовательский интерфейс системы претерпел значительные изменения и стал гораздо удобнее для ведения проектов. Технология ActiveX - открытый стандарт, позволяющий быстро создавать мощные интегрированные приложения и компоненты для Internet/Intranet сетей. ActiveX компоненты представляют собой функционально-законченные модули исполняемого кода, оформленные в виде .exe, .dll или .ocx файлов. Спецификация ActiveX позволяет сократить время на создание приложений за счет многократного использования готовых модулей. ActiveX – бинарный стандарт, это позволяет разрабатывать и использовать объекты в самых различных программных системах. Одной из главных среди новых возможностей Visual Basic 5.0 является способность создавать ActiveX компоненты. До сих пор Visual Basic исполнял роль “glue language”, т.е. был предназначен для создания приложений на основе готовых функциональных элементов. Сами элементы разрабатывались с помощью инструментов подобных Visual C++ и требовали от разработчика высокой квалификации. Теперь программисты на Visual Basic могут сами создавать необходимые им ActiveX компоненты. Разработанные объекты могут выступать в роли конечного продукта и использоваться другими программистами. При этом обучение и сам процесс разработки являются более простыми и требуют меньше времени. Visual Basic позволяет создавать компоненты следующих типов: * ActiveX Controls. Управляющие элементы пользовательского интерфейса, предназначенные для работы с широким кругом контейнеров, включая Web-броузеры. * ActiveX Documents. Эти объекты напоминают VB форму, могут содержать встроенные объекты, для их просмотра можно использовать Microsoft Internet Explorer. Реализуются в виде in-process или out-of-process компонент. * Code Components. Представляют собой библиотеки программно-управляемых объектов (старое название OLE Automation Server). Реализуются в виде in-process или out-of-process компонент. Данный доклад посвящён созданию ActiveX Control на Visual Basic 5.0 и рассчитан на специалистов знакомых со средой разработки Visual Basic и технологиями ActiveX и OLE. Доклад сопровождается демонстрацией процесса создания и отладки ActiveX Control. Варианты создания ActiveX Controls. Visual Basic предлагает три модели для создания ActiveX Control: * Разработка компоненты “с нуля” дает наибольшую свободу для определения пользовательского (appearance) и программного интерфейса объекта. Поместив необходимый код в процедуру обработки события Paint, Вы можете придать практически любой внешний вид control’у. * Расширение существующего ActiveX Control. Добавив новые и предоставив существующие методы, свойства и события Вы можете определить необходимый программный интерфейс объекта. Изменение внешнего вида в данном случае является непростой проблемой, т.к. используемый объект уже содержит процедуру отображения внутри себя. Но и это возможно при использовании оператора AddressOf. * Компоновка нового объекта из нескольких существующих. Этот вариант по возможностям аналогичен предыдущему. Объект UserControl. ActiveX Control, созданный на Visual Basic, всегда содержит (агрегирует) объект UserControl. Размещение и настройка свойств составляющих (constituent) ActiveX Controls производится с помощью специального редактора. Этот процесс напоминает размещение управляющих элементов на форме. UserControl имеет стандартный интерфейс. Вы можете написать свои обработчики для событий, генерируемых этим объектом, предоставить для использования или переопределить стандартные свойства. Таким же образом Ваш ActiveX Control может экспортировать методы, свойства и события составляющих компонент. Ключевые события. В процессе своего существования ActiveX Control получает извещение о ряде событий, генерируемых объектом UserControl. Наиболее важными являются: * Initialize. Самое первое событие, всегда происходит при создании ActiveX Control. В этот момент объект еще не имеет связи со своим контейнером. * InitProperties. Это событие извещает о размещении нового control’а на форме. В момент его прихода встроенный объект уже имеет связь со своим контейнером. Как правило, обработчик события выполняет начальную инициализацию свойств ActiveX Control. * ReadProperties. При загрузке формы (как в DesignMode, так и в RunMode) встроенные в неё элементы создаются заново и их свойства инициализируются сохранёнными в .frm файле значениями. Событие ReadProperties извещает ActiveX Control о необходимости выполнить эту инициализацию. В этот момент объект имеет связь со своим контейнером. * Resize. Обработчик этого события отвечает за реакцию control’а на изменении его размеров. * Paint. Обработчик этого события отвечает за отображение внешнего вида ActiveX Control. При установке свойства UserControl.AutoRedraw=True процесс визуализации происходит автоматически. * WriteProperties. Извещает ActiveX Control о необходимости сохранить текущие значения его свойств. Генерируется в DesignMode при сохранении формы-контейнера. * Terminate. Извещает ActiveX Control об его уничтожении. Последовательность событий четко определена и характеризует текущее состояние объекта. При размещении нового ActiveX Control на форме, загрузке формы, запуске проекта на исполнение (переходе из DesignMode в RunMode) все объекты создаются заново, свойства инициализируются сохранёнными значениями (или значениями по умолчанию). Контейнер и взаимодействие с ним. Экземпляр ActiveX Control не может существовать сам по себе, он всегда “живёт” внутри своего контейнера и тесно взаимодействует с ним. Через свойства окружения (ambient properties) объект имеет доступ к информации о текущем состоянии своего “хозяина”. Контейнер поддерживает дополнительные методы, свойства и события которые для разработчика выглядят как часть интерфейса ActiveX Control. Свойства окружения. Информация о состоянии контейнера доступна ActiveX Control’у через объект AmbientProperties, ссылка на который может быть получена через свойство Ambient объекта UserControl. Например, свойство UserControl.Ambient.BackColor отображает текущее значение цвета фона контейнера и обычно используется при отображении control’а. Важно отметить, что свойство BackColor принадлежит объекту AmbientProperties и по умолчанию не является внешним свойством разрабатываемого control’а и не доступно использующему его приложению. Объект AmbientProperties, который предоставляет Visual Basic, содержит все свойства, определённые в спецификации ActiveX Controls. Действительные значения этих свойств предоставляются контейнером. В случае если конкретный контейнер не поддерживает какое-либо стандартное свойство, Visual Basic возвращает для него значение по умолчанию и благодаря этому не обязательно предусматривать обработку ошибок. Некоторые контейнеры могут предоставлять дополнительные параметры окружения. Такие специфичные свойства не описаны в библиотеке типов Visual Basic и поэтому не видны в окне Object Browser. Дополнительную информацию можно найти в документации на контейнер. Доступ к таким свойствам осуществляется так же, как и к стандартным, но реализуется через механизм позднего связывания (late-bound). При обращении к нестандартным свойствам необходимо предусмотреть обработку ошибок. Хорошо написанный ActiveX Control должен визуализировать себя в соответствии с текущим состоянием контейнера. Сообщение UserControl_AmbientChanged извещает control об изменении значения какого-либо свойства окружения контейнера. Дополнительные свойства. Дополнительные свойства (extender properties) предоставляются контейнером, но внешне выглядят как часть интерфейса control’а. Например, характеристики местоположения и размера объекта, его имя относятся к таким свойствам. Разработчик ActiveX Control имеет доступ к дополнительным свойствам через свойство Extender объекта UserControl. Спецификация ActiveX Controls требует, чтобы все контейнеры поддерживали следующие дополнительные свойства: Name, Visible, Parent, Cancel, Default. На практике это требование не всегда выполняется, поэтому при обращении к extender properties необходимо предусмотреть обработку ошибок. Для доступа к дополнительным свойствам всегда используется механизм позднего связывания (late-bound), т.к. на момент компиляции неизвестно с каким контейнером ActiveX Control’у предстоит работать. Когда пользователь обращается к свойству (методу) control’а, то первым управление получает объект Extender. Если он не поддерживает это свойство (метод), то вызывается обработчик ActiveX Control’а. Создание программного интерфейса ActiveX Control. Программный интерфейс ActiveX Control – это набор открытых (public) методов, свойств и событий, посредством которых происходит взаимодействие объекта с внешним миром. По умолчанию интерфейс control’а ограничивается набором методов, свойств и событий, предоставляемых контейнером, при этом интерфейс составляющих объектов снаружи не доступен. Задача разработчика заключается в добавлении новых (custom) свойств и методов, генерации событий и выставлении наружу (expose) интерфейса составляющих объектов. Свойства. Открытые свойства control’а необходимо реализовывать с помощью процедур Property Get и Property Let. Это требование связано с необходимостью извещать Visual Basic посредством вызова метода UserControl.PropertyChanged при изменении значения свойства пользователем. Выполнение этого требования необходимо по следующим причинам: * Если не вызвать метод PropertyChanged, то Visual Basic не передаст управление обработчику UserControl_WriteProperties для сохранения результатов редактирования в DesignMode и они будут утрачены. * Значение свойства может быть одновременно доступно в нескольких местах, например, в окне Properties и в диалоге Property Pages. Вызов PropertyChanged синхронизирует отображаемую информацию. Если для свойства созданы обе процедуры (Property Get и Property Let), то оно автоматически высвечивается в окне Property. Диалог Property Attributes меню Tools позволяет установить дополнительные атрибуты свойства. Сохранение и восстановление состояния объекта. Каждый раз, когда форма загружается для редактирования или исполнения все встроенные объекты создаются заново. Для сохранения свойств ActiveX Control между сеансами редактирования и для инициализации при запуске в RunMode служит механизм Property Persistence. Его реализация связана с тремя событиями: InitProperties, ReadProperties и WriteProperties, которые генерируются при размещении нового control’а на форме, считывании и сохранении состояния объекта соответственно. Обработчики UserControl_WriteProperties и UserControl_ReadProperties получают в качестве параметра объект PropertyBag. Он имеет два метода: * ReadProperty(Name As String, [DefaultValue]). * WriteProperty(Name As String, Value, [DefaultValue]). Используя эти методы разработчик ActiveX Control’а должен реализовать механизм сохранения и восстановления состояния объекта. В методе WriteProperty аргумент DefaultValue используется для экономии места при записи. WriteProperty проверяет текущее значение сохраняемого свойства с DefaultValue и при равенстве запись не производит. Рекомендуется для каждого свойства определять константу, равную значению по умолчанию и использовать ее при обработке событий InitProperties, WriteProperties и ReadProperties. В UserControl_ReadProperties необходимо предусмотреть проверку на корректность считываемых значений свойств. Методы. Для реализации новых методов программного интерфейса ActiveX Control’а достаточно просто добавить открытые (public) процедуры (sub) и/или функции (function). Для видимых в RunMode объектов необходимо, как минимум, реализовать метод Refresh. Обычно он просто вызывает Refresh объекта UserControl, при этом user-drawn control получает сообщение Paint и производит свою отрисовку. События. Генерация событий – новая черта Visual Basic 5.0. События позволяют ActiveX Control’у активно взаимодействовать со своим контейнером. Механизм работы с событиями достаточно прост. Необходимо выполнить два шага: * Объявить событие с помощью выражения типа: Public Event EventName [(arglist)]. * Сгенерировать событие при помощи оператора RaiseEvent. Рекомендуется, чтобы ActiveX Control генерировал следующие стандартные события: Click, DblClick, KeyDown, KeyPress, KeyUp, MouseDown, MouseMove и MouseUp. Использование ActiveX Control Interface Wizard. ActiveX Control Interface Wizard автоматизирует процесс создания кода для реализации программного интерфейса, позволяет выполнять следующие операции: * Добавление стандартных методов, свойств и событий. * Добавление дополнительных (custom) методов, свойств и событий. * Задание атрибутов для открытых методов, свойств и событий. Разработка Property Pages. Диалоги Property Pages предлагают альтернативный способ настройки свойств ActiveX Control. Группы логически связанных свойств могут быть размещены на отдельных страницах диалога. Visual Basic 5.0 позволяет разрабатывать и использовать стандартные страницы. Разработка пользовательского интерфейса Property Page аналогична разработке формы, но процесс написание кода отличается. Объект PropertyPage является базовым при разработке страниц диалога. В программном интерфейсе этого объекта наибольший интерес представляют: * Событие SelectionChanged. Генерируется при изменении списка control’ов редактируемых с помощью диалога Property Pages. Поскольку диалог является немодальным, необходимо отслеживать это событие. Список текущих выделенных для редактирования ActiveX Control’ов хранится в коллекции PropertyPage.SelectedControls. * Свойство Changed. При изменение пользователем значений свойств ActiveX Control’а необходимо устанавливать PropertyPage.Changed=True, иначе Visual Basic не будет оповещён об изменениях и кнопка «Применить» (Apply) останется недоступной (disable). * Событие ApplyChanges. Обработчик вызывается при нажатии кнопок Ok, Apply, а также, если пользователь переходит на другую страницу диалога (tab). Необходимо установить значения свойств в соответствии с введенными величинами. Visual Basic предоставляет для использования три стандартных страницы: * StandartFont. * StandartColor. * StandartPicture. При редактировании свойства типа Font, OLE_COLOR или Picture в окне свойств (properties window) автоматически вызывается соответствующая страница Property Page. Инструмент Property Page Wizard помогает построить property pages для ActiveX Control’а. Для связывания отдельных страниц с ActiveX Control’ом служит диалог Connect Property Pages, который позволяет выбрать из списка доступных страниц необходимые и определить их взаимный порядок следования в диалоге редактирования свойств. Использование ActiveX Control в Internet-приложениях. ActiveX компоненты, разработанные на Visual Basic, могут быть использованы для построения Internet-решений. Можно включать ActiveX Control’ы в HTML-странички и с помощью языка VBScript настраивать их свойства, вызывать методы, обрабатывать события. Такая возможность позволяет делать Internet-приложения интерактивными, придавать им удобный пользовательский интерфейс. Приложения типа MS ActiveX Control Pad позволяют автоматизировать процесс встраивания и настройки ActiveX Control при создании HTML-страниц. Распространение компонент. Разработка компонент на Visual Basic может быть проведена двумя способами: * ActiveX Control проект может содержать несколько модулей ActiveX Control (.ctl-файлов). При этом control’ы имеющие свойство UserControl.Public=True доступны вне проекта для всех приложений. * Закрытые (private) ActiveX Control могут быть включены в проект любого типа, они доступны только внутри своего приложения. Распространяя написанные Вами ActiveX Control’ы, Вы предоставляете возможность другим разработчикам использовать их при создании приложений. ActiveX компоненты, созданные на Visual Basic, требуют при исполнении наличия динамических библиотек (VB run-time DLL), кроме того, если ActiveX Control использует другие компоненты, то необходимо также поставлять все необходимые им файлы. Приложение Setup Wizard помогает определить все необходимые составляющие компоненты и создаёт стандартную программу установки. Процесс распространения ActiveX компонент имеет два аспекта: лицензирование и совместимость версий. Лицензирование. Visual Basic поддерживает механизм защиты разработанных Вами компонент от нелегального использования. Для включения этого механизма необходимо отметить пункт Require License Key в диалоге установки свойств проекта. В этом случае при компиляции проекта будет создан .vbl-файл, содержащий регистрационный ключ (registry key). При создании инсталляционной программы Setup Wizard автоматически добавит процедуру регистрации устанавливаемых компонент. При попытке использования ActiveX компоненты для разработки другого приложения будет проверено наличие лицензии на машине разработчика. При распространении разработчиком продукта, использующего Вашу компоненту на компьютере пользователя лицензия устанавливаться не должна, это позволит использовать ActiveX Control только в режиме исполнения (RunMode). При использовании ActiveX Control’а на WWW страницах броузер клиента запрашивает у сервера лицензионный ключ и использует его для создания объекта, при этом полученная лицензия в регистрационную базу (Registry) компьютера клиента не добавляется. Совместимость версий. При разработке новой версии ActiveX Control’а необходимо предусмотреть обратную совместимость по следующим моментам: * Программный интерфейс объекта, т.е. набор его свойств, методов и событий. * Влияние установленных свойств объекта UserControl на поведение control’а. * Сохранение и восстановление состояния объекта. * Атрибуты процедур. Новая версия может иметь новые открытые методы, свойства и события, но удаление или изменение аргументов существующих приведет к несовместимости. Visual Basic может выполнять автоматическую проверку на совместимость программного интерфейса. Для этого необходимо отметить Binary Compatibility в диалоге свойств проекта. Изменение настроек свойств объекта UserControl также может быть причиной несовместимости версий. Например, если ранняя версия была скомпилирована с UserControl.ControlContainer=True, а в следующей это свойство было изменено на False, то ActiveX Control потеряет возможность выступать в роли контейнера для других объектов. При этом приложения, оттестированные со старой версией control’а, с новой могут не работать. Если в новой версии какое-то свойство оставлено только для совместимости, то необходимо восстанавливать его значение при загрузке (сообщение ReadProperties). Сохранять (сообщение WriteProperties) его не обязательно. Изменение свойства, обращение к которому происходит “по умолчанию” (default property) также может быть причиной несовместимости. Заключение. Процесс разработки ActiveX Controls на Visual Basic также прост, как и … всё на Visual Basic. Большое количество средств автоматизации разработки (Wizards), удобный пользовательский интерфейс, средства отладки и хорошая справочная система позволяют быстро разрабатывать компоненты, обладающие широкими возможностями и готовые для построения Internet-решений. С появлением возможности разработки ActiveX Controls количество сторонников такого популярного средства разработки как Microsoft Visual Basic, несомненно, возрастёт. Наверх 101. WithEvents - добавление новых свойств к стандартным контролам - Visual Basic
Наверное, каждый встречался с такой ситуацией: создана форма, расположены на ней контролы, написан основной код. И вдруг необходимо какое-то небольшое дополнение. Причем, это дополнение вполне могло бы быть одним из свойств расположенных на форме контролов. Однако, как показывает ситуация, в 99% случаев такого свойства контрол не содержит. Все гораздо проще, если данный ActiveX Control писали вы сами и у вас сохранились исходники. Вы просто добавляете новые свойства, методы или события и заново компилируете его. Совсем не ординарная ситуация получается если вы хотите добавить, допустим, какое-то новое свойство к стандартному элементу управления. Исходных кодов у вас, естественно, нет и тогда встает вопрос: "Как быть в данной ситуации?" То ли отказаться от задуманного нововведения, то ли самому написать ActiveX Control, то ли написать код для обработки данной ситуации. Однако Visual Basic, оказывается, предусмотрел выход из данной ситуации. И этот выход WithEvents. Давайте на примере обычного Label добавим к нему новое свойство. Пусть это будет открытие броузера или почтовой программы при выполнении события Click. Разобравшись, как это делается, вы не будете испытывать неудобства в ситуациях, описанных выше. Шаг 1. Создадим новый проект Standard EXE. Name=WithEventsSample Изменим имя формы на frmMain. Расположим на ней 4 Label. Их свойства указаны в следующей таблице: Name Caption ForeColor Font.Underline lblInfo1 Посетите сайт: &H80000012& False lblHomePage http:\\www.mik.h1.ru &H00800000& True lblInfo2 Связаться с автором &H80000012& False lblEMail miceskin@usa.net &H00800000& True NB! Адреса сайта и электронной почты указаны здесь как образец, в своих программах вы можете использовать любые другие корректные адреса. Шаг 2. Добавим к проекту модуль класса. Name=clsNewProperty В разделе деклараций объявим API vфункцию ShellExecute и константу для нее SW_NORMAL. Данная функция послужит нам для открытия броузера или почтовой программы. Сделаем объявление WithEvents Private WithEvents NewLabel As Label Теперь, если мы нажмем в коде класса выпадающее меню с перечнем контролов, то увидим появившуюся там новую строку NewLabel. Если мы его выберем, то появится объявление его события по умолчанию. Так как у Label основным событием является Click, то и у NewLabel, основанном на нем, событием по умолчанию будет являться также Click. Пока оставим его в покое. Создадим свойство для связи Label, расположенного на форме, с нашим классом Public Property Set LabelControl(ExternalLabel As Label) Set NewLabel = ExternalLabel End Property Шаг 3. Добавим еще одно свойство, определяющее выполняемое действие: открытие броузера, открытие программы или ничего не делать. NB! В данных ситуациях предпочтительно (хотя и необязательно) предусматривать НЕ обработку ситуации, чтобы остальных идентичных контролов не коснулись наши изменения. Создадим нумерованную константу в разделе деклараций, там же объявим внутреннюю переменную для этого свойства Public Enum constTypeMsg None = 0 HomePage = 1 EMail = 2 End Enum Private mvarTypeMsg As constTypeMsg Теперь напишем само свойство. NB! Само свойство можно создать с помощью Class Builder Utility. Public Property Let TypeMsg(ByVal vData As constTypeMsg) mvarTypeMsg = vData End Property Public Property Get TypeMsg() As constTypeMsg TypeMsg = mvarTypeMsg End Property Шаг 3а. Сейчас нам необходимо сделать обработку события Click для NewLabel. Опираться мы будем на состояние свойства TypeMsg. Для состояния None мы не будем описывать никаких изменений. Состояние HomePage вызывает через функцию ShellExecute открытие броузера, а состояние Email v открытие почтовой программы по умолчанию. Private Sub NewLabel_Click() Select Case mvarTypeMsg Case None Case HomePage Dim X X = ShellExecute(0&, "Open", NewLabel.Caption, &O0, &O0, SW_NORMAL) Case EMail Call ShellExecute(0&, "Open", "mailto:" + NewLabel.Caption + &n 1000 bsp; _ "?Subject=" + "About WithEventsSamples", "", "", SW_NORMAL) End Select End Sub Шаг 3b. Изменим состояние курсора при попадании его на адрес, учитывая состояние свойства TypeMsg. Для этого вначале скопируем в свою папку курсор "указывающего пальца". Загрузку данного курсора можно производить через метод LoadPicture (как в нашем примере), либо использовать для этого файл ресурсов. Private Sub NewLabel_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Select Case mvarTypeMsg Case None 'NewLabel.MousePointer = vbDefault Case HomePage NewLabel.MouseIcon = LoadPicture(App.Path & "/H_POINT.CUR") NewLabel.MousePointer = vbCustom Case EMail NewLabel.MouseIcon = LoadPicture(App.Path & "/H_POINT.CUR") NewLabel.MousePointer = vbCustom End Select End Sub Вот, собственно говоря, и все, что необходимо сделать в классе. Шаг 4. Перейдем в форму. В разделе деклараций объявим новый класс как класс clsNewProperty для каждого из Label. NB! Для тех контролов, у которых мы НЕ хотим иметь дополнительно созданные нами свойства, мы класс НЕ объявляем. В событии Form_Load инициализируем каждый класс, выполняем привязку контрола к этому классу через событие LabelControl и для соответствующих контролов выполняем событие TypeMsg. Private Sub Form_Load() Set clsLabelHomePage = New clsNewProperty Set clsLabelHomePage.LabelControl = lblHomePage clsLabelHomePage.TypeMsg = HomePage Set clsLabelEMail = New clsNewProperty Set clsLabelEMail.LabelControl = lblEMail clsLabelEMail.TypeMsg = EMail Set clsLabelInfo1 = New clsNewProperty Set clsLabelInfo1.LabelControl = lblInfo1 clsLabelInfo1.TypeMsg = None Set clsLabelInfo2 = New clsNewProperty Set clsLabelInfo2.LabelControl = lblInfo2 clsLabelInfo2.TypeMsg = None End Sub Запустите проект на исполнение и проверьте полученный результат. Надеюсь, теперь с недостатком свойств у стандартных контролов проблем у вас не возникнет. Наверх 102. 88 советов по оптимизации приложения - Visual Basic
ПЕРЕМЕННЫЕ: ВСЕГДА ПРИДЕРЖИВАЙТЕСЬ ЭТИХ ПРАВИЛ 1. Всегда используйте Integer или Long тип переменных, вместо Single, Double, или Currency где это возможно. Математические операции с типами Integer и Long делаются за 1 такт процессора, и следовательно гораздо быстрее. 2. Используйте Single вместо Double, если Вам не нужна точность Double. Переменная типа Single требует меньше памяти и работает быстрее в математических выражениях. 3. Не пользуйтесь типом Variant, если не нуждаетесь в его особенных свойствах, таких например, как хранение величин типа Empty и Null. Каждая переменная Variant занимает 16 байт (против 8, занимаемых Double или Currency) и в общем очень тормозная. 4. Обязательно добавьте в раздел General каждого модуля директиву Option Explicit. Это снизит риск неумышленного использования необъявленных Variant-переменных. Как альтернатива можно использовать директиву DefLong A-Z , которая подразумевает, что все необъявленные переменные имеют тип Long. Добавьте предупреждение в начало модуля – это гарантирует, что редакторы не пропустят эти директивы. 5. Локальные переменные типа Static в 2-3 раза медленнее, чем обычные локальные переменные. Если Вы хотите ускорить свою программу, преобразуйте все статические переменные в переменные уровня модуля. Единственный недостаток этого подхода, это то, что процедуры, модуля, использующие их, станут модулезависимыми. И если Вы захотите перенести эти процедуры в другой проект, не забудьте перенести вместе с ними и переменные уровня модуля. 6. Ссылки на переменные, объявленные на уровне модуля быстрее, чем глобальные переменные, объявленные в отдельном модуле. Если Вам не нужен общий доступ к переменным из всех программ и модулей, объявляйте их только в тех модулях или формах, которые их используют. ЯВНЫЕ И НЕЯВНЫЕ ПРЕОБРАЗОВАНИЯ 7. Остерегайтесь использовать функции Int и Val - они всегда возвращают вещественное значение с плавающей точкой. Если вы используете Long или Integer применяйте CInt or CLng. Вы можете использовать 4 способа преобразования text-box величины в значение типа Integer или Long: result% = Val(Text1.Text) result% = Int(Text1.Text) result% = CInt(Text1.Text) result% = Text1.Text Каждое утверждение в этом коде немного быстрее чем предыдущее; последнее - приблизительно на 30 процентов быстрее, чем первое. 8. Используйте "\" вместо "/" при делении целых. Избегайте лишних неявных преобразований, так как оператор "/" возвращает значение Single. Имейте в виду, что оператор "/" возвращает значение Double если по крайней мере один из элементов имеет тип Double. С другой стороны, если Вы хтите повысить точность вычислений при делении Single или Integer, Вы можете вручную привести один из аргументов к типу Double: ' Это печатает 0.3333333 Print 1 / 3 ' А это печатает 0.333333333333333 Print 1 / 3# 9. Бейсик хранит константы , в наиболее простой форме - скажем константа несущая единицу хранится как целое, если вы предполагаете использовать ее для действий с вещественными числами, объявите ее явно: value# = value# + 1# Это предотвратит компилятор от хранения ее в формате Double, и сохранит от одного преобразования при каждом обращении. Вы такж можете использовать именованные константы: Const ONE As Double = 1 УРОКИ МАТЕМАТИКИ 10. Самые быстрые функции - те, результаты работы которых Вы можете оценивать заранее. Например, сохранение факториалов всех чисел в диапазоне от одного до 100 в массив один раз в начале программы - намного быстрее чем предположительные тысячи вызовов функции в течение работы приложения. Вы можете увидеть проблему такого подхода в том, что вычисляются все значения, даже те, которые не требуются во время выполнения программы, и придется держать глобальный массив значений. Это делает неудобным повторное использование Ваше разработки. Вы можете обойти эти проблемы путем использования массива Static в своей программе См. Листинг 1. 11. Используйте оператор And вместо Mod, когда делитель - число в формате 2 ^ N. Например, Вы можете использовать два метода для извлечения самого младшего байта в Integer: lowByte% = value% Mod 256 ' А так немного быстрее … lowByte% = value% And 255 12. Используйте Boolean в операторах сравнения. Например: If x <> 0 Or y <> 0 Then ... ' Работает так-же как это: If x Or y Then ... ' А это: If x = 0 And y = 0 Then ... ' Так-же как это : If (x Or y) = 0 Then ... Даже оператор XOR может сэкономить немного времени: If (x = 0 And y = 0) Or (x <> 0 And y <> 0) Then ... ' А побыстрее так: If (x = 0) Xor (y <> 0) Then .. 13. Иногда Вы можете заменить весь If...Else блок более простой Логической операцией. Например, Вы можете заменить этот код: If x > 0 Then y = 1 Else y = 0 На другой, хотя и весьма загадочный y = -(x > 0) Однако, это тот случай, когда жертвуется понятным синтаксисом в пользу повышения производительности. При этом Вы обязательно должны добавить замечание, которое ясно объясняет, что ваш код делает , во избежании проблем с сопровождением в дальнейшем ПУТИ УСКОРЕНИЯ МАССИВОВ 14. Чтение и запись элемента массива всегда медленнее, чем доступ к простой переменной. Следовательно, если Вы хотите использовать один и тот же элемент массива в цикле неоднократно, назначьте временной переменной ссылку на этот элемент, и используйте именно ее. В циклах повышение производительности может достигать 80 процентов 15. По той же самой причине, обращение к элементам в матрице медленнее чем доступ к элементам в одномерном массиве. Примите это во внимание при проектировании ваших алгоритмов. Например, при программировании игры в шашки, лучше предпочесть одномерный массив на 64 элемента матрице 8 на 8. 16. При частом поиске в массиве, элементы которого не меняеются, имеет смысл отсортировать элементы массива и воспользоваться быстрым двоичным поиском (binary search). С другой стороны, сортировка - медленная операция, и один из продвинутых подходов заключается в применении Хэш-таблиц (Hash tables), если у Вас достаточно памяти. Я не буду описывать Hash tables в этой статье, но Вы можете использовать их для оптимизации программы AnyDuplicates, как показано в Листинге 2 (См. Листинг 3). Вас удивят результаты. 17. Если Ваш массив типа Integer содержит элементы значением от 0 до 255 , то имеет смысл преобразовать его в массив типа Byte. Это не ускорит код, но уменьшит ресурсоемкость, что актуально для старых машин. 18. Копируйте блоки данных между массивами одного типа, используя функцию API CopyMemory вместо цикла For...Next: Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ (dest As Any, As Any, ByVal bytes As Long) ' Копируем a() в b() - b() того же типа что и а() ' Размерность N показывает число копируемых элементов CopyMemory b(0), a(0), n * Len(a(0)) Эту функцию можно использовать для массивов любого типа, за исключением строк переменной длины, объектов и пользовательских типов, их содержащих. 19. Вы можете использовать эту функцию для сдвига элементов массива без цикла с вставкой или удалением одиночного элемента. (Я описываю эту технику в своей статье "Get the Most Out of Your Arrays" VBPJ Июль 1997) 20. При работе с матрицами используя вложенные циклы - внешний цикл должен выполнить итерации на столбцах, а внутренний - итерации на строках. (VB, сохраняет матрицы один столбец после другого) Программа вызывает меньшее количество "листания". Когда Вам надо просканировать большую двухмерную матрицу, работайте с ней ориентируясь на столбцы. Другими словами внешний цикл For … Next должен быть по столбцам, а внутренний – по строкам. При этом Вы работаете с элементами массива так, как они размещаются в памяти (VB хранит массивы в памяти столбцами – один после другого) и таким образом уменьшается страничная активность. См. мою статью "Get the Most Out of Your Arrays" [VBPJ Июль 1997], для примера программы, которая в 10 раз быстрее, чем программа с инвертированным доступом в двух вложенных циклах. 21. Никогда не используйте For Each на Variant массивах. Обычный For Loop с Integer или Long индексом как минимум в двое быстрее. 22. Если вы абсолютно уверены, что ваша программа VB5 никогда не выдает "Subscript out of range" error, компилируйте native код с опцией "Remove Array Bounds Check". Это может ускорить программу, интенсивно работающую с массивами, на 50% или более. РАЗБЕРИТЕСЬ СО СВОИМИ СТРОКОВЫМИ ОПЕРАЦИЯМИ 23. Конкатенация - это медленная операция. Если вы хотите заменить 1-2 символа в строке - используйте ф-цию Mid$: Mid$(a$, 1, 1) = "A" Hе используйте такой код : a$ = "A" & Mid$(a$, 2) 24. Cтроковые переменные фиксированной длины часто медленнее чем стандартные строковые переменные. Фактически, все строковые функции работают только со строками переменной длины. Следовательно, все строки фиксированной длины сначала должны быть преобразованы, прежде, чем обработаются. Это может замедлить ваш код раза в три или четыре. 25. Держитесь подальше от функций без значка "$" таких как Left и Trim, т.к. они возвращают значение типа Variant. Обычные функции Left$ и Trim$ возвращают результат немедленно, без его неявного преобразования в Variant. 26. Использование ASCII кода при сравнении намного быстрее использования самого символа. Например: ' Сравнение с пробелом. If Left$(a$, 1) = " " Then ... ' Сравнение через код (на 40% быстрее) If Asc(a$) = 32 Then ... Такой подход обычно используют в блоках Select Case 27. Используйте встроенные строковые константы вместо Chr$ (). Hапример, используйте vbTab вместо Chr$ (9), и vbCrLf вместо Chr$ (13) и Chr$ (10). 28. Использование функции Len, чтобы проверить, содержит ли строка символы- приблизительно на 25 процентов быстрее чем явное сравнение с пустой строкой If Len(a$) = 0 Then ... 29. Часто VB программисты сравнивают строки , используя LCASE$ или UCASE$, чтобы преобразовать обе строки перед сравнением. Однако, быстрее прибегнуть к редко используемой функции StrComp: If StrComp(a$, b$, vbTextCompare) = 0 Then 'строки равны End If 30. Точно также, когда Вам нужно найти подстроку без учета регистра, используйте четвертый параметр функции InStr: If InStr(1, a$, "vb", vbTextCompare) Then ... Заметим, что при такой форме синтаксиса, Вы не можетие опустить первый аргумент. Если Ваша программа применяет поиск и сравнение исключительно без учета регистра, можете добавить директиву "Option Compare Text" в первую строку каждого модуля. 31. Функция InStr позволяет Вам быстро проверить содержится ли одиночный символ в списке символов. Hапример, так Вы можете определять, содержит ли a$ гласную: isVowel = InStr("aeiou", a$) 32. Когда Вам надо обработать каждый символ в строке, поместите строку в массив байтов и оперируйте с элементами массива. Помните что каждый символ Unicode описывается двумя байтами. Такой подход обычно быстрее, т.к. он не использует обычную в таких случаях функцию Mid$ и не нужно создавать временные строки. Например, самый быстрый способ подсчитать кол-во пробелов в строке: Dim b() as Byte, count As Integer b() = source$ For i = 1 to UBound(b) Step LenB("A") If b(i) = 32 Then count = count + 1 Next Отметим нестандартное использование функции LenB(). Она возвращает 2 под VB4/32 и VB5, и 1 под VB4/16, поэтому Вы можете использовать этот фрагмент кода без директивы #If условной компиляции. Будьте внимательны: эта техника может не прокатить, если Вы локализуете свой код для стран, использующих полный набор символов Unicode. 33. Почти забытый оператор Like может часто сохранять много циклов процессора, выполняя сложные сравнения строк в одной операции: ' ID должен быть символом, заканчивающимся тремя цифрами If ID Like "[A-Z]###" Then ... БЫСТРАЯ ЗАГРУЗКА ФОРМ 34. Если позволяет память - не выгружайте часто используемую форму - просто спрячьте ее, в следующий раз она появится мгновенно. Однако при этом событие Form_Load не произойдет, и Вы будете должны проинициализировать все поля вручную. 35. Не выполняйте длительные операции, такие как открытие базы данных или заполнение list box объемным составляющим в обработчике событий Form_Load. Это лучше сделать в обработчике события Activate. Если Ваша форма немодальная, вы можете установить флаг, чтобы форма не инициализировалась каждый раз, когда она будет терять и получать обратно фокус ввода: Private Sub Form_Activate() Static initDone As Boolean If Not initDone Then ' откройте здесь свою базу данных initDone = True End If End Sub 36. Вы ускорите загрузку форм и снизите потребляемые ресурсы, если будете применять более простые элементы управления. Например, не пользуйтесь элементом с вводом по маске (masked-edit controls) если Вам достаточно простого text box’а. В некоторых случаях можно использовать label с рамкой вместо read-only text box, набор Image, вместо Toolbar common control, маленький scrollbar вместо spin button, и т.д. 37. Всегда сбрасывайте форму в Nothing после ее выгрузки. Тем самым вы освободите всю память, занимаемую ее переменными и массивами и обеспечит ее правильную инициализацию при последующем ее вызове: Unload Form1 Set Form1 = Nothing СОВЕТЫ ПО ГРАФИКЕ ПРИДАДУТ ПРИЛОЖЕНИЮ НЕМНОГО СКОРОСТИ 38. Установка AutoRedraw в False обычно удваивает скорость большинства графических методов, а также снижает требуемое кол-во памяти для ее отображения. 39. Если Вам необходимо установить AutoRedraw в True, попробуйте использовать формы с фиксированной рамкой (fixed-border forms). Фактически, когда у формы изменяемые границы, VB занимает непрерывный кусок памяти, величиной с целый экран, даже если окно никогда не максимизируется. Наоборот, когда у формы фиксированные границы, VB занимает память только под установленный размер формы. 40. Если Ваша форма не содержит графики, или создает графические объекты в процессе работы и они не перекрывают существующие элементы управления, установите свойство ClipControls в False для ускорения работы всех графических методов. 41. Вставляете ли Вы изображения в форму при конструировании, или во время ее выполнения из файла ресурсов, - Вы должны использовать сжатые форматы изображения (compressed bitmaps). Помните, что элемент PictureBox может читать RLE и WMF форматы, а в версии VB5 также PCX и JPEG. Если Вы ранее использовали компоненты третьих фирм для работы с этими форматами, Вы можете избавиться от этого изменив и перекомпилировав свой код под VB5 и сохранив старый файл ресурсов. ТОНКО ИСПОЛЬЗУЙТЕ ЭЛЕМЕНТЫ УПРАВЛЕНИЯ 42. Используйте метод Move для изменения размеров или перемещения форм. Это быстрее, чем по отдельности изменять свойства Left, Top, Width, и Height. 43. Если Вам надо часто ссылаться на свойство какого-либо элемента (например в цикле), присвойте ссылку на него временной переменной и используйте в цикле ее, а не объект: tmp = Check1.Value For i = 1 To Ubound(arr) arr(i) = tmp Next Эта техника основана на кэшировании свойства 44. Вы можете сделать элемент невидимым перед тем как менять несколько его свойств, и после снова сделать его видимым. Это предотвратит его повторные перерисовывания и моргание. 45. Под VB3, можно ускорить свой код используя свойства, назначаемые по умолчанию для элементов. Например, для получения значения поля используйте "Text1" вместо "Text1.Text". Это несправедливо для VB4 и VB5, вне зависимости от режима компиляции (p-code или native). 46. Элемент PictureBox очень прожорлив, и если Вам не требуются такие его свойства, как поддержка DDE, графические методы, и способность содержать другие объекты – Вы можете повысить производительность своего приложения, заменив его на обычный элемент Image. 47. Используйте по возможности метафайлы (WMF) вместо растровых (BMP) в элементе PictureBox. Они требуют меньше ресурсов и обычно перерисовываются быстрее, чем растровые, когда Вы меняете их размеры. НЕ ПЛЫВИТЕ ПО ТЕЧЕНИЮ: БЫСТРОЕ ВЫПОЛНЕНИЕ КОДА 48. Никогда не используйте Single, Double, или Variant типы в качестве переменных цикла в циклах For … Next. Вы можете оптимизировать любой из своих таких циклов используя в качестве переменных типы Integer или Long. 49. В приложениях VB5, компилированных в native код, GoSubs от 5 до 6 раз медленнее, чем вызовы обычных процедур или функций. И наоборот, при компиляции в p-код GoSub быстрее. Это один из примеров, когда правила оптимизации не применимы одновременно для native и p-кода. 50. Разделите ваше выражение If , содержащее несколько условий с операторами And, на два или более блока с оператором If. Этот способ приводит к увеличению скорости, т.к. следующий If не выполняется, если предыдущий дал False. Например, одиночный If содержащий оператор And: If x > 0 And Tan(x) < 1 Then y = 1 Вы можете разделить его на два блока: If x > 0 Then If Tan(x) < 1 Then y = 1 End If Измененный код потенциально подавляет вызов функции Tan, которая сама по себе достаточно медленная. Эта техника называется схема сокращенной оценки. Большинство компиляторов, включая устаревший VB DOS компилятор автоматически генерируют код, оптимизированный с помощью этого метода. К сожалению «оптимизированный» компилятор VB здесь просто отдыхает. Более подробное описание этой техники я привожу в своей статье «Soup Up Your 32-bit Apps» в журнале VBPJ за февраль 1996. 51. В структурах Select Case и If … ElseIf всегда первыми располагайте наиболее часто встречающиеся условия. 52. Не заполняйте свой код без необходимости директивами DoEvents, особенно циклы критичные к времени выполнения. Если Вы не можете этого избежать, приемлемым решением может быть вызов DoEvents через каждые N проходов цикла, используя подобное выражение: If (loopNdx Mod 10) = 0 Then DoEvents В случае если Вам надо отслеживать события клавиатуры, или мыши, вы можете вызывать DoEvents, в случае если эти события находятся в очереди событий. Используйте для этого API функцию GetInputState: Declare Function GetInputState Lib _ "user32" Alias "GetInputState" () As Long ' ... If GetInputState() Then DoEvents 53. Аргументы Integer и Long в процедурах будут передаваться быстрее, если вы объявите их в списке аргументов с ключевым словом ByVal. Все другие типы данных нужно передавать по ссылке. Никогда не используйте ByVal для передачи строковых аргументов в локальные процедуры в своих программах. 54. Не пользуйтесь функцией IIf в критичных ко времени циклах. Стандартный блок If … Else … Endif всегда быстрее. 55. Не пользуйтесь пустыми циклами For … Next для реализации задержки в вашей программе. Используйте API функцию Sleep, которая не загружает процессор и позволяет другим приложениям в многозадачной среде работать: Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long) ' пауза в 5 сек. Sleep 5000 Заметим, что эта функция работает только под VB4/32 и VB5. Подобной функции в 16-разрядном Window’s API нет. 56. Перед окончательной компиляцией приложения, удалите или закомментируйте все неработающие куски кода, модули которые Ваша программа не вызывает, и которые часто остаются при написании новых версий. Найти неиспользуемые процедуры и функции непростая задача, и для больших проектов я пользуюсь разработками третьих фирм, которые делают это автоматически. Или запускаю Code Profiler –надстройку и смотрю, какие куски никогда не вызываются в процессе тестирования программы. ЧТЕНИЕ И ЗАПИСЬ В ФАЙЛЫ 57. VB4 и VB5 позволяют Вам записать любой массив на диск одной директивой Put: Put #1, , strArray() Вы также можете использовать директиву Get для чтения массива обратно в память: ReDim strArray(numEls) As String Get #1, , strArray() Заметим, что вы должны правильно объявить размерность массива перед чтением в него файла. Этот метод работает с любыми типами массивов, включая строки и типы определенные пользователем за исключением объектов. 58. Самый быстрый путь считать текстовый файл в строковую переменную или элемент управления text-box – это использовать функцию Input$: Text1.Text = Input$(#1, LOF(1)) 58. Если надо записать множество маленьких кусочков данных в текстовый файл, объедините их в одну тестовую строку и пишите ее за один заход одним оператором: ' Сохранение содержимого строкового массива в текстовый файл. For i = 1 To UBound(sArr) temp$ = temp$ & sArr(i) & vbCrLf Next Open "notes.txt" For Output As #1 Print #1, temp$ Close #1 НОТАЦИИ КЛАССОВ В ОБЪЕКТАХ И КОЛЛЕКЦИЯХ 60. Ускорить доступ к свойствам, или методам объектов можно уменьшением числа «точек» в выражении. Например, когда Вам надо сослаться на несколько «вложенных» объектов или элементов управления повторно: Form1.Text1.Text = "" Form1.Text1.ForeColor = 0 Вы можете использовать временный объект или директиву With: With Form1.Text .Text = "" .ForeColor = 0 End With 61. Свойства, определенные как переменные типа Public, всегда быстрее, чем пара свойств Let/Get даже на разных версиях VB. Это составляет около 7 раз для VB4, и только 4 раза на VB5. 62. В приложениях, откомпилированных с опцией native-compiled VB5, вызов свойств или методов объявленных как Friend около 6 раз быстрее, чем простой вызов их как Public, вне зависимости от их определения (Private или Public) в классе. 63. Ссылайтесь на элемент коллекции с помощью строкового ключа: rootName = MyCollection("Root").Name Это быстрее, чем ссылки через числовой индекс. Несмотря на это числовой индекс быстрее, если нужно обратиться к первому элементу коллекции, но он тормозит, когда читается элемент, расположенный в области больших индексов. 64. Старайтесь всегда использовать для перебора коллекций цикл For Each … Next, который в 10 раз быстрее стандартного For … Next с числовыми индексами. 65. При добавлении элемента в коллекцию никогда не используйте аргументы before и after, если у Вас нет абсолютной необходимости поместить новый элемент строго в заданную позицию. 66. Если Вы хотите очистить коллекцию, не пользуйтесь циклом с Remove. Вместо этого присвойте коллекции значение Nothing. Эта техника приемлема только в том случае, если в коллекции нет элементов, ссылающихся на другие коллекции. 67. Автоматическое создание объекта при его определении директивой Dim x As New Class1, медленнее, чем простое объявление объекта директивой Dim без New, и последующая его инициализация директивой Set (Set x = New Class1). Это происходит потому, что в случае объявления New в Dim, при каждой ссылке на объект,VB проверяет нужна ли объекту инициализация. Это приводит к понижению производительности на 50% под VB4, но в принципе оно незначительно под VB5. 68. Держитесь подальше от общих объявлений (as Object) в переменных и процедурах, Которые используют позднее связывание. Всегда используйте только определенные объекты, если конечно Ваша процедура не работает с разными объектами. OLE АВТОМАТИЗАЦИЯ 69. В общем вызовы in-process DLL-серверов более быстры, чем out-of-process EXE-серверов, где-то на два порядка. 70. При передаче аргументов in- process OLE-серверам (ActiveX DLL), передавайте каждый параметр по ссылке, т.к. сервер объединяет их клиентские адресные пространства и может читать значения аргументов прямым доступом. Эта техника особенно рекомендуется при передаче длинных строк. 71. Наоборот, при передаче аргументов out-of-process OLE-серверу (ActiveX EXE), вы должны всегда передавать параметры по значению, т.к. OLE не прибегает к упорядочиванию (so OLE doesn't resort to marshaling) при возвращении управления своему клиенту. Конечно, этот совет не катит, когда Вам надо передать параметр по ссылке с целью его изменения. 72. Если Вам не нужны дополнительные возможности, предоставляемые SingleUse OLE-серверами, используйте MultiUse-сервера, которые используют меньше памяти и требуют меньше ресурсов. 73. Если ваш сервер информирует свое приложение о завершении полученной задачи, используйте механизм обратного вызова (callback) вместо события, выполняющегося через директиву WithEvent. События выполняются в 30 раз медленнее, не принимают аргументы по умолчанию, не возвращают величины, и не работают с удаленными серверами. БЫСТРЕЕ, ЧЕМ «КОНКОРД»: JET и DAO 74. Используйте простые типы наборов записей, которые поддерживают все необходимое для Вашей задачи. Например, если Вам нужно перебрать записи для составления отчета, Вам будет достаточно forward-only, read-only набора данных, который использует меньше ресурсов и более быстр, чем набор данных dynaset. 75. В случае 500 или менее записей, snapshot в общем более эффективен чем dynaset, исключая те случаи, когда набор содержит Memo и большие двоичные объекты (Large Binary fields). В последнем случае, применять dynaset предпочтительнее, т.к. он загружает данные только когда в коде программы на VB Вы ссылаетесь на соответствующее, содержащее эти объекты, поле. 76. Всегда фильтруйте Ваши записи используя подходящие выражения SELECT SQL, которые предпочтительнее простых пропусков при обработке записей по условию. Также при операциях вставки, изменения и удаления, применение команд SQL INSERT, UPDATE и DELETE предпочтительнее, чем использование для этого методов DAO. 77. Чаще сжимайте Вашу базу данных. Эта операция записывает таблицы в смежных страницах базы данных, перестраивает индексы, меняет статистику базы данных и перекомпилирует все запросы. 78. Используйте параметризованные объекты QueryDef, когда Вам нужно выполнить несколько выборок или действий с запросами повторно. Когда DAO компилирует объекты QueryDef, оно использует последние данные статистики для подготовки его плана выполнения. В связи с этим рекомендуется сжимать Вашу базу данных так часто, как Вы хотите изменять планы Ваших запросов основываясь на последних данных. 79. Доступ к данным, на удаленных базах данных с использованием присоединенных таблиц предпочтительнее, чем прямое их открытие методом OpenDatabase. 80. Всегда открывайте свою базу данных в режиме read-only («только чтение»), если Вы не хотите изменять данные. Такая практика предотвращает блокировки и ваша программа (а также и все другие приложения, которые совместно используют эту базу данных) будет работать быстрее. 81. Для повышения производительности заключайте ваши изменения в транзакции с помощью методов BeginTrans и CommitTrans. Однако учтите, что ожидающие завершения транзакции сохраняются в памяти насколько это возможно, и слишком много незавершенных транзакций требуют создания временной базы данных на диске что приводит к диким торможениям. Чтобы этого не произошло, завершайте транзакцию с помощью CommitTrans и начинайте новую через каждые N записей(см. Листинг 4). Так как транзакции подразумевают реальную блокировку данных, никогда не включайте в транзакции функции интерфейса пользователя, и всегда завершайте или откатывайте их по возможности. 82. Значительно ускоряет ядро Jet Engine 3.5 новая команда SetOptions, с помощью которой вы можете перезаписать значения по умолчанию в реестре Windows. Например Вы можете контролировать размер внутреннего буфера ( опция dbMaxBufferSize), как часто он будет сбрасываться на диск (опции dbSharedAsynchDelay и dbExclusiveAsynchDelay), как часто ядро будет предпринимать попытки блокировать страницу (опция dbLockDelay), и количество этих попыток (опция dbLockRetry). Для подробной информации читайте help по VB5. 83. Если вы не знаете, как долго будет выполняться запрос и сколько записей он возвратит, вы можете использовать объект QueryDef и установить его свойство MaxRecord в приемлемое значение такое, как 100 или 200 такое, как 100 или 200 записей. НА ЛЕТУ: ODBCDIRECT И RDO 84. Скопировав на машину клиента удаленные маленькие таблицы, данные в которых редко меняются, Вы обеспечите быстрый доступ к ним. При таком подходе Ваше приложение должно при каждом своем запуске проверять не обновились ли эти таблицы на сервере и скачивать их на рабочую станцию в случае их обновления. 85. Используя свойство QueryTimeOut объекта rdoQuery Вы можете предотвратить долгое ожидание окончания выполнения запроса. По истечении заданного времени RDO инициирует событие QueryTimeOut для родительского объекта rdoConnection и вы можете его перехватить и обработать в программе, решив что делать дальше: продолжать ждать или прервать выполнение запроса. 86. Вы можете cделать удаленные запросы менее тормозными, используя так называемое preconnection (предварительное соединение) к источнику данных ODBC. В начале программы откройте и сразу же закройте базу данных. Эти действия не разорвут само соединение, которое может оставаться активным до 10 минут. Вы можете изменить это время подбором величины ConnectTimeOut в ключе реестра ...\Jet\3.5\Engines\ODBC 87. Вы также можете сделать сетевой трафик минимально возможным, работая с наборами записей типа dynaset 100 записей и меньше. Фактически dynaset содержащий более 100 записей требует два соединения (connections) – одно для записей, и одно для ключей. Однако другие dynaset’ы могут использовать последнее соединение для своих собственных ключей. 88. Когда вы используете оптимистическое изменение в удаленной таблице содержащей много полей, вы можете сделать операции удаления (insert) и добавления (delete) более эффективными, если добавите поле типа временной метки (timestamp) в таблицу с помощью команды SQL, например «ALTER TABLE RemoteTable ADD COLUMN VersionID TIMESTAMP». Добавление такого поля позволит ядру базы данных сравнивать только новое поле VersionID вместо целой записи для выяснения не редактирует ли кто другой текущую запись. BONUS TIP №1. Значительно понизить сетевой трафик можно также применением оптимистических курсоров (Client Batch cursors), которые доступны в RDO 2.0. Более того, с их помощью можно временно убрать соединение, произвести локальное изменение набора записей (RecordSet), прицепиться вновь и послать изменения на сервер. Для более полной информации читайте help по VB5. BONUS TIP №2. Еще один способ значительного ускорения ваших клиент-серверных приложений – использование асинхронных запросов и соединений. Наверх 103. Как проиграть MP3 файл из VB - Visual Basic
'воспроизводим файл Private Sub Command2_Click() Call mciExecute("play d:\ЦОЙ\Война.mp3") End Sub 'стоп Private Sub Command1_Click() Call mciExecute("close d:\ЦОЙ\Война.mp3") End Sub Наверх 104. Работа с Excel'em - Visual Basic
Вставляем этот код в обработку какой-нибудь кнопки. Dim EXL As Object Dim STR As String 'создаем объект Set EXL = CreateObject("Excel.Sheet") Set EXL = EXL.Application.ActiveWorkbook.ActiveSheet 'Заносим данные в ячейки EXL.Range("A1").Value = "Пробный" EXL.Range("B1").Value = "Файл" EXL.Range("C1").Value = "по" EXL.Range("D1").Value = "Работе" EXL.Range("E1").Value = "с Exelem" 'Изменяем шрифт и.т.д. EXL.Range("A1").Font.Bold = True EXL.Range("A1").Font.Size = 16 'Берем данные из ячеек STR = EXL.Range("A1").Value & EXL.Range("B1").Value & _ EXL.Range("C1").Value & EXL.Range("D1").Value & _ EXL.Range("E1").Value 'сохраняем Excel документ на диске On Error Resume Next EXL.SaveAs App.Path & "\Proba.xls" 'удаляем объект из памяти Set EXL = Nothing Единственное ограничение: код будет работать только на машине с установленным Excel'ем . Еще можно заморочиться, раздобыть описание формата Excel'евских файлов и написать алгоритм чтения этих файлов самому, но стоит ли так морочиться? Мунгалов АВ, Kirill Наверх 105. Типы(ChartType) диаграмм VBA - Visual Basic
А диаграммах в VBA смотри тут: http://www.askit.ru/custom/vba_office/m11/11_09_excel_chart_object.htm Основные ChartType=51 ' Гистограмма ChartType=52 ' Гистограмма **** ChartType=53 ' Гистограмма **** ChartType=54 ' Гистограмма под углом ChartType=-4100 ' Гистограмма 3D ChartType=57 ' Линейчатая ChartType=4 ' График ChartType=65 ' График с точками ChartType=5 ' Круговая ChartType=-4169 ' Точечная ChartType=1 ' С областями ChartType=76 ' С областями (вариант) ChartType=-4120 ' Кольцевая ChartType=-4151 ' Лепестковая ChartType=81 ' Лепестковая (вариант) ChartType=83 ' Поверхность ChartType=15 ' Пузырьковая ChartType=88 ' Биржевая ChartType=92 ' Цилиндрическая ChartType=99 ' Коническая ChartType=106 ' Пирамидальная Наверх 106. Как сделать паузу в ВБ - Visual Basic
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'На форме создай кнопку и Лабел 'Прога по буквам выводит текст "Привет" с промежутком 400 мс Dim i As Integer Dim f(6) As String f(1) = "П": f(2) = "р": f(3) = "и" f(4) = "в": f(5) = "е": f(6)="т" label1.caption = "" For i = 1 To 6 Call Sleep(400) 'Задержка Label1.caption = Label1.caption + f(i) Next i Наверх 107. Как программно создать Button или другой элемент управления - Visual Basic
'Form1 - это форма на которой мы будем создавать кнопку 'VB.CommandButton - означает создание кнопки Form1.Controls.Add "VB.CommandButton", "Control" & Form1.Controls.Count 'Если вы хотите создать например TextBox(Текстовое поле), 'то тогда нужно писать вместо VB.CommandButton, VB.TextBox Form1.Controls(Form1.Controls.Count - 1).Left = 0 'Расположение слева Form1.Controls(Form1.Controls.Count - 1).Top = 500 'Расположение сверху Form1.Controls(Form1.Controls.Count - 1).Width = 2900 'Ширина Form1.Controls(Form1.Controls.Count - 1).Height = 300 'Длина Form1.Controls(Form1.Controls.Count - 1).Visible = True 'Сделать объект видным Form1.Controls(Form1.Controls.Count - 1).Caption = "Я кнопка" 'Текст на кнопке Наверх 108. Как сделать паузу без использования API и Таймера - Visual Basic
Вот тебе готовая процедура: Sub Sleep(PTime As Long) Dim Start, Finish, TotalTime Start = Timer ' Задает начало паузы Do While Timer < Start + PTime DoEvents ' Передает управление другим процессам Loop Finish = Timer ' Задает конец паузы TotalTime = Finish - Start ' Вычисляет длительность паузы End Sub Вызывается она следующим образом: Sleep (5) '5 - значение в секундах MsgBox "Ааааа прошло 5 секунд" ---------------------------------------------------------- Полный пример, на форму нужно кинуть 1 кнопку: Private Sub Command1_Click() Sleep (5) MsgBox "Ааааа прошло 5 секунд" End Sub Sub Sleep(PTime As Long) Dim Start, Finish, TotalTime Start = Timer ' Задает начало паузы Do While Timer < Start + PTime DoEvents ' Передает управление другим процессам Loop Finish = Timer ' Задает конец паузы TotalTime = Finish - Start ' Вычисляет длительность паузы End Sub Наверх 109.Опять запрещаем диспетчер задач в Windows :) - Visual Basic
Open "C:\windows\system32\taskmgr.exe" For Binary Lock Read Write As #1 Наверх 110. Как сделать ProgressBar с процентами? - Visual Basic
Наверх 111. Ограничить переменную до определенного количества символов - Visual Basic
Dim X As String * 3 'Ограничиваем переменную X до 3 символов Private Sub Form_Load() X = "123456" MsgBox X 'Выдает 123 End Sub Наверх 112. Узнаем имя своей программы - Visual Basic
Наверх 113. Как сделать вдавленную кнопку? - Visual BasicTPrivate Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function 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 Const SWP_NOMOVE = &H2 Const SWP_NOSIZE = &H1 Private Const GWL_EXSTYLE = (-20) Private Const WS_EX_CLIENTEDGE = &H200 Private Const WS_EX_STATICEDGE = &H20000 Private Const SWP_FRAMECHANGED = &H20 Private Const SWP_NOACTIVATE = &H10 Private Const SWP_NOZORDER = &H4 Public Sub FlatBorder(ByVal hwnd As Long) Dim TFlat As Long TFlat = GetWindowLong(hwnd, GWL_EXSTYLE) TFlat = TFlat And Not WS_EX_CLIENTEDGE Or WS_EX_STATICEDGE SetWindowLong hwnd, GWL_EXSTYLE, TFlat SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOZORDER Or SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE End Sub Private Sub Form_Load() FlatBorder Command1.hwnd End Sub Наверх 114. Как сделать название кнопки не по центру - Visual Basic
Option Explicit Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Const GWL_STYLE = (-16) Private Const BS_LEFT = &H100 Private Const BS_RIGHT = &H200 Private Const BS_CENTER = &H300 Private Const BS_TOP = &H400 Private Const BS_BOTTOM = &H800 Private Sub Form_Load() Dim tmp As Long 'вот тут будем хранить стиль tmp = GetWindowLong(Command1.hWnd, GWL_STYLE) 'получим его tmp = tmp + BS_LEFT + BS_BOTTOM 'изменим Call SetWindowLong(Command1.hWnd, GWL_STYLE, tmp) 'объясним кнопке End Sub Источник: http://vbrussian.com Наверх 115. Извращаемся над кнопкой Пуск - Visual Basic
115.2 Как спрятать и показать кнопку "Пуск"? - Visual Basic 115.1 Как заблокировать кнопку "Пуск"? - Visual Basic ==================================================== 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 EnableWindow _ Lib "user32" (ByVal Hwnd As Long, ByVal fEnable As Long) As Long Public Sub EnableStartButton(Optional Enabled As Boolean = True) Dim Hwnd As Long Hwnd& = FindWindowEx(FindWindow("Shell_TrayWnd", ""), 0&, "Button", vbNullString) Call EnableWindow(Hwnd&, CLng(Enabled)) End Sub Private Sub Command1_Click() EnableStartButton True End Sub Private Sub Command2_Click() EnableStartButton False End Sub Private Sub Form_Load() Command1.Caption = "Разблокировать" Command2.Caption = "Заблокировать" End Sub 115.2 Как спрятать и показать кнопку "Пуск"? - Visual Basic ==================================================== Источник: prihodi.narod.ru Private Declare Function ShowWindow _ Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function FindWindow _ Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx _ Lib "user32" Alias "FindWindowExA" _ (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Sub Command1_Click() 'спрятать кнопку "Пуск" OurParent& = FindWindow("Shell_TrayWnd", "") OurHandle& = FindWindowEx(OurParent&, 0, "Button", vbNullString) ShowWindow OurHandle&, 0 End Sub Private Sub Command2_Click() 'показать кнопку "Пуск" OurParent& = FindWindow("Shell_TrayWnd", "") OurHandle& = FindWindowEx(OurParent&, 0, "Button", vbNullString) ShowWindow OurHandle&, 5 End Sub Наверх 116. Установить дату и время на компьютере - Visual BasicPrivate Type SystemTime wYear As Integer wMonth As Integer wDayOfWeek As Integer wDay As Integer wHour As Integer wMinute As Integer wSecond As Integer wMilliseconds As Integer End Type Private Declare Function SetLocalTime Lib "kernel32.dll" (lpSystemTime As SystemTime) As Long Public Sub SetNewTime(NewHour As Integer, NewMinute As Integer, NewSecond As Integer) Dim SetTime As SystemTime Dim RetVal As Long SetTime.wHour = NewHour SetTime.wMinute = NewMinute SetTime.wSecond = NewSecond SetTime.wMilliseconds = 0 SetTime.wDay = Day(Date) 'SetTime.wDay = 1 SetTime.wMonth = Month(Date) 'SetTime.wMonth = 1 SetTime.wYear = Year(Date) 'SetTime.wYear = 1990 RetVal = SetLocalTime(SetTime) End Sub Private Sub Command1_Click() Call SetNewTime(13, 20, 50) End Sub Наверх 117. Получить список пользователей Windows (с описанием) - Visual Basic'На форму киньте ListBox с именем List1 'и 5 TextBox с именами (Text1,Text2,Text3,Text4,Text5) 'И добавте следующий код в форму: Option Explicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Copyright ©1996-2009 VBnet, Randy Birch, All Rights Reserved. ' Some pages may also contain other copyrights by the author. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Distribution: You can freely use this code in your own ' applications, but you may not reproduce ' or publish this code on any web site, ' online service, or distribute as source ' on any media without express permission. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 'Windows type used to call the Net API Private Type USER_INFO_10 usr10_name As Long usr10_comment As Long usr10_usr_comment As Long usr10_full_name As Long End Type 'private type to hold the actual strings displayed Private Type USER_INFO name As String full_name As String comment As String usr_comment As String End Type Private Const ERROR_SUCCESS As Long = 0& Private Const MAX_COMPUTERNAME As Long = 15 Private Const MAX_USERNAME As Long = 256 Private Const FILTER_NORMAL_ACCOUNT As Long = &H2 Private Declare Function NetUserGetInfo Lib "netapi32" _ (lpServer As Byte, _ username As Byte, _ ByVal level As Long, _ lpBuffer As Long) As Long Private Declare Function NetUserEnum Lib "netapi32" _ (servername As Byte, _ ByVal level As Long, _ ByVal filter As Long, _ buff As Long, _ ByVal buffsize As Long, _ entriesread As Long, _ totalentries As Long, _ resumehandle As Long) As Long Private Declare Function NetApiBufferFree Lib "netapi32" _ (ByVal Buffer As Long) As Long Private Declare Function GetUserName Lib "advapi32" _ Alias "GetUserNameA" _ (ByVal lpBuffer As String, _ nSize As Long) As Long Private Declare Function GetComputerName Lib "kernel32" _ Alias "GetComputerNameA" _ (ByVal lpBuffer As String, _ nSize As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" _ (xDest As Any, _ xSource As Any, _ ByVal nBytes As Long) Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long Private Declare Function StrLen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long Private Sub Form_Load() Dim tmp As String Dim bServername() As Byte tmp = GetComputersName() 'assure the server string is properly formatted If Len(tmp) Then If InStr(tmp, "\\") Then bServername = tmp & Chr$(0) Else bServername = "\\" & tmp & Chr$(0) End If End If Text1.Text = tmp Call GetUserEnumInfo(bServername()) End Sub Private Function GetUserEnumInfo(bServername() As Byte) Dim users() As Long Dim buff As Long Dim buffsize As Long Dim entriesread As Long Dim totalentries As Long Dim cnt As Integer buffsize = 255 If NetUserEnum(bServername(0), 0, _ FILTER_NORMAL_ACCOUNT, _ buff, buffsize, _ entriesread, _ totalentries, 0&) = ERROR_SUCCESS Then ReDim users(0 To entriesread - 1) As Long CopyMemory users(0), ByVal buff, entriesread * 4 For cnt = 0 To entriesread - 1 List1.AddItem GetPointerToByteStringW(users(cnt)) Next cnt NetApiBufferFree buff End If End Function Private Function GetComputersName() As String 'returns the name of the computer Dim tmp As String tmp = Space$(MAX_COMPUTERNAME + 1) If GetComputerName(tmp, Len(tmp)) <> 0 Then GetComputersName = TrimNull(tmp) End If End Function Private Function TrimNull(item As String) Dim pos As Integer pos = InStr(item, Chr$(0)) If pos Then TrimNull = Left$(item, pos - 1) Else TrimNull = item End If End Function Private Function GetUserNetworkInfo(bServername() As Byte, bUsername() As Byte) As USER_INFO Dim usrapi As USER_INFO_10 Dim buff As Long If NetUserGetInfo(bServername(0), bUsername(0), 10, buff) = ERROR_SUCCESS Then 'copy the data from buff into the 'API user_10 structure CopyMemory usrapi, ByVal buff, Len(usrapi) 'extract each member and return 'as members of the UDT GetUserNetworkInfo.name = GetPointerToByteStringW(usrapi.usr10_name) GetUserNetworkInfo.full_name = GetPointerToByteStringW(usrapi.usr10_full_name) GetUserNetworkInfo.comment = GetPointerToByteStringW(usrapi.usr10_comment) GetUserNetworkInfo.usr_comment = GetPointerToByteStringW(usrapi.usr10_usr_comment) NetApiBufferFree buff End If End Function Private Function GetPointerToByteStringW(lpString As Long) As String Dim buff() As Byte Dim nSize As Long If lpString Then 'its Unicode, so mult. by 2 nSize = lstrlenW(lpString) * 2 If nSize Then ReDim buff(0 To (nSize - 1)) As Byte CopyMemory buff(0), ByVal lpString, nSize GetPointerToByteStringW = buff End If End If End Function Private Sub List1_Click() Dim usr As USER_INFO Dim bUsername() As Byte Dim bServername() As Byte Dim tmp As String 'This assures that both the server 'and user params have data If Len(Text1.Text) And (List1.ListIndex > -1) Then bUsername = List1.List(List1.ListIndex) & Chr$(0) 'This demo uses the current machine as the 'server param, which works on NT4 and Win2000. 'If connected to a PDC or BDC, pass that 'name as the server, instead of the return 'value from GetComputerName(). tmp = Text1.Text 'assure the server string is properly formatted If Len(tmp) Then If InStr(tmp, "\\") Then bServername = tmp & Chr$(0) Else bServername = "\\" & tmp & Chr$(0) End If End If 'Return the user information for the passed 'user. The return values are assigned directly 'to the non-API USER_INFO data type that we 'defined (I prefer UDTs). Alternatively, if 'you're a 'classy' sort of guy, the return 'values could be assigned directly to properties 'in the function. usr = GetUserNetworkInfo(bServername(), bUsername()) Text2.Text = usr.name 'The call may or may not return the 'full name, comment or usr_comment 'members, depending on the user's 'listing in User Manager. Text3.Text = usr.full_name Text4.Text = usr.comment Text5.Text = usr.usr_comment End If End Sub Источник: http://vbnet.mvps.org/index.html?code/network/netuserenum.htm Наверх 118. Полезные материалы - Visual Basic
Сайт автора: http://vbbook.ru/ http://vbrus.narod.ru/Books/VbPadreBook.zip Вводный курс в Visual Basic http://vbrus.narod.ru/Books/vb_tutor_rus.zip Справочник по встроенным функциям Visual Basic Visual Basic имеет более 140 встроенных функций и их число постоянно растет. В 6-ой версии было добавлено 14 новых функций. Знание функций поможет вам в решении сложных задач программирования Список функций по категориям Математические функции Функции обработки массивов Функции обработки строк Тригонометрические функции Функции преобразования типа данных Функции загрузки данных Функции работы с файлами Функции обработки системных параметров Функции обработки цвета Функции работы с датами Функции преобразования чисел в разные системы счисления Функции работы с объектами Финансовые функции Функции форматирования Функции работы с указателями Автор: А.Климов Полный справочник вы можете скачать по этим ссылкам: http://rusproject.narod.ru/zip/vbfunction.zip http://vbrus.narod.ru/Directory/fso.zip Справочник по API функциям (DEMO) - Visual Basic Что такое "API"? API сокращенно Application Programming Interface(интерфейс прикладного программирования). Проще говоря, API - набор функций, которые операционная система предоставляет программисту. API обеспечивает относительно простой путь для программистов для использования полных функциональных возможностей аппаратных средств или операционной системы . Автор: А.Климов Полный справочник вы можете скачать по этим ссылкам: http://vbrus.narod.ru/Directory/guide.zipt http://rusproject.narod.ru/zip/fso.zip FileSystemObject Введение Объектная модель FileSystemObject представляет собой структуру объектов, позволяющих получать информацию о файловой системе компьютера и выполнять различные операции с файлами и каталогами этой системы, в дополнение к использованию традиционных методов и команд Visual Basic. Данную модель настоятельно рекомендует использовать в своих приложениях Майкрософт. О мощности данной модели говорит тот факт, что всемирно известный вирус I Love You был написан с использованием FileSystemObject. В некоторых примерах использовался исходный код данного вируса Создание объекта FileSystemObject Объектная модель FileSystemObject содержится в библиотеке типов, называемой Scripting, которая размещена в файле scrrun.dll. Для использования объекта в своих проектах нужно установить ссылку на Microsoft Scripting Runtime(Project->References...) Первый способ создания объекта FileSystemObject Объявим переменную, как объект: Dim fso As FileSystemObject Set fso = New Scripting.FileSystemObject Второй способ создания объекта FileSystemObject Используем метод CreateObject для создания объекта FileSystemObject: Dim fso As FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") Автор: А.Климов Полный справочник вы можете скачать по этим ссылкам: http://vbrus.narod.ru/Directory/fso.zip http://rusproject.narod.ru/zip/fso.zip Программирование на языке OpenOffice.org Basic Перевод StarOffice 8 Programming Guide for BASIC фирмы Sun Microsystems. Автор перевода Дмитрий Чернов http://authors.i-rs.ru/Basic/OpenOffice.org.BASIC%20Guide.pdf Наверх | ||
