home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 1997 March / VPR9703A.ISO / MS_DEV / VBCCE / SAMPLES / Flexlbl / FlexLbl.EXE / RCDATA / CABINET / Flexlbl.ctl < prev    next >
Text File  |  1996-10-25  |  7KB  |  226 lines
  1. VERSION 5.00
  2. Begin VB.UserControl FlexLabel 
  3.    ClientHeight    =   660
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   1500
  7.    BeginProperty Font 
  8.       Name            =   "Tahoma"
  9.       Size            =   8.4
  10.       Charset         =   0
  11.       Weight          =   400
  12.       Underline       =   0   'False
  13.       Italic          =   0   'False
  14.       Strikethrough   =   0   'False
  15.    EndProperty
  16.    PropertyPages   =   "FlexLbl.ctx":0000
  17.    ScaleHeight     =   660
  18.    ScaleWidth      =   1500
  19.    ToolboxBitmap   =   "FlexLbl.ctx":0004
  20.    Begin VB.Label lblInfo 
  21.       Height          =   375
  22.       Left            =   120
  23.       TabIndex        =   0
  24.       Top             =   120
  25.       Width           =   1215
  26.    End
  27. End
  28. Attribute VB_Name = "FlexLabel"
  29. Attribute VB_GlobalNameSpace = False
  30. Attribute VB_Creatable = True
  31. Attribute VB_PredeclaredId = False
  32. Attribute VB_Exposed = True
  33. '   FlexLabel Control
  34. '   VB Component Team
  35. '   Microsoft Corporation
  36. '   October 1996
  37.  
  38. Option Explicit
  39.  
  40. 'Constant for TrueType check
  41. Private Const TMPF_TRUETYPE = &H4
  42.  
  43. 'UDT for TrueType check
  44. Private Type TEXTMETRIC
  45.         tmHeight            As Long
  46.         tmAscent            As Long
  47.         tmDescent           As Long
  48.         tmInternalLeading   As Long
  49.         tmExternalLeading   As Long
  50.         tmAveCharWidth      As Long
  51.         tmMaxCharWidth      As Long
  52.         tmWeight            As Long
  53.         tmOverhang          As Long
  54.         tmDigitizedAspectX  As Long
  55.         tmDigitizedAspectY  As Long
  56.         tmFirstChar         As Byte
  57.         tmLastChar          As Byte
  58.         tmDefaultChar       As Byte
  59.         tmBreakChar         As Byte
  60.         tmItalic            As Byte
  61.         tmUnderlined        As Byte
  62.         tmStruckOut         As Byte
  63.         tmPitchAndFamily    As Byte
  64.         tmCharSet           As Byte
  65. End Type
  66.  
  67. 'API declare for TrueType check
  68. Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
  69.  
  70. Enum FlexLabelErr
  71.     errNonTrueTypeFont
  72. End Enum
  73.  
  74. 'Default Property Values
  75. Const m_def_Caption = "FlexLabel"
  76.  
  77. 'Property Variables
  78. Dim m_Caption               As String
  79. Dim ChangeInProgress        As Boolean
  80.  
  81. 'Initialize Properties for User Control
  82. Private Sub UserControl_InitProperties()
  83.     ChangeInProgress = False
  84.     lblInfo.Caption = UserControl.Name
  85. End Sub
  86.  
  87. Private Sub UserControl_Resize()
  88.     If ChangeInProgress = False Then
  89.         ChangeInProgress = True
  90.         
  91. '       --- Set height of text to match box
  92.         With lblInfo
  93.           If TextHeight(.Caption) > Height Then
  94.               While (TextHeight(.Caption) > Height)
  95.                   FontSize = FontSize - 1
  96.               Wend
  97.           ElseIf TextHeight(.Caption) < Height Then
  98.               While (TextHeight(.Caption) < Height)
  99.                   FontSize = FontSize + 1
  100.               Wend
  101.               FontSize = FontSize - 1
  102.           End If
  103.           
  104.           .FontSize = FontSize
  105.           
  106.   '       --- Set width of box to match text
  107.           If Len(.Caption) = 0 Then
  108.               Width = 100
  109.           Else
  110.               Width = TextWidth(.Caption)
  111.           End If
  112.           
  113.           .Move 0, 0, ScaleWidth, ScaleHeight
  114.         End With  'lblInfo
  115.         
  116.         ChangeInProgress = False
  117.     End If
  118. End Sub
  119.  
  120. 'Load property values from storage
  121. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  122.     lblInfo.Caption = PropBag.ReadProperty("Caption", "FlexLabel")
  123.   lblInfo.ToolTipText = PropBag.ReadProperty("ToolTipText", "")
  124. End Sub
  125.  
  126. 'Write property values to storage
  127. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  128.     Call PropBag.WriteProperty("Caption", lblInfo.Caption, "FlexLabel")
  129.   Call PropBag.WriteProperty("ToolTipText", lblInfo.ToolTipText, "")
  130. End Sub
  131.  
  132. Public Property Get Font() As Font
  133. Attribute Font.VB_Description = "Returns a Font object."
  134. Attribute Font.VB_UserMemId = -512
  135.     Set Font = lblInfo.Font
  136. End Property
  137.  
  138. Public Property Set Font(ByVal New_Font As Font)
  139.     Dim tmpFont As Font
  140.         
  141.     Set tmpFont = lblInfo.Font
  142.     
  143.     Set UserControl.Font = New_Font
  144.     
  145.     If IsTrueType(UserControl.hdc) Then
  146. '       Update control with new font informaton
  147.         lblInfo.Font = New_Font
  148.         
  149.         With lblInfo.Font
  150.           .Bold = New_Font.Bold
  151.           .Italic = New_Font.Italic
  152.           .Strikethrough = New_Font.Strikethrough
  153.           .Underline = New_Font.Underline
  154.           .Weight = New_Font.Weight
  155.         End With  'lblInfo.Font
  156.           
  157.         UserControl_Resize
  158.     Else
  159. '       Report error and reset font
  160.         ErrorInfo (errNonTrueTypeFont)
  161.         Set UserControl.Font = tmpFont
  162.     End If
  163. End Property
  164.  
  165. Public Property Get Caption() As String
  166. Attribute Caption.VB_Description = "Returns/sets the text displayed in an object's title bar or below an object's icon."
  167.     Caption = lblInfo.Caption
  168. End Property
  169.  
  170. Public Property Let Caption(ByVal New_Caption As String)
  171.     lblInfo.Caption = New_Caption
  172.  
  173. '   Update control with new text information
  174.     UserControl_Resize
  175.     
  176.     PropertyChanged "Caption"
  177. End Property
  178.  
  179. Private Function IsTrueType(phDC As Long) As Boolean
  180.     Dim lRet As Long
  181.     Dim pMETRIC As TEXTMETRIC
  182.     
  183.     lRet = GetTextMetrics(phDC, pMETRIC)
  184.     
  185.     If (pMETRIC.tmPitchAndFamily And TMPF_TRUETYPE) > 0 Then
  186.         IsTrueType = True
  187.     Else
  188.         IsTrueType = False
  189.     End If
  190.  
  191. End Function
  192.  
  193. Public Sub ErrorInfo(MyErrNumber As FlexLabelErr)
  194.     Const ErrLocation As String = "FlexLabel Control"
  195.     Dim lStr As String
  196.     
  197.     Select Case MyErrNumber
  198.         Case errNonTrueTypeFont
  199.             lStr = "An attempt was made to set the control font to a " & _
  200.                    "non TrueType font.  The control font remains unchanged."
  201.             
  202.             If Ambient.UserMode Then
  203.                 Err.Raise vbObjectError + errNonTrueTypeFont, _
  204.                           UserControl.Name, lStr
  205.             Else
  206.                 MsgBox lStr, vbOKOnly + vbExclamation, ErrLocation
  207.             End If
  208.         Case Else
  209.             With Err
  210.               .Raise .Number, .Source, .Description
  211.             End With  'Err
  212.     End Select
  213. End Sub
  214. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  215. 'MappingInfo=lblInfo,lblInfo,-1,ToolTipText
  216. Public Property Get ToolTipText() As String
  217. Attribute ToolTipText.VB_Description = "Returns/sets the text displayed when the mouse is paused over the control."
  218.   ToolTipText = lblInfo.ToolTipText
  219. End Property
  220.  
  221. Public Property Let ToolTipText(ByVal New_ToolTipText As String)
  222.   lblInfo.ToolTipText = New_ToolTipText
  223.   PropertyChanged "ToolTipText"
  224. End Property
  225.  
  226.