Macro to Create a Hyperlink

[sspatriots]

I'm trying to use the code below to create a hyperlink on a cell that is selected when the dialog box pops up. It will create a hyperlink, but replaces the cell contents with the entire link path. I tried using
fName = ActiveCell.Value 'Mid(fPath, InStrRev(fPath, "") + 1, 9999), but that only works if I have that cell activated before I run the macro. I'd like the link name be the cell value that was originally in the cell. The only other issue I am having with this code is if I run the macro and try and cancel out from the pop-up dialog box, I get the error message below the code shown below.

Sub CreateHyperLink()
Dim fd As Object, fPath As String, fName As String, cel As Range
Set cel = Application.InputBox("Select a cell", "Add Link to File", , , , , , 8)
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'Set selectedCell = Application.ActiveCell
With fd
.InitialFileName = " " 'default folder path - MUST end with \
.AllowMultiSelect = False
.Title = "Please select a file."
.Filters.Clear



If .Show = True Then
fPath = fd.SelectedItems(1)
fName = 'Mid(fPath, InStrRev(fPath, "") + 1, 9999)
Else
Exit Sub
End If
End With
cel.Hyperlinks.Add Anchor:=cel, Address:=fPath, TextToDisplay:=fName
End Sub

Any suggestions would be greatly appreciated.


Thanks,

SS

 

[Logit]

This works here :

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub HyperlinkFile()
'Opens dialog box to Pick File to Hyperlink

Set xGetFile = Application.FileDialog(msoFileDialogFilePicker)
With xGetFile
    .Title = "Spreadsheet Creative - Select File to Hyperlink"
    If .Show = -1 Then
'Selected File full path
        fName = .SelectedItems(1)
        
    Else
        fName = ""
    End If
End With

'Test if user pressed cancel
If fName = "" Then Exit Sub
'Resume code

'Get File name from path
sFullFilename = Right(fName, Len(fName) - InStrRev(fName, "\"))
On Error Resume Next

'Change display text to the Selected File name WITHOUT FILE EXTENSION
'if you want to display the file extension then change the formula from sFileName to sFullFilename
sFileName = Left(sFullFilename, (InStr(sFullFilename, ".") - 1))
On Error Resume Next

'Add HYPERLINK formula to active cell
ActiveCell.Formula = "=HYPERLINK(""" & fName & """,""" & sFileName & """)"
End Sub

 

[sspatriots]

That code definitely allows me to cancel out, but I need the name of the hyperlink to be the cell value that is selected. If entering the hyperlink manually, I need to have what is in the "Text to display:" field (which is the cell value before running the code).

 

[Logit]

Try this :

Option Explicit

Sub HyperlinkFile()
Dim xGetFile As Object
Dim fName As String, sFullFilename As String, sFileName As String

'Opens dialog box to Pick File to Hyperlink

Set xGetFile = Application.FileDialog(msoFileDialogFilePicker)
With xGetFile
    .Title = "Spreadsheet Creative - Select File to Hyperlink"
    If .Show = -1 Then
'Selected File full path
        fName = .SelectedItems(1)
        
    Else
        fName = ""
    End If
End With

'Test if user pressed cancel
If fName = "" Then Exit Sub
'Resume code

'Get File name from path
sFullFilename = Right(fName, Len(fName) - InStrRev(fName, "\"))
On Error Resume Next

'Change display text to the Selected File name WITHOUT FILE EXTENSION
'if you want to display the file extension then change the formula from sFileName to sFullFilename
'sFileName = Left(sFullFilename, (InStr(sFullFilename, ".") - 1))

sFileName = ActiveCell.Text

On Error Resume Next

'Add HYPERLINK formula to active cell
ActiveCell.Formula = "=HYPERLINK(""" & fName & """,""" & sFileName & """)"
End Sub

 

[sspatriots]

Sorry I haven't gotten to this before now. It came after I left last night and I'm just getting into the office because of an early dentist appointment. I'm not sure where to specify my file path in this code. I tried the following, but it must not be correct.

With xGetFile
.Title = "Spreadsheet Creative - Select File to Hyperlink"
If .Show = -1 Then

.InitialFileName = "G:\Folder\Folder" 'Selected File full path
fName = .SelectedItems(1)

Else
fName = ""
End If
End With

 

[sspatriots]

Tried to edit the last post and my time expired. One other thing missing with this last code is it doesn't take me to a cell to select to put the hyperlink to.

 

[sspatriots]

I ended up adding a code for the input box and then calling the Hyperlink you wrote with my file path and it works smoothly as designed. Thanks for the help. Greatly appreciated.

Sub CreateHyperLink()
Dim myReply As Range

On Error Resume Next
Set myReply = Application.InputBox(prompt:="Please select any cell", Type:=8)
If myReply Is Nothing Then Exit Sub
myReply.Activate

HyperlinkFile


End Sub

 

[Logit]

Glad you have an answer.

 

[sspatriots]

Not sure if I should start a new post on this or not. Everything is working fine, except now one of my colleagues is asking me if we can convert the e-mail message that I have set up to go to a folder on the network into a .pdf file and then save it to a folder.

 

[Logit]

Start a new thread.