建立可打开超联接的Label

    在很多的应用软件的帮助窗口中有软件站点超联接的Label,只要鼠标单击
就可以自动调用浏览器打开相应的站点。下面的程序利用VB介绍如何实现上面的
功能。
    在介绍程序前首先介绍URL（资源统一定位符）。这是定位Internet上资源
（包括http,ftp,email,gopher等资源）的字符串，例如超文本一般的形式是：
http://www.pccomputing.com.cn Email一般是 mailto:develop@163.net 。
    程序的思路是首先从注册表中读入相应的资源的默认的打开程序，再使用这个
程序打开资源定位字符串。下面是具体的程序。
    首先在Form1中加入四个Label控件，设置这些Label的Caption属性为某一
URL。如 http://vbtips.yeah.net telnet:bbs.tsinghua.edu.cn 。

在Form1中加入下面的代码：
	
'Form1的程序清单
Sub LinkTo(IStr As String)
    Dim astr As String
    Dim bstr As String
    Dim a As Integer
    
    If InStr(IStr, ":") Then
        astr = Left$(IStr, InStr(IStr, ":") - 1)
        astr = astr + "\shell\open\command\"
        bstr = QueryValue(HKEY_CLASSES_ROOT, astr, "")
        If Left$(bstr, 1) = Chr(34) Then
            a = InStr(2, bstr, Chr(34))
            bstr = Mid$(bstr, 2, a - 2) + " " + IStr
        ElseIf InStr(bstr, "%") Then
            bstr = Left$(bstr, InStr(bstr, "%") - 1) + IStr
        Else
            Exit Sub
        End If
        Shell bstr
    Else
        MsgBox ("没有有效的URL连接")
    End If
End Sub

Private Sub Form_Load()
    Label1.Caption = "telnet:bbs.tsinghua.edu.cn"
    Label2.Caption = "http://vbtips.yeah.net"
    Label3.Caption = "ftp://ftp.microsoft.com"
    Label4.Caption = "mailto:develop@371.net"
End Sub

Private Sub Label1_Click()
    LinkTo Label1.Caption
End Sub

Private Sub Label2_Click()
    LinkTo Label2.Caption
End Sub

Private Sub Label3_Click()
    LinkTo Label3.Caption
End Sub

Private Sub Label4_Click()
    LinkTo Label4.Caption
End Sub

在Project中加入一个Module，在Module中加入以下程序：

'Module1.bas的程序清单
Option Explicit

Global Const REG_SZ As Long = 1
Global Const REG_DWORD As Long = 4
Global Const HKEY_CLASSES_ROOT = &H80000000
Global Const KEY_ALL_ACCESS = &H3F
Global Const ERROR_NONE = 0


Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _
        hKey As Long) As Long
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
        "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As _
        String, ByVal ulOptions As Long, ByVal samDesired As _
        Long, phkResult As Long) As Long
Public Declare Function RegQueryValueExString Lib "advapi32.dll" _
        Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal _
        lpValueName As String, ByVal lpReserved As Long, lpType _
        As Long, ByVal lpData As String, lpcbData As Long) As Long
Public Declare Function RegQueryValueExLong Lib "advapi32.dll" _
        Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal _
        lpValueName As String, ByVal lpReserved As Long, lpType _
        As Long, lpData As Long, lpcbData As Long) As Long
Public Declare Function RegQueryValueExNULL Lib "advapi32.dll" _
        Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal _
        lpValueName As String, ByVal lpReserved As Long, lpType _
        As Long, ByVal lpData As Long, lpcbData As Long) As Long

Public Function QueryValue(lPredefinedKey As Long, sKeyName As _
        String, sValueName As String)
       Dim lRetVal As Long
       Dim hKey As Long
       Dim vValue As Variant

       lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, _
                KEY_ALL_ACCESS, hKey)
       lRetVal = QueryValueEx(hKey, sValueName, vValue)
       QueryValue = vValue
       RegCloseKey (hKey)
End Function

Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName _
         As String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String

    On Error GoTo QueryValueExError
    
    '获得键值的属性
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, _
            cch)
    If lrc <> ERROR_NONE Then Error 5

    Select Case lType
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, _
                lType, sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If

        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, _
                lType, lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case Else
            lrc = -1
    End Select

QueryValueExExit:

    QueryValueEx = lrc
    Exit Function

QueryValueExError:

    Resume QueryValueExExit

End Function

    运行程序,点击Label,就可以调用相应的程序打开URL了。
    以上程序在Windows98，VB5.0下运行通过。