|
Листинг 8
UserControl TTEx Option Explicit 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 '******************** Properties ************************** 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 '***************** Method ********************************* 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 Properties ************************ 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 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
|
