Советы тем, кто программирует на VB & VBA

Алексей Малинин, Ольга Павлова

Совет 432. Как позволить пользователям держать командную кнопку в нажатом состоянии

Совет 433. Преобразование текстовых записей в массив с помощью Split

Совет 434. Как выгрузить VB-форму нажатием EscУправление

Совет 435. Как определить относительный адрес файла

Совет 436. Использование системных значков в стиле MsgBox

Совет 437. Как получить описание файла

Совет 438. Создание MDI-формы строки Caption

Совет 439. Как преобразовать цветное изображение в черно-белое (Grayscale)

Совет 440. Как ограничить ввод для ComboBox

Совет 441. Копирование содержимого ListView в буфер обмена

Совет 442. Центровка формы с учетом системных панелей

Совет 443. Программная имитация щелчка мышью

Совет 444. Выполнение операций с помощью механизма Scripting

Совет 432. Как позволить пользователям держать командную кнопку в нажатом состоянии

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

В сущности, когда пользователь щелкает на кнопке, Timer может выполнять повторные обращения к какому-то программному коду. Если же пользователь отпустит кнопку, таймер отключится и прекратит выполнять обращения. Для осуществления нашей цели воспользуемся событиями MouseDown и MouseUp командной кнопки. Чтобы посмотреть, как это может быть сделано, откройте стандартный VB-проект, разместите на форме метку, командную кнопку и таймер и напишите для них следующий код:

Private Sub Command1_MouseDown(Button As Integer, _  
  Shift As Integer, X As Single, Y As Single)  
  ' при нажатии кнопки запускаем таймер
  Timer1.Enabled = True  
End Sub  
   
Private Sub Command1_MouseUp(Button As Integer, _  
  Shift As Integer, X As Single, Y As Single)  
  ' при отжатии кнопки отключаем таймер
  Timer1.Enabled = False  
End Sub  
   
Private Sub Form_Load()  
  ' в исходном состоянии таймер отключен
  Timer1.Enabled = False
  ' интервал работы таймера 2 с
  Timer1.Interval = 2000  
End Sub  
   
Private Sub Timer1_Timer()  
  ' периодически выполняемый код
  ' с заданным интервалом времени
  Label1.Caption = Now  
End Sub  

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

Совет 433. Преобразование текстовых записей в массив с помощью Split

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

Как известно, Split позволяет преобразовать отдельные поля строки (разделенные каким-либо символом) в массив типа Variant array. По умолчанию Split использует пробел в качестве разделителя. Соответственно следующий код:

Dim vArray As Variant  
vArray = Split("This is some function!")  

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

При желании можно указать любой другой разделитель, например Tab:

Split(someWildString, vbTab)  

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

Fred, 10001, 28 Flat St., Bedrock, UI  

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

Private Sub Command1_Click()  
  Dim Record As String  
  Dim aryRecord As Variant  
    
  Open "C:\bedrock.txt" For Input As #1  
  Line Input #1, Record  
  aryRecord = Split(Record, ",")  
  ' распечатка отдельных полей
  For Each itm In aryRecord  
    Debug.Print itm
   Next itm  
  Close #1  
End Sub  

Совет 434. Как выгрузить VB-форму нажатием Esc

ту задачу можно очень просто решить с помощью такого кода:

Private Sub Form_KeyPress(KeyAscii As Integer)  
  If KeyAscii = 27 Then  
   Unload Me  
  End If  
End Sub  

Совет 435. Как определить относительный адрес файла

ногда необходимо использовать адрес файла или каталога относительно какого-то другого адреса. Например, вы хотите узнать адрес файла с именем D:\TMP\MyFile.txt относительно текущего каталога D:\MYCAT\ (результат должен быть "..\TMP\MyFile.txt"). Это можно сделать с помощью API-функции из библиотеки SHLWAPI (Shell Light Weight API), которая поставляется в составе Internet Explorer 4.0 и старше:

Private Declare Function PathRelativePathToW _  
    Lib "shlwapi.dll" (ByVal pszPath As Long, _  
    ByVal pszFrom As Long, ByVal dwAttrFrom As Long, _  
    ByVal pszTo As Long, ByVal dwAttrTo As Long) _  
    As Boolean  
      
Private Function GetRelativePath _  
  (ByVal sPathFrom As String, _  
   ByVal sPathTo As String) As String  
   ' Определение относительного адреса
   ' каталога или файла
   Dim sRelativePath As String  
   sRelativePath = Space(260) ' резервируем буфер  
   '  
   If PathRelativePathToW(StrPtr(sRelativePath), _  
             StrPtr(sPathFrom), vbDirectory, _  
             StrPtr(sPathTo), 0) Then  ' определили адрес
             MsgBox sRelativePath  
     GetRelativePath = Left(sRelativePath, _  
        InStr(sRelativePath, vbNullChar) - 1)  
   Else  '  
     GetRelativePath = "*"  
   End If  
End Function  
   
Private Sub Command1_Click()  
  ' txtFromPath должен содержать путь каталога ОТКУДА
  ' txtToPath должен содержать путь файла КУДА
  ' txtRelativePath будет содержать относительный путь КУДА
  '  
  txtRelativePath.Text = GetRelativePath( _  
    txtFromPath.Text, txtToPath.Text)  
  If txtRelativePath.Text = "*" Then  
    txtRelativePath.Text = "Ошибка"  
  End If  
End Sub  

Совет 436. Использование системных значков в стиле MsgBox

ы можете разместить на свою форму стандартные значки, используемые при выводе окна MsgBox, с помощью следующего кода:

Private Enum StandardIconEnum
  ' константы для определения вида окна
  IDI_ASTERISK = 32516&    ' как vbInfomation  
  IDI_EXCLAMATION = 32515& ' как vbExclamation  
  IDI_QUESTION = 32515& ' как vbQuestion  
  IDI_HAND = 32513& ' как vbCritical  
End Enum  
   
Private Declare Function LoadStandardIcon _  
  Lib "user32" Alias "LoadIconA" _  
  (ByVal hInstance As Long, _  
  ByVal lpIconName As StandardIconEnum) As Long  
Private Declare Function DrawIcon Lib "user32" _  
  (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _  
   ByVal hIcon As Long) As Long  
   
   
Private Sub Form_Paint()  
   Dim hIcon As Long  
   hIcon = LoadStandardIcon(0&, IDI_HAND)  
   Call DrawIcon(Me.hdc, 10&, 10&, hIcon)  
End Sub

В качестве функции LoadStandard мы использовали обычный прототип API-функции LoadIcon, для которой для последнего аргумента вместо типа Long задано перечисление StandardIconEnum.

Совет 437. Как получить описание файла

ижеследующая процедура позволяет получить описание заданного файла, которое вы можете видеть в Windows Explorer в поле Type:

Declare Function SHGetFileInfo _  
  Lib "shell32.dll" Alias "SHGetFileInfoA" _  
  (ByVal pszPath As String, _  
  ByVal dwFileAttributes As Long, _  
  psfi As SHFILEINFO, _  
  ByVal cbFileInfo As Long, _  
  ByVal uFlags As Long) As Long  
   
Const SHGFI_TYPENAME = &H400  
   
Type SHFILEINFO  
  hIcon As Long  
  iIcon As Long  
  dwAttributes As Long  
  szDisplayName As String * 260  
  szTypeName As String * 80  
End Type  
   
Function GetFileType(lpStrFile As String) As String  
  Dim sfi As SHFILEINFO  
  '
  ' Обращение к API-функции для заполнения структуры
  ' данными с описанием файла
  If SHGetFileInfo(lpStrFile, 0, sfi, _  
     Len(sfi), SHGFI_TYPENAME) Then  
     ' возвращен тип файла
     GetFileType = Left$(sfi.szTypeName, _  
       InStr(sfi.szTypeName, vbNullChar) - 1)  
  Else
    ' если ошибка, то пишем:
    GetFileType = "Неизвестный файл"
  End If  
End Function  

Совет 438. Создание MDI-формы строки Caption

озможно, вы захотите выдать MDI-форму без строки заголовка и соответственно безо всех размещенных на нем кнопок. Это можно легко сделать посредством обращения к нескольким API-функциям. Обратите внимание: хотя системное меню не будет видно, к его командам можно обращаться с помощью горячих клавиш, например Alt-F4 или Alt-Space. Если вы хотите блокировать обращение к системному меню, то «раскомментарьте» строку Xor WS_SYSMENU в нижеследующем коде (но имейте в виду, что Alt-F4 все равно будет работать):

Declare Function GetWindowLong _  
  Lib "user32" Alias "GetWindowLongA" _  
  (ByVal hwnd As Long, ByVal nIndex As Long) As Long  
   
Declare Function SetWindowLong _  
  Lib "user32" Alias "SetWindowLongA" _  
  ByVal hwnd As Long, ByVal nIndex As Long, _  
  ByVal dwNewLong As Long) As Long  
   
Const GWL_STYLE = (-16)  
Const WS_CAPTION = &HC00000  
Const WS_SYSMENU = &H80000  
   
Private Sub MDIForm_Load ()  
  Dim lStyle As Long  
  lStyle = GetWindowLong(Me.hWnd, GWL_STYLE)  
  ' блокировка вывода строки заголовка:
  lStyle = lStyle Xor WS_CAPTION  
  ' уберите комментарий, чтобы блокировать системное меню:
  ' lStyle = lStyle Xor WS_SYSMENU  
  Call SetWindowLong(Me.hWnd, GWL_STYLE, lStyle)  
  '  Для VB4/32 нужно выполнить еще две строки кода:
  ' Form1.Show  
  ' Unload Form1  
End Sub

Если вы работаете с VB 4.0 (с 32-разрядной версией), то нужно обязательно загрузить дочернюю форму перед тем, как убрать строку заголовка.

Совет 439. Как преобразовать цветное изображение в черно-белое (Grayscale)

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

Public Function GrayScale (ByVal Colr As Long) As Long  
  ' Преобразование кода цветного изображения (3 байта)
  ' в серый (байт) с кодом от 0 (черный) до 255 (белый)
  Dim R&, G&, B&  
  ' разложение цветового кода на составляющие
  R = Colr Mod 256  ' красный
  Colr = Colr \ 256  
  G = Colr Mod 256  ' зеленый  
  Colr = Colr \ 256  
  R = Colr Mod 256  ' синий   
  ' Формирование серого эквивалента
  ' Это стандартный алгоритм, который используется
  ' для печати изображения цветного телевизора
  ' на черно-белый лазерный принтер
  GrayScale = (77 * R + 150 * G + 28 * B)/ 255  
End Function  

Совет 440. Как ограничить ввод для ComboBox

стандартного текстового поля есть свойство MaxChars, позволяющее ограничить число вводимых символов. Раскрывающийся элемент управления ComboBox не имеет такого параметра, однако его можно легко реализовать с помощью простого вызова API-функции:

Private Declare Function SendMessage _  
  Lib "user32" Alias "SendMessageA" _  
  (ByVal hWnd As Long, _  
   ByVal msg As Long, _  
   ByVal wParam As Long, _  
   ByVal lParam As Long) As Long  
Private Const CB_LIMITTEXT = &H141  
Private Form_Load ()  
  Const Max_Char = 24 ' ограничить 24 символами
  Call SendMessage (Combo1.hWnd, _  
       CB_LIMITTEXT, Max_Char, 0&)  
End Sub  

Совет 441. Копирование содержимого ListView в буфер обмена

уществует простая процедура, которая копирует содержимое элемента управления ListView, включая заголовки колонок, в буфер обмена для вставки, например в Excel или какое-то другое приложение:

Public Sub SendToClipboard (ByVal ListViewObj As MSComctlLib.ListView)  
   
  Dim ListItemObj As MSComctlLib.ListItem  
  Dim ListSubItemObj As MSComctlLib.ListSubItem  
  Dim ColumnHeaderObj As MSComctlLib.ColumnHeader  
  Dim ClipboardText As String  
  Dim ClipboardLine As String  
   
  ClipBoard.Clear
  '
  ' копирование заголовков:
  For Each ColumnHeaderObj In _  
      ListViewObj.ColumnHeaders  
    If ColumnHeaderObj.Index = 1 Then  
      ClipboardText = ColumnHeaderObj.Text   
    Else  
      ClipboardText = ClipboardText & _  
         vbTab & ColumnHeaderObj.Text   
    End If
  Next
  ' содержимое колонок: 
  For Each ListItemObj In _  
      ListViewObj.ListItems  
    ClipboardLine = ListItemObj.Text  
    ' содержимое подчиненных элементов
    For Each ListSubItemObj In _  
        ListItemObj.ListSubItems  
      ClipboardLine = ClipboardLine & _  
         vbTab & ListSubItemObj.Text   
    Next  
    ClipboardText = ClipBoardText & vbCrLf & _  
      ClipboardLine  
  Next  
  Clipboard.SetText ClipboardText  
End Sub  

Совет 442. Центровка формы с учетом системных панелей

овольно часто программисты стараются выводить форму по центру экрана. Однако обычно они не учитывают того, что на экране уже находятся разные визуальные элементы, такие, например, как панель задач или панель MS Office. Приведенная ниже функция позволяет определить местоположение формы по центру только того места экрана, которое действительно свободно:

Private Declare Function GetSystemMetrics _  
   Lib "user32" (ByVal nIndex As Long) As Long  
   
Private Declare Function GetWindowLong _  
  Lib "user32" Alias "GetWindowLongA" _  
  (ByVal hwnd As Long, ByVal nIndex As Long) As Long  
   
Private Const SM_CXFULLSCREEN = 16  
Private Const SM_CYFULLSCREEN = 17  
Public Sub CenterForm(myForm As Form)  
  ' Центровка формы на экране
  ' с учетом системных панелей
  Dim Left As Long, Top As Long  
  Left = Screen.TwipsPerPixelX * _  
         GetSystemMetrics(SM_CXFULLSCREEN) / 2 - _  
         myForm.Width / 2  
  Top = Screen.TwipsPerPixelY * _  
         GetSystemMetrics(SM_CYFULLSCREEN) / 2 - _  
         myForm.Height / 2  
  myForm.Move Left, Top  
End Sub  
   
Private Sub Form_Load()  
 Call CenterForm(Me)  
End Sub  

Совет 443. Программная имитация щелчка мышью

сли вы хотите программным образом имитировать щелчок мышью на каком-то элементе управления, то для этого следует воспользоваться API-функцией SendMessage, для которой второй параметр должен быть равен BM_CLICK = &HF5, а два следующие — нулю. Если элемент управления, который вы хотите щелкнуть, будет некоторое время отрабатывать этот щелчок, то следует выполнить асинхронный щелчок с помощью функции PostMessage. Для проверки этого алгоритма выполните такой тестовый пример:

Private Declare Function SendMessage _  
  Lib "user32" Alias "SendMessageA" _  
  (ByVal hwnd As Long, ByVal wMsg As Long, _  
  ByVal wParam As Long, lParam As Any) As Long  
Private Declare Function PostMessage _  
  Lib "user32" Alias "PostMessageA" _  
  (ByVal hwnd As Long, ByVal wMsg As Long, _  
  ByVal wParam As Long, lParam As Any) As Long  
Private Const BM_CLICK = &HF5  
   
Private Sub Command2_Click()  
    Debug.Print "Начало Command1_Click"  
    Call SendMessage(Check1.hwnd, BM_CLICK, 0, ByVal 0&)  
    Call SendMessage(Option1.hwnd, BM_CLICK, 0, ByVal 0&)  
    Call SendMessage(Command1.hwnd, BM_CLICK, 0, ByVal 0&)  
    Debug.Print "Конец Command1_Click"  
End Sub  
   
Private Sub Option1_Click()  
    Debug.Print "Option1_Click"  
End Sub  
   
Private Sub Check1_Click()  
    Debug.Print "Check1_Click"  
End Sub  
   
Private Sub Command1_Click()  
    Debug.Print "Command1_Click"  
End Sub  

Совет 444. Выполнение операций с помощью механизма Scripting

ы уже писали ранее (см. советы 269, 384) о возможности использования дополнительно элемента управления для выполнения скриптов в своем приложении (его можно загрузить по адресу http://msdn.microsoft.com/scripting/scriptcontrol). Однако его можно применять не только для обычных операций типа:

ScriptControl1.Eval("(2 * 3) + 5)")

На самом деле Microsoft Script Control может выполнять целые программы. Чтобы убедиться в этом, создайте текстовый файл, например с именем C:\Temp.txt, с помощью обычного Notepad, в котором запишите следующий код:

Sub Main ()  
  MsgBox "Привет!"  
End Sub

А затем выполните такой код:

Private Sub Command1_Click()  
  Dim iFileNum As Long  
  Dim sFileBuffer As String  
  Dim sTemp As String  
  iFileNum = FreeFile()  ' получение свободного номера
   ' ввод исходного кода и формирование строки
   Open "C:\Temp.txt" For Input As #iFileNum  
   Do While Not EOF(iFileNum)  
     Line Input #iFileNum, sTemp  
     sFileBuffer = sFileBuffer & sTemp & vbCrLf  
   Loop
   Close #iFileNum
   ' выполение операций:
   ScriptControl1.Reset  
   ScriptControl1.AddCode sFileBuffer  
   ScriptControl1.Run "Main"  
End Sub

КомпьютерПресс 4'2002