home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / firese1a / urllink.ctl < prev    next >
Encoding:
Text File  |  1999-09-19  |  4.5 KB  |  144 lines
  1. VERSION 5.00
  2. Begin VB.UserControl URLLink 
  3.    ClientHeight    =   3600
  4.    ClientLeft      =   0
  5.    ClientTop       =   0
  6.    ClientWidth     =   4800
  7.    ScaleHeight     =   3600
  8.    ScaleWidth      =   4800
  9.    Begin VB.Label lblURL 
  10.       Caption         =   "Label1"
  11.       BeginProperty Font 
  12.          Name            =   "MS Sans Serif"
  13.          Size            =   8.25
  14.          Charset         =   0
  15.          Weight          =   400
  16.          Underline       =   -1  'True
  17.          Italic          =   0   'False
  18.          Strikethrough   =   0   'False
  19.       EndProperty
  20.       ForeColor       =   &H8000000D&
  21.       Height          =   615
  22.       Left            =   120
  23.       MouseIcon       =   "URLLink.ctx":0000
  24.       MousePointer    =   99  'Custom
  25.       TabIndex        =   0
  26.       Top             =   120
  27.       Width           =   1575
  28.    End
  29. End
  30. Attribute VB_Name = "URLLink"
  31. Attribute VB_GlobalNameSpace = False
  32. Attribute VB_Creatable = True
  33. Attribute VB_PredeclaredId = False
  34. Attribute VB_Exposed = False
  35. Option Explicit
  36.  
  37. Private Const DEF_TEXT = "Open in new window"
  38. Private Const DEF_URL = "http://tazmanuk.cjb.net"
  39. Private Const DEF_SHOWTOOLTIP = False
  40.  
  41. Private m_sURL As String
  42. Private m_bShowToolTip As Boolean
  43.  
  44. Event GoToURL(URL As String, Cancel As Boolean)
  45.  
  46. Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
  47. Private Const SW_NORMAL = 1
  48.  
  49. Public Property Get Text() As String
  50. Attribute Text.VB_Description = "Text displayed in control"
  51. Attribute Text.VB_ProcData.VB_Invoke_Property = ";Text"
  52. Attribute Text.VB_UserMemId = -517
  53.     Text = lblURL.Caption
  54. End Property
  55.  
  56. Public Property Let Text(sText As String)
  57.     lblURL.Caption = sText
  58.     lblURL.Move 0, 0, UserControl.TextWidth(sText), _
  59.         UserControl.TextHeight(sText)
  60.     PropertyChanged "Text"
  61. End Property
  62.  
  63. Public Property Get URL() As String
  64. Attribute URL.VB_Description = "URL loaded when mouse is clicked over text. May also be a data file that has an extension registered by an application on your system."
  65. Attribute URL.VB_ProcData.VB_Invoke_Property = ";Behavior"
  66. Attribute URL.VB_MemberFlags = "200"
  67.     URL = m_sURL
  68. End Property
  69.  
  70. Public Property Let URL(sURL As String)
  71.     m_sURL = sURL
  72.     SetToolTip
  73.     PropertyChanged "URL"
  74. End Property
  75.  
  76. Public Property Get ShowToolTip() As Boolean
  77. Attribute ShowToolTip.VB_Description = "Determines if the URL is displayed in a tooltip when the mouse is parked over the text"
  78. Attribute ShowToolTip.VB_ProcData.VB_Invoke_Property = ";Behavior"
  79.     ShowToolTip = m_bShowToolTip
  80. End Property
  81.  
  82. Public Property Let ShowToolTip(bShowToolTip As Boolean)
  83.     m_bShowToolTip = bShowToolTip
  84.     SetToolTip
  85.     PropertyChanged "ShowToolTip"
  86. End Property
  87.  
  88. Private Sub SetToolTip()
  89.     If m_bShowToolTip Then
  90.         lblURL.ToolTipText = m_sURL
  91.     Else
  92.         lblURL.ToolTipText = ""
  93.     End If
  94. End Sub
  95.  
  96. 'Load the URL in response to mousedown
  97. Private Sub lblURL_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  98.     Dim bCancel As Boolean
  99.     Dim sURL As String
  100.  
  101.     If Button And vbLeftButton Then
  102.         'Give user a chance to modify or cancel URL jump
  103.         sURL = m_sURL
  104.         RaiseEvent GoToURL(sURL, bCancel)
  105.         If bCancel Then Exit Sub
  106.         On Error GoTo LinkError
  107.         Screen.MousePointer = vbHourglass
  108.         ShellExecute hwnd, "open", sURL, vbNullString, vbNullString, SW_NORMAL
  109.     End If
  110. EndMouseDown:
  111.     Screen.MousePointer = vbDefault
  112.     Exit Sub
  113. LinkError:
  114.     MsgBox "Unable to load '" & sURL & "' : " & _
  115.         Err.Description & " (Error " & CStr(Err.Number) & ")"
  116.     Resume EndMouseDown
  117. End Sub
  118.  
  119. 'Initialize control properties on first use
  120. Private Sub UserControl_InitProperties()
  121.     Text = DEF_TEXT
  122.     m_sURL = DEF_URL
  123.     ShowToolTip = DEF_SHOWTOOLTIP
  124. End Sub
  125.  
  126. 'Load control properties
  127. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  128.     On Error GoTo ReadPropErr
  129.     Text = PropBag.ReadProperty("Text", DEF_TEXT)
  130.     m_sURL = PropBag.ReadProperty("URL", DEF_URL)
  131. EndReadProp:
  132.     Exit Sub
  133. ReadPropErr:
  134.     'Use default property settings
  135.     UserControl_InitProperties
  136.     Resume EndReadProp
  137. End Sub
  138.  
  139. 'Save control properties
  140. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  141.     PropBag.WriteProperty "Text", Text, DEF_TEXT
  142.     PropBag.WriteProperty "URL", m_sURL, DEF_URL
  143. End Sub
  144.