Im heutigen Internet-Zeitalter verlangen unsere VB-Programme nach einem modernen Look & Feel. Wie man seine Programme mit sogenannten Hyperlinks ausstattet, das zeigt Ihnen nachfolgendes Klassen-Modul. Ein HyperLabel soll "Links" des folgenden Typs starten können:
Alles was Sie hierzu benötigen, ist eine Picturebox auf der aufrufenden Form. Die Picturebox wird durch die Klasse sogar automatisch auf die richtige Größe angepasst. Wie wird das Hyperlabel genutzt? Legen Sie in einem neuen Projekt ein neues Klassenmodul an. Benennen Sie das Klassenmodul cHyperLabel. Fügen Sie den nachfolgenden Code in das Klassenmodul ein. Option Explicit ' Benötigte API´s Private Declare Function SetCapture Lib "user32" ( _ ByVal hwnd As Long) As Long Private Declare Function ReleaseCapture Lib "user32" () As Long 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 ' Errorcode ShellExecute Private Const SE_ERR_NOTFOUND = 2 ' Aufzählung LinkType Public Enum eLinkType URL = 0 Mail = 1 Dokument = 2 End Enum ' Öffentliche Events Public WithEvents Hyperlabel As PictureBox Public Event Status(ByVal LinkSuccess As Boolean, _ ByVal ReturnCode As Long) ' Öffentliche Eigenschaften der Klasse Public AddGapWidth As Long Public AddGapHeight As Long Public LabelText As String Public LinkColor As OLE_COLOR Public Link As String Public LinkType As eLinkType Public ShowBold As Boolean Public TextOffsetX As Long Public TextOffsetY As Long Public VisitedLinkColor As OLE_COLOR ' Klassenvariablen Private hasVisited As Boolean Private Sub Class_Initialize() ' Initialisieren der Klasse, Eigenschaften ' vorbesetzen AddGapWidth = 50 AddGapHeight = 50 hasVisited = False LinkColor = &HFF0000 LinkType = URL ShowBold = True TextOffsetX = 0 TextOffsetY = 0 VisitedLinkColor = &HC000C0 End Sub Public Sub InitHyperLabel() ' Initialisieren des HyperLabels Dim tmpWidth As Long With Hyperlabel tmpWidth = .Width AddGapWidth = IIf(AddGapWidth < 30, 30, AddGapWidth) AddGapHeight = IIf(AddGapHeight < 30, 30, AddGapHeight) .Cls .AutoRedraw = True .FontUnderline = True .Height = .TextHeight(LabelText) + AddGapHeight .Width = .TextWidth(LabelText) + AddGapWidth .Left = .Left - ((.Width - tmpWidth) \ 2) .BorderStyle = 0 .CurrentX = TextOffsetX .CurrentY = TextOffsetY Hyperlabel.Print LabelText End With End Sub Private Sub Hyperlabel_Click() ' Klick auf das HyperLabel wurde ausgelöst Dim tmpString As String Dim lRet As Long ' Init der Eigenschaft Link tmpString = Link If tmpString = "" Then RaiseEvent Status(False, SE_ERR_NOTFOUND) Exit Sub End If ' LinkType auswerten Select Case LinkType Case eLinkType.URL If Left$(LCase(tmpString), 7) <> "http://" Then _ tmpString = "http://" & tmpString Case eLinkType.Mail If Left$(LCase(tmpString), 7) <> "mailto:" Then _ tmpString = "mailto:" & tmpString End Select ' Link starten Screen.MousePointer = 11 lRet = ShellExecute(Hyperlabel.Parent.hwnd, "open", _ tmpString, vbNullString, vbNullString, vbNormalFocus) Screen.MousePointer = 0 ' Returncode auswerten und RaiseEvent auslösen hasVisited = IIf(lRet <> SE_ERR_NOTFOUND, True, False) RaiseEvent Status(lRet <> SE_ERR_NOTFOUND, lRet) If hasVisited Then Hyperlabel_MouseMove 0, 0, -1, -1 DoEvents End Sub Private Sub Hyperlabel_MouseMove(Button As Integer, _ Shift As Integer, X As Single, Y As Single) ' Mausbewegungen auswerten Dim l As Long Dim tmpWidth As Long Static SaveColor As OLE_COLOR Static isMouseOver As Boolean With Hyperlabel ' Ist die Maus über dem HyperLabel ? If X >= 0 And X <= .Width And Y >= 0 And Y <= .Height Then l = SetCapture(.hwnd) If Not isMouseOver Then isMouseOver = True SaveColor = .ForeColor .Cls .ForeColor = IIf(hasVisited = True, _ VisitedLinkColor, LinkColor) If ShowBold Then tmpWidth = .Width .FontBold = True .Width = .TextWidth(LabelText) + AddGapWidth .Left = .Left - ((.Width - tmpWidth) \ 2) End If .CurrentX = TextOffsetX .CurrentY = TextOffsetY Hyperlabel.Print LabelText DoEvents End If ' Hat die Maus das HyperLabel verlassen ? Else l = ReleaseCapture() isMouseOver = False .Cls .ForeColor = SaveColor If ShowBold Then tmpWidth = .Width .FontBold = False .Width = .TextWidth(LabelText) + AddGapWidth .Left = .Left - ((.Width - tmpWidth) \ 2) End If .CurrentX = TextOffsetX .CurrentY = TextOffsetY Hyperlabel.Print LabelText DoEvents End If End With End Sub Beispiel: Option Explicit Private WithEvents nHyperURL As cHyperLabel Private Sub Form_Load() Set nHyperURL = New cHyperLabel Set nHyperURL.Hyperlabel = Picture1 With nHyperURL .LabelText = "vbarchiv" .Link = "www.vbarchiv.net" .LinkType = URL .InitHyperLabel End With End Sub Das HyperLabel verfügt insgesamt über:
Wie Sie den vollen Umfang des HyperLabels zusammen mit einigen Grafikelementen nutzen können, zeigt Ihnen eindrucksvoll unser Demoprojekt. Dieser Tipp wurde bereits 13.272 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
vb@rchiv CD Vol.6 Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! Online-Update-Funktion Entwickler-Vollversionen u.v.m. Tipp des Monats April 2024 Skyfloy Chart von Microsoft und dazu noch gratis Tutorial für Microsoft Chart Controls für Microsoft .NET Framework 3.5 Neu! sevPopUp 2.0 Dynamische Kontextmenüs! Erstellen Sie mit nur wenigen Zeilen Code Kontextmenüs dynamisch zur Laufzeit. Vordefinierte Styles (XP, Office, OfficeXP, Vista oder Windows 8) erleichtern die Anpassung an die eigenen Anwendung... |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |