Provided by Allen Browne, January 2008
The GoHyperlink() function (below) performs the same task as FollowHyperlink(), with improved control over the outcome. Like FollowHyperlink, you can use it to:
FollowHyperlink can be frustrating:
GoHyperlink addresses those frustrations:
It cannot solve these issues completely:
These are limitations relating to HTML. But you will experience these issues far less frequently than with FollowHyperlink, which fowls up whenever it finds one of these sequences.
To use GoHyperlink() in your database:
You can now use GoHyperlink() anywhere in your database.
For example if you have a form with a hyperlink field named MyHyperlink, use:
Call GoHyperlink(Me.[MyHyperlink])
To open a file, be sure you pass in the full path. If necessary, use:
Call GoHyperlink(CurDir & "\MyDoc.doc")
The PrepareHyperlink() function can also be used to massage a file name so it will be handled correctly as a hyperlink.
Option Compare Database Option Explicit 'Purpose: Avoid warning and error messages when opening files with FollowHyperlink 'Author: Allen Browne (allen@allenbrowne.com) 'Release: 28 January 2008 'Usage: To open MyFile.doc in Word, use: ' GoHyperlink "MyFile.doc" ' instead of: ' FollowHyperlink "MyFile.doc" 'Rationale: 'FollowHyperlink has several problems: ' a) It errors if a file name contains characters such as #, %, or &. ' b) It can give unwanted warnings, e.g. on a fileame with "file:///" prefix. ' c) It yields errors if the link did not open. 'This replacement: ' a) escapes the problem characters ' b) prepends the prefix ' c) returns True if the link opened (with an optional error message if you care.) 'Limitations: ' - If a file name contains two # characters, it is treated as a hyperlink. ' - If a file name contains % followed by 2 hex digits, it assumes it is pre-escaped. ' - File name must include path. 'Documentation: http://allenbrowne.com/func-GoHyperlink.html Public Function GoHyperlink(FullFilenameOrLink As Variant) As Boolean On Error GoTo Err_Handler 'Purpose: Replacement for FollowHyperlink. 'Return: True if the hyperlink opened. 'Argument: varIn = the link to open Dim strLink As String Dim strErrMsg As String 'Skip error, null, or zero-length string. If Not IsError(FullFilenameOrLink) Then If FullFilenameOrLink <> vbNullString Then strLink = PrepHyperlink(FullFilenameOrLink, strErrMsg) If strLink <> vbNullString Then FollowHyperlink strLink 'Return True if we got here without error. GoHyperlink = True End If 'Display any error message from preparing the link. If strErrMsg <> vbNullString Then MsgBox strErrMsg, vbExclamation, "PrepHyperlink()" End If End If End If Exit_Handler: Exit Function Err_Handler: MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "GoHyperlink()" Resume Exit_Handler End Function Public Function PrepHyperlink(varIn As Variant, Optional strErrMsg As String) As Variant On Error GoTo Err_Handler 'Purpose: Avoid errors and warnings when opening hyperlinks. 'Return: The massaged link/file name. 'Arguments: varIn = the link/file name to massage. ' strErrMsg = string to append error messages to. 'Note: Called by GoHyperlink() above. ' Can also be called directly, to prepare hyperlinks. Dim strAddress As String 'File name or address Dim strDisplay As String 'Display part of hyperlink (if provided) Dim strTail As String 'Any remainding part of hyperlink after address Dim lngPos1 As Long 'Position of character in string (and next) Dim lngPos2 As Long Dim bIsHyperlink As Boolean 'Flag if input is a hyperlink (not just a file name.) Const strcDelimiter = "#" 'Delimiter character within hyperlinks. Const strcEscChar = "%" 'Escape character for hyperlinks. Const strcPrefix As String = "file:///" 'Hyperlink type if not supplied. If Not IsError(varIn) Then strAddress = Nz(varIn, vbNullString) End If If strAddress <> vbNullString Then 'Treat as a hyperlink if there are two or more # characters (other than together, or at the end.) lngPos1 = InStr(strAddress, strcDelimiter) If (lngPos1 > 0&) And (lngPos1 < Len(strAddress) - 2&) Then lngPos2 = InStr(lngPos1 + 1&, strAddress, strcDelimiter) End If If lngPos2 > lngPos1 + 1& Then bIsHyperlink = True strTail = Mid$(strAddress, lngPos2 + 1&) strDisplay = Left$(strAddress, lngPos1 - 1&) strAddress = Mid$(strAddress, lngPos1 + 1&, lngPos2 - lngPos1) End If 'Replace any % that is not immediately followed by 2 hex digits (in both display and address.) strAddress = EscChar(strAddress, strcEscChar) strDisplay = EscChar(strDisplay, strcEscChar) 'Replace special characters with percent sign and hex value (address only.) strAddress = EscHex(strAddress, strcEscChar, "&", """", " ", "#", "<", ">", "|", "*", "?") 'Replace backslash with forward slash (address only.) strAddress = Replace(strAddress, "\", "/") 'Add prefix if address doesn't have one. If Not ((varIn Like "*://*") Or (varIn Like "mailto:*")) Then strAddress = strcPrefix & strAddress End If End If 'Assign return value. If strAddress <> vbNullString Then If bIsHyperlink Then PrepHyperlink = strDisplay & strcDelimiter & strAddress & strcDelimiter & strTail Else PrepHyperlink = strAddress End If Else PrepHyperlink = Null End If Exit_Handler: Exit Function Err_Handler: strErrMsg = strErrMsg & "Error " & Err.Number & ": " & Err.Description & vbCrLf Resume Exit_Handler End Function Private Function EscChar(ByVal strIn As String, strEscChar As String) As String 'Purpose: If the escape character is found in the string, ' escape it (unless it is followed by 2 hex digits.) 'Return: Fixed up string. 'Arguments: strIn = the string to fix up ' strEscChar = the single character used for escape sequqnces. (% for hyperlinks.) Dim strOut As String 'output string. Dim strChar As String 'character being considered. Dim strTestHex As String '4-character string of the form &HFF. Dim lngLen As Long 'Length of input string. Dim i As Long 'Loop controller Dim bReplace As Boolean 'Flag to replace character. lngLen = Len(strIn) If (lngLen > 0&) And (Len(strEscChar) = 1&) Then For i = 1& To lngLen bReplace = False strChar = Mid(strIn, i, 1&) If strChar = strEscChar Then strTestHex = "&H" & Mid(strIn, i + 1&, 2&) If Len(strTestHex) = 4& Then If Not IsNumeric(strTestHex) Then bReplace = True End If End If End If If bReplace Then strOut = strOut & strEscChar & Hex(Asc(strEscChar)) Else strOut = strOut & strChar End If Next End If If strOut <> vbNullString Then EscChar = strOut ElseIf lngLen > 0& Then EscChar = strIn End If End Function Private Function EscHex(ByVal strIn As String, strEscChar As String, ParamArray varChars()) As String 'Purpose: Replace any characters from the array with the escape character and their hex value. 'Return: Fixed up string. 'Arguments: strIn = string to fix up. ' strEscChar = the single character used for escape sequqnces. (% for hyperlinks.) ' varChars() = an array of single-character strings to replace. Dim i As Long 'Loop controller If (strIn <> vbNullString) And IsArray(varChars) Then For i = LBound(varChars) To UBound(varChars) strIn = Replace(strIn, varChars(i), strEscChar & Hex(Asc(varChars(i)))) Next End If EscHex = strIn End Function
Home | Index of tips | Top |