home *** CD-ROM | disk | FTP | other *** search
Wrap
Visual Basic user-defined control file | 2001-08-01 | 9.3 KB | 271 lines
VERSION 5.00 Begin VB.UserControl pucTextTip BackStyle = 0 'Transparent ClientHeight = 1350 ClientLeft = 0 ClientTop = 0 ClientWidth = 3480 ControlContainer= -1 'True FillColor = &H80000018& FillStyle = 0 'Solid ForwardFocus = -1 'True ScaleHeight = 90 ScaleMode = 3 'Pixel ScaleWidth = 232 ToolboxBitmap = "SimpleTip.ctx":0000 Begin VB.TextBox txtTip BackColor = &H80000018& BorderStyle = 0 'None ForeColor = &H80000017& Height = 465 Left = 225 Locked = -1 'True MousePointer = 1 'Arrow MultiLine = -1 'True ScrollBars = 2 'Vertical TabIndex = 1 Top = 720 Visible = 0 'False Width = 3075 End Begin VB.Image imgPicture Height = 330 Left = 0 Top = 135 Width = 330 End Begin VB.Label lblTip AutoSize = -1 'True BackColor = &H80000018& Caption = "Label1" ForeColor = &H80000017& Height = 195 Left = 225 TabIndex = 0 Top = 180 Visible = 0 'False Width = 3075 WordWrap = -1 'True End End Attribute VB_Name = "pucTextTip" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '--------------------------------------' ' TextTip Private UserControl ' ' Version 5.0 ' '--------------------------------------' ' Ariad Development Library 5.0 ' '--------------------------------------' 'Copyright ⌐ 2000-2001 by Ariad Software. All Rights Reserved. 'Created : 13/10/2000 'Completed : 13/10/2000 'Last Updated : 19/10/2000 '15/10/2000 ' - FIX: Font property not being set ' correctly when control first ' created '19/10/2000 ' - FIX: A VB bug causes labels to ' occasionaly size larger than ' specified when text is changed. Option Explicit Private Declare Function RoundRect& Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) Const CornerSize As Long = 26 Const ControlYOffset As Long = 6 Const ControlXOffset As Long = 8 Private WithEvents pFont As StdFont Attribute pFont.VB_VarHelpID = -1 Private pPicture As StdPicture Private pText As String '---------------------------------------------------------------------- 'Name : Picture 'Created : 13/10/2000 14:16 '---------------------------------------------------------------------- 'Description : Returns or sets a graphic to be displayed in a control. '---------------------------------------------------------------------- 'Returns : Returns a StdPicture Object '---------------------------------------------------------------------- 'Updates : ' '---------------------------------------------------------------------- Public Property Get Picture() As StdPicture Attribute Picture.VB_Description = "Returns or sets a graphic to be displayed in a control." '##BLOCK_DESCRIPTION Returns or sets a graphic to be displayed in a control. Set Picture = pPicture End Property '(Public) Property Get Picture () As StdPicture Property Set Picture(ByVal Picture As StdPicture) Set pPicture = Picture Set imgPicture.Picture = Picture UserControl_Resize PropertyChanged "Picture" End Property ' Property Set Picture '---------------------------------------------------------------------- 'Name : pFont_FontChanged 'Created : 01/12/1999 19:52 'Modified : 'Modified By : '---------------------------------------------------------------------- 'Description : Occurs when the font changes '---------------------------------------------------------------------- Private Sub pFont_FontChanged(ByVal PropertyName As String) 'account for changes such as Font.Bold etc as opposed 'to Set Font = Set Font = pFont End Sub '---------------------------------------------------------------------- 'Name : Font 'Created : 14/07/1999 19:12 'Modified : 'Modified By : '---------------------------------------------------------------------- 'Description : Returns or sets the primary font object '---------------------------------------------------------------------- 'Returns : A font object containing the font '---------------------------------------------------------------------- Public Property Get Font() As StdFont '##BLOCK_DESCRIPTION Returns or sets the default font used to display text in a control Set Font = pFont End Property Public Property Set Font(ByVal Font As StdFont) If Font Is Nothing Then Err.Raise 380, , "Cannot set Font to Nothing" Else Set pFont = Font Set lblTip.Font = Font Set txtTip.Font = Font PropertyChanged "Font" Refresh End If End Property '------------------------------------------------------------------- 'Name : Text 'Created : 13/10/2000 12:43 '------------------------------------------------------------------- 'Description : Returns or sets the text contained in the edit area. '------------------------------------------------------------------- 'Returns : Returns a String Variable '------------------------------------------------------------------- 'Updates : ' '------------------------------------------------------------------- Public Property Get Text() As String Attribute Text.VB_Description = "Returns or sets the text contained in the edit area." Attribute Text.VB_UserMemId = -517 Attribute Text.VB_MemberFlags = "200" '##BLOCK_DESCRIPTION Returns or sets the text contained in the edit area. Text = pText End Property '(Public) Property Get Text () As String Property Let Text(ByVal Text As String) Dim Left As Long pText = Replace$(Text$, "<CR>", "<B>") lblTip.Caption = Replace$(pText, "<B>", vbCr) txtTip.Text = Replace$(pText, "<B>", vbCrLf) lblTip.AutoSize = False lblTip.AutoSize = True Left = ControlXOffset If Not pPicture Is Nothing Then Left = Left + ScaleX(pPicture.Width, vbHimetric, vbPixels) + ControlXOffset End If lblTip.Width = ScaleWidth - (Left + ControlXOffset) txtTip.Width = lblTip.Width If lblTip.Height > (ScaleHeight - (ControlYOffset * 2)) Then txtTip.Visible = True lblTip.Visible = False Else lblTip.Visible = True txtTip.Visible = False End If PropertyChanged "Text" End Property ' Property Let Text '-------------------------------------------------------------- 'Name : Refresh 'Created : 13/10/2000 12:30 '-------------------------------------------------------------- 'Description : Forces a complete repaint of a form or control. '-------------------------------------------------------------- 'Updates : ' '-------------------------------------------------------------- Public Sub Refresh() Attribute Refresh.VB_Description = "Forces a complete repaint of a form or control." '##BLOCK_DESCRIPTION Forces a complete repaint of a form or control. On Error Resume Next Cls RoundRect hDC, 0, 0, ScaleWidth, ScaleHeight, 20, 20 UserControl.Refresh Set MaskPicture = Image On Error GoTo 0 End Sub '(Public) Sub Refresh () Private Sub UserControl_Initialize() UserControl.AutoRedraw = True End Sub Private Sub UserControl_InitProperties() Set Font = Ambient.Font Text = Ambient.DisplayName Refresh End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) UserControl_Resize With PropBag Set Font = .ReadProperty("Font", Ambient.Font) Set Picture = .ReadProperty("Picture", Nothing) Text = .ReadProperty("Text", Ambient.DisplayName) End With Refresh End Sub Private Sub UserControl_Resize() Dim Left As Long On Error Resume Next Left = ControlXOffset If Not pPicture Is Nothing Then Left = Left + ScaleX(pPicture.Width, vbHimetric, vbPixels) + ControlXOffset End If imgPicture.Move ControlXOffset, ControlYOffset lblTip.Move Left, ControlYOffset, ScaleWidth - (Left + ControlXOffset), ScaleHeight - (ControlYOffset * 2) txtTip.Move Left, ControlYOffset, ScaleWidth - (Left + ControlXOffset), ScaleHeight - (ControlYOffset * 2) Text = pText On Error GoTo 0 Refresh End Sub Private Sub UserControl_Show() Refresh End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) With PropBag .WriteProperty "Font", pFont, Ambient.Font .WriteProperty "Picture", pPicture, Nothing .WriteProperty "Text", pText$, Ambient.DisplayName End With End Sub