ActiveX

Листинг для Урока 8

ActiveX Control "ToolTipEx"

UserControl TTEx

'*****************************************************************
'Урок 8

'ActiveX Control - "ToolTipEx"

'Листинг

'*****************************************************************

Option Explicit

'*****************************************************************
'Объявление API-функций

'*****************************************************************

Private Declare Function GetWindowRect Lib "user32" _

    (ByVal hwnd As Long, lpRect As RECT) As Long

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 Const SM_CYCAPTION = 4

Private CaptionHeight As Long ' высота заголовка формы

Private PFrm As RECT 'позиция формы, содержащей UserControl

'*****************************************************************
'Свойства

'*****************************************************************

Public Property Get Text() As String

    Text = frmToolTipEx.lblTTEx.Caption

End Property

Public Property Let Text(ByVal New_Text As String)

    If New_Text = vbNullString Then

        frmToolTipEx.Hide

        Exit Property

    End If

    frmToolTipEx.lblTTEx.Caption = New_Text

    PropertyChanged "Text"

End Property

Public Property Get BackColor() As OLE_COLOR

    BackColor = frmToolTipEx.BackColor

End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)

    frmToolTipEx.BackColor = New_BackColor

    PropertyChanged "BackColor"

End Property

Public Property Get Font() As Font

    Set Font = frmToolTipEx.lblTTEx.Font

End Property

Public Property Set Font(ByVal New_Font As Font)

    Set frmToolTipEx.lblTTEx.Font = New_Font

    PropertyChanged "Font"

End Property

Public Property Get ForeColor() As OLE_COLOR

    ForeColor = frmToolTipEx.lblTTEx.ForeColor

End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)

    frmToolTipEx.lblTTEx.ForeColor = New_ForeColor

    PropertyChanged "ForeColor"

End Property

'*****************************************************************
'Метод

'*****************************************************************

Public Sub ShowTTEx(ctrl As Object)

    GetWindowRect UserControl.Parent.hwnd, PFrm

    CaptionHeight = (GetSystemMetrics(SM_CYCAPTION) * Screen.TwipsPerPixelY)

    With frmToolTipEx

        .Move PFrm.Left * Screen.TwipsPerPixelX + ctrl.Left, _

        PFrm.Top * Screen.TwipsPerPixelY + ctrl.Top + ctrl.Height + CaptionHeight  'перевод в твипы

        .FrmResize

        .Show

    End With

End Sub

'*****************************************************************
'Обработка событий UserControl и контрола

'*****************************************************************

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

    frmToolTipEx.BackColor = PropBag.ReadProperty("BackColor", &HC0FFFF)

    Set frmToolTipEx.lblTTEx.Font = PropBag.ReadProperty("Font", Ambient.Font)

    frmToolTipEx.lblTTEx.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)

    frmToolTipEx.lblTTEx.Caption = PropBag.ReadProperty("Text", vbNullString)

End Sub

Private Sub UserControl_Resize()

    'изменение размеров контрола по размерам Image1

    Size Image1.Width, Image1.Height

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

    Call PropBag.WriteProperty("BackColor", frmToolTipEx.BackColor, &HC0FFFF)

    Call PropBag.WriteProperty("Font", frmToolTipEx.lblTTEx.Font, Ambient.Font)

    Call PropBag.WriteProperty("ForeColor", frmToolTipEx.lblTTEx.ForeColor, &H80000012)

    Call PropBag.WriteProperty("Text", frmToolTipEx.lblTTEx.Caption, vbNullString)

End Sub

Ôîðìà frmToolTipEx

Option Explicit

'*****************************************************************
'Объявление API-функций

'*****************************************************************

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 HWND_TOPMOST = -1

Const SWP_NOMOVE = &H2

Const SWP_NOSIZE = &H1

'*****************************************************************
'Обработка событий формы

'*****************************************************************

Public Sub FrmResize()

    Me.Height = lblTTEx.Height + 60

End Sub

Private Sub Form_Load()

    SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE

    FrmResize

End Sub

К статье