Visual2000 · Архив статей А.Колесова & О.Павловой
Андрей Колесов, Ольга Павлова
© Андрей Колесов, Ольга Павлова, 2001Как известно, функция AddressOf позволяет передавать в качестве параметра адрес VB-процедуры при обращении к DLL-процедурам вообще и к Win API в частности. Обычно это нужно для реализации механизма "обратного вызова" (Callback). Однако порой бывает необходимо передавать такой адрес в виде одного из полей структуры данных. Для решения подобной задачи следует иметь в виду, что ключевое слово AddressOf можно использовать и при обращении к VB-процедуре, в связи с чем можно предложить такой вариант программы:
Public Sub Main()
Type MySturture
lpfnProc As Long ' адрес процедуры
End Type
Dim MyStruc
' вычисление адреса процедуры MyProc
MyStruc.lpfnProc = FcnPtr(AddressOf MyProc)
End Sub
Public Function FcnPtr(ByVal Whatever As Long) As Long
' фиксируем значение переданного адреса процедуры
FcnPtr = Whatever
End Function
Public Sub MyProc()
' ...
End Sub
Обычно регистрация (или ее отмена) ActiveX-компонентов выполняется с помощью автономной утилиты regsvr32.exe. Если необходимо выполнять процедуры регистрации в момент выполнения вашего VB-приложения, то можно воспользоваться обращением к этой утилите с помощью Shell. Однако существует еще один способ проведения таких операций, недостатком которого является необходимость "железного" включения имени нужного компонента в код программы.
Дело в том, что каждый ActiveX-компонент (ActiveX DLL или OCX) имеет функции DllRegisterServer и DllUnregisterServer, выполняющие операции регистрации/отмены регистрации над собственным компонентом. И обратиться к ним можно напрямую, как к обычной DLL-функции.
Например, если вы хотите программно проводить операции регистрации компонента COMCTL32.OCX, то в программе нужно описать две такие функции:
' функция регистрации компонента COMCTL32.OCX
Declare Function RegComCtl32 Lib "COMCTL32.OCX" Alias _
DllRegisterServer() As Long
' функция отмены регистрации компонента COMCTL32.OCX
Declare Function UnRegComCtl32 Lib "COMCTL32.OCX" Alias _
DllUnregisterServer() As Long
Однако следует иметь в виду, что если вы не указали полный путь к файлу, то его поиск будет осуществляться только в системном или текущем каталоге. Кроме того, при выполнении операций целесообразно реализовать механизм анализа возможных ошибок.
Приведем пример кода регистрации библиотеки Test.DLL, которая хранится в произвольном каталоге C:\MyApp:
Declare Function RegTestDLL Lib "Test.DLL" Alias _
DllRegisterServer() As Long
Const ERROR_SUCCESS = 0&
Dim retCode As Long
On Error Resume Next ' включаем программную обработку ошибок
ChDrive "C:" ' Устанавливаем нужный
ChDir "C:\MyApp" ' каталог текущим
regCode = RegTestDLL() ' регистрация Test.DLL
' анализ возможных ошибок
If Err <> 0 Then
MsgBox "Файл Test.DLL не найден"
Else
If regCode <> ERROR_SUCCES Then
MsgBox "Операция регистрации не выполнена"
End If
End If
В окне кода VB передвигаться между процедурами модуля или формы можно с помощью быстрых клавиш — Ctrl + Page Down и Ctrl + Page Up.
Если вы определили текстовое поле как "многостроковое", может возникнуть необходимость узнать число строк. Это можно сделать с помощью такого простого кода:
Private Sub Command1_Click() Dim myParas As Variant myParas = Split(Text1.Text, vbNewLine) MsgBox "Число строк = " & (UBound(myParas) + 1) End Sub
Но данный вариант позволит получить только число строк, разделенных "жестким образом" (возврат каретки). Для того чтобы получить фактическое число строк в данном текстовом окне, можно воспользоваться обращением к API-функции SendMessageAsLong:
Private Declare Function SendMessageAsLong Lib "user32" _ Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _ ByVal wParam As Long, ByVal lParam As Long) As Long Const EM_GETLINECOUNT = 186 Private Sub Command2_Click() Dim lCount As Long lCount = SendMessageAsLong(Text1.hWnd, EM_GETLINECOUNT, 0, 0) MsgBox "Фактическое число строк = " & lCount End Sub
Если в качестве текстового редактора вы используете элемент управления Rich Textbox, то полезно узнать не только число строк (о чем говорилось в предыдущем совете), но также, например, и текущую позицию курсора. Это можно сделать с помощью еще одной API-функции — SendMessageByNum:
Private Declare Function SendMessageByNum Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const EM_LINEFROMCHAR = &HC9 Private Const EM_LINEINDEX = &HBB
Public Function GetCurrentLine(TxtBox As Object) As Long
' определение текущей строки в окне
With TxtBox
GetCurrentLine = SendMessageByNum(.hwnd, _
EM_LINEFROMCHAR, CLng(.SelStart), 0&) + 1
End With
End Function
Public Function GetCurrentColumn(TxtBox As Object) As Long
' определение текущей колонки в окне
With TxtBox
GetCurrentColumn = .SelStart - SendMessageByNum(.hwnd, _
EM_LINEINDEX, -1&, 0&) + 1
End With
End Function
Вот как их можно использовать:
Private Sub Command1_Click() MsgBox "Текущая строка = " & GetCurrentLine(RichTextBox1) End Sub Private Sub Command2_Click() MsgBox "Текущая колонка = " & GetCurrentColumn(RichTextBox1) End Sub
Предположим, на вашей форме Form1 расположены несколько командных кнопок и вам нужно выполнить программную имитацию их нажатия:
Private Sub Command1_Click() MsgBox "Кнопка 1 нажата!" End Sub Private Sub Command2_Click() MsgBox "Кнопка 2 нажата!" End Sub
К примеру, на другой форме Form2 имеется кнопка AllCommands, щелчок которой должен вызывать нажатие двух кнопок на Form1. Обратиться непосредственно к процедурам CommandN_Click нельзя, так как они имеют статус Private. Для решения этой проблемы следует воспользоваться свойством Value, которое управляет состоянием кнопки:
Private Sub AllCommands_Click() Form1.Command1.Value = True Form1.Command2.Value = True End Sub
Установка значения Command.Value = True автоматически вызывает выполнение события Click соответствующей кнопки.
При программной установке источника данных элемента управления DataGrid нельзя указывать имена заголовков колонок в режиме проектирования. Поэтому DataGrid применяет имена колонок самого набора данных, что не всегда бывает удобным для работы.
Эта проблема решается элементарно: в SQL-операторе нужно просто указать альтернативные имена полей. Например, вместо
SELECT pub_id, pub_name FROM pubs
написать
SELECT pub_id AS Учетный_Номер, pub_name AS Издатель FROM pubs
В результате DataGrid выдаст на экран в качестве заголовков имена "Учетный_Номер" и "Издатель" вместо соответствующих идентификаторов pub_id и pub_name.
Недавно при работе со считанным из Интернета небольшим программным примером я столкнулся со странной ситуацией. Для удобства работы я хотел немного уменьшить форму проекта и для этого немного передвинуть расположенные на ней элементы управления. Но не тут-то было — компоненты выделялись, но передвигаться или менять размеры не хотели. При этом выделяемые элементы обрамлялись не черными квадратиками, как обычно, а белыми, показывая тем самым, что никакие перемещения не разрешены.
Оказалось, что такой режим блокировки элементов управления формы задается свойством LockControls = -1 (True), нигде не описанным и не упомянутым (кстати, в электронной документации вообще нет четкого описания свойств формы). Получается, что остановка/отмена LockControls может выполняться только непосредственным редактированием FRM-файла, которое будет выглядеть приблизительно следующим образом:
Begin VB.Form MyForm Caption = "Форма с блокировкой компонентов" ... LockControls = -1 'True ...
Те, кто работал с QuickBasic (в среде DOS), возможно, помнят, что там был оператор PAINT, который позволял заливать поверхности фигур произвольных очертаний. В системе VB этот оператор отсутствует и встроенные VB-функции позволяют выполнять заливку только "стандартных" фигур, например прямоугольника или круга, что явно недостаточно для решения многих графических задач.
Тем не менее выход существует — нужно использовать функцию ExtFloodFill из состава Win32 GDI API, которая имеет следующее описание:
Private Declare Function ExtFloodFill Lib "gdi32" _ (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, _ ByVal crColor As Long, ByVal wFillType As Long) As Long
Параметр hDC — номер описателя объекта. В данном случае допустимым объектом является форма (Form) или элемент управления PictureBox, номер описателя определяется с помощью их свойства hDC. Цветовая фактура заливки задается с помощью двух свойств объекта (их нужно установить перед обращением к ExtFloodFill) — FillColor (цвет) и FillStyle (тип фактуры).
X и Y — координаты точки, из которой выполняется заливка. Однако следует иметь в виду, что они должны быть заданы в пикселах, а не в логических координатах, которые могут быть установлены свойством ScaleMode (по умолчанию Twip).
crColor и wFillType — взаимосвязанные параметры, определяющие режим выбора площади заливки:
В составе GUI API также предусмотрена функция FloodFill, которая является частным случаем ExtFloodFill (случай FLOODFILLBORDER).
Следует обратить внимание на один момент, не отмеченный в документации и обнаруженный нами в ходе эксперимента. Оказалось, что функция ExtFloodFill срабатывает, только если перед обращением к ней выполнено обращение к свойству object.Point (x, y). Впрочем, такую операцию выполнять в любом случае полезно, поскольку цвет "начальной" точки понадобится для установки параметра crColor (FLOODFILLSURFACE) или, напротив, для проверки значения этого же параметра (FLOODFILLBORDER).
На листинге 396-1 приведен пример процедуры Paint, которая имитирует оператор PAINT системы QB. Обратите внимание, что параметр BorderColor при обращении к ней нужно задавать только для случая FLOODFILLSURFACE — в другом режиме он определяется автоматически внутри процедуры с помощью Point (x, y).
На рис. 396-1 и 396-2 показаны возможности применения функции ExtFloodFill соответственно в режимах FLOODFILLBORDER и FLOODFILLSURFACE.
Рис. 396-1
Рис. 396-2
А в листингах 396-2 и 396-3 приведен код формы Flood.frm и модуля AddProc.bas, которые используются в этом демонстрационном примере. Заливка выполняется в элементе управления PictureBox.
Обратите также внимание, что при рисовании начальных контуров (функция DrawShapes) последние пять линий изображаются фиксированным, синим цветом. Это сделано специально для демонстрации работы режима FLOODFILLBORDER. Ведь для этого случая граница не должна иметь "дырок", которые получаются при наложении линий других цветов. Таким образом, наш пример устойчиво будет работать только для случая границы синего цвета. Это вполне соответствует реальной ситуации — перед заливкой необходимо сделать контур нужного цвета.
Option Explicit
Private Declare Function ExtFloodFill Lib "gdi32" _
(ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal crColor As Long, ByVal wFillType As Long) As Long
' Значения режимов заливки
Public Enum FillModes
FLOODFILLBORDER = 0
FLOODFILLSURFACE = 1
End Enum
Public Sub Paint(ByVal Canvas As Object, ByVal X As Single, _
ByVal Y As Single, ByVal FillColor As Long, _
Optional ByVal FillStyle As FillStyleConstants = vbFSSolid, _
Optional ByVal BorderColor As Long = vbBlack, _
Optional ByVal Flags As FillModes = FLOODFILLBORDER)
' Заливка поверхности фигуры произвольных очертаний
Dim xP As Long, yP As Long
Dim oldFillColor As Long
Dim oldFillStyle As Long
' Работает только с Form и Picture
If Not TypeOf Canvas Is Form Then
If Not TypeOf Canvas Is PictureBox Then
MsgBox "Контур должен быть формой или картинкой"
Exit Sub
End If
End If
Dim PointColor As Long
' почему-то нужно обязательно выполнить операцию Point
PointColor = Canvas.Point(X, Y)
'
' Впрочем, это пригодится для установки режима заливки
' и проверки параметров
If Flags = FLOODFILLBORDER Then
If PointColor = BorderColor Then
MsgBox "Ошибка: совпадают цвета 'начальной'" & _
"точки и границы в режиме FLOODFILLBORDER"
Exit Sub
End If
Else ' в этом режиме нужно установить текущий цвет
BorderColor = PointColor
End If
' Преобразование координат (логические данного объекта) в пикселы
xP = Canvas.ScaleX(X, Canvas.ScaleMode, vbPixels)
yP = Canvas.ScaleY(Y, Canvas.ScaleMode, vbPixels)
' Сохранение текущих атрибутов и установка новых
oldFillColor = Canvas.FillColor
oldFillStyle = Canvas.FillStyle
Canvas.FillColor = FillColor
Canvas.FillStyle = FillStyle
' Заливка !
Call ExtFloodFill(Canvas.hDC, xP, yP, BorderColor, Flags)
' Восстановление значений атрибутов
Canvas.FillColor = oldFillColor
Canvas.FillStyle = oldFillStyle
End Sub
Option Explicit
Private m_X As Single
Private m_Y As Single
Private Sub Command1_Click()
' перерисовываем картинку
Call DrawShapes(Picture1, cboFillColor)
End Sub
Private Sub Form_Load()
Dim i As Long
' Начальная установка параметров и элементов управления
' Формирование списков
Call FillColorList(cboFillColor)
Call FillColorList(cboBorderColor)
Call FillStyleList(cboFillStyle)
Option1(1).Value = True
'Для режима FLOODFILLSURFACE цвет границы не нужен
cboBorderColor.Enabled = False
BorderLabel.Enabled = False
'
Set Me.Icon = Nothing
Me.Show
Call DrawShapes(Picture1, cboFillColor)
cboFillColor.ListIndex = 3
cboBorderColor.ListIndex = 0
cboFillStyle.ListIndex = 0
End Sub
Private Sub Picture1_Click()
Dim MyBorderColor As Long
Dim MyBorderColor1 As Long
Dim MyFillColor As Long
Dim MyFillStyle As FillStyleConstants
Dim MyFlags As FillModes
' установка цвета и стиля заполнения
MyFillColor = CheckSysColor _
(cboFillColor.ItemData(cboFillColor.ListIndex))
MyFillStyle = cboFillStyle.ItemData(cboFillStyle.ListIndex)
MyFlags = Option1(0).Value + 1 ' режим заливки
' Формирование параметра BorderColor
If MyFlags = FLOODFILLBORDER Then ' цвет границы контура
MyBorderColor = cboBorderColor.ItemData(cboBorderColor.ListIndex)
End If
' выполняем заливку
Call Paint(Picture1, m_X, m_Y, MyFillColor, _
MyFillStyle, MyBorderColor, MyFlags)
End Sub
Private Sub Picture1_MouseDown _
(Button As Integer, Shift As Integer, X As Single, Y As Single)
' Фиксируем координаты нажатия мыши
m_X = X
m_Y = Y
End Sub
Private Sub Option1_Click(Index As Integer)
If Index = 0 Then
' Для режима FLOODFILLBORDER гарантированный контур "без дырок"
' сформирован в этом примере только СИНЕГО цвета
cboBorderColor.ListIndex = 1
' но можно попробовать и другие цвета (может повезет)
cboBorderColor.Enabled = True
BorderLabel.Enabled = True
Else 'Для режима FLOODFILLSURFACE цвет границы не нужен
cboBorderColor.Enabled = False
BorderLabel.Enabled = False
End If
End Sub
Option Explicit
Private Declare Function GetSysColor Lib "user32" _
(ByVal nIndex As Long) As Long
Function CheckSysColor(ByVal Color As Long) As Long
Const HighBit As Long = &H80000000
' Если установлен старший разряд, то берем системный цвет
If Color And HighBit Then
CheckSysColor = GetSysColor(Color And Not HighBit)
Else
CheckSysColor = Color
End If
End Function
Sub DrawShapes(pct As PictureBox, cbo As ComboBox)
' Начальная картинка с пересечением разных линий
' на рисунке
Dim i As Long
Dim x1 As Long, y1 As Long
Dim x2 As Long, y2 As Long
Dim c As Long
Dim MyRnd As Single
' рисуем случайные линии разного цвета
Randomize Timer
With pct
.Cls
For i = 1 To 20
x1 = Rnd * .ScaleWidth
y1 = Rnd * .ScaleHeight
x2 = Rnd * .ScaleWidth
y2 = Rnd * .ScaleHeight
If i <= 15 Then ' для первых 15 выбираем случайные цвета
MyRnd = Rnd * 7
Else ' для последних — фиксированный синий
MyRnd = 1 'Синий
End If
c = cbo.ItemData(MyRnd) ' выбор цвета
' прямая или круг (чет/нечет)
If i Mod 2 Then
pct.Line (x1, y1)-(x2, y2), c, B
Else
pct.Circle (x1, y1), y2, c
End If
Next i
End With
End Sub
Sub FillStyleList(ByVal cbo As ComboBox)
' заполнение списка типом фактуры
With cbo
.AddItem "Сплошная заливка"
.ItemData(.NewIndex) = vbFSSolid
.AddItem "Горизонтальные линии"
.ItemData(.NewIndex) = vbHorizontalLine
.AddItem "Вертикальные линии"
.ItemData(.NewIndex) = vbVerticalLine
.AddItem "Верхняя диагональ"
.ItemData(.NewIndex) = vbUpwardDiagonal
.AddItem "Нижняя диагональ"
.ItemData(.NewIndex) = vbDownwardDiagonal
.AddItem "Клетка"
.ItemData(.NewIndex) = vbCross
.AddItem "Косая клетка"
.ItemData(.NewIndex) = vbDiagonalCross
End With
End Sub
Sub FillColorList(ByVal cbo As ComboBox)
' заполнение списка названиями цветов
With cbo
.AddItem "Черный"
.ItemData(.NewIndex) = vbBlack
.AddItem "Синий"
.ItemData(.NewIndex) = vbBlue
.AddItem "Циан"
.ItemData(.NewIndex) = vbCyan
.AddItem "Зеленый"
.ItemData(.NewIndex) = vbGreen
.AddItem "Лиловый"
.ItemData(.NewIndex) = vbMagenta
.AddItem "Красный"
.ItemData(.NewIndex) = vbRed
.AddItem "Белый"
.ItemData(.NewIndex) = vbWhite
.AddItem "Желтый"
.ItemData(.NewIndex) = vbYellow
End With
End Sub