"Add Hyperlink" Button that pastes the inserted link into a text box in a form

[abby__edwards]

Basically I have a form set up with a text box that says "SDS Link", where I need people to paste in the file path that they saved a particular file to. I would like to create a button on this form that opens the "Insert Hyperlink" box so people can locate their file within excel and when they hit submit it sends it to the text box. This form is completely set up with a final submit button that adds all the info to the table, but this button would make the form even easier to use so people don't have to go locate the file in the file browser and copy/paste the file path.

Any help is very appreciate - I have gotten no where with this

 

[GWteB]

Hi & welcome to MrExcel!

Is (in the end) a functional hyperlink (linked to a file or folder, both of which can vary) within your worksheet table required or are you just wanting to have the file path as plain text in this table?
I'm asking since you're talking about using a text box as an intermediate UI control before submitting, while hyperlink objects cannot be assigned to text boxes, plain text obviously can.
Either way, regardless of what you want I think it's doable, however, a peek within your workbook would be helpfull so you might consider to upload a sanitized copy of your workbook along with its current VBA code to a public facility like DropBox or Google Drive and to post a shared link within this thread.

 

[abby__edwards]

Hi GWteB,

Yes, the links are active and within the worksheet table! That can definitely be done, thank you. I will upload it now!
Test-Chemical Inventory-program.xlsm
Hopefully this works, thank you

 

[abby__edwards]

Sorry to better clarify, yes they need to be active links and not just plain text so people can open them immediately. They are stored on a shared file folder so everyone has access to them.

 

[GWteB]

I've wrapped a stripped-down version of the Hyperlink object in its own Class. Because user input is required, the use of a UserForm class was obvious.
Note that its class code needs to be NEW'ed and that the form needs to be displayed on screen using the (custom) ShowDialog function, rather than its (built-in) Show method.

Within the workbook you've uploaded I made some changes for implementation purposes.

Workbook on DropBox

I think its use is self explanatory: browse for a file and amend text to be displayed as required.

Usage example, to be pasted in a standard module:

Public Sub LaunchDialog()

    Const INITIALFOLDER As String = "C:\Data\SomeFolder"    ' <<<< File Explorer tries to open within this folder; change to suit

    Dim Dlg    As UsfLinkToFile
    Set Dlg = New UsfLinkToFile

    Dim Rng As Excel.Range
    Set Rng = ThisWorkbook.Sheets("Sheet1").Range("A1")     ' <<<< cell to put hyperlink in; change to suit
    
    Dim HLAddress As String, HLTextToDisplay As String, HLScreenTip As String

    With Dlg
        If .ShowDialog(INITIALFOLDER) Then

            ' some properties can be stored for further use if required
            HLAddress = .Address
            HLTextToDisplay = .TextToDisplay
            HLScreenTip = .ScreenTip

            ' add hyperlink
            .ApplyToRange Rng
        Else
            ' do nothing, aborted by user
        End If
    End With
    Unload Dlg
    Set Dlg = Nothing
End Sub

This goes in a UserForm module to be renamed UsfLinkToFile:

Option Explicit

Private Type HyperlinkProps
    Address         As String   ' full path & filename
    TextToDisplay   As String   ' visible within cell
    ScreenTip       As String   ' visible on mouse hovering over
End Type

Private Type CurrentDialogState
    IsChanged               As Boolean
    IsUpdating              As Boolean
    IsOKReady               As Boolean
    IsCancelled             As Boolean
End Type

Private Type TLinkToFile
    FSO                     As Object
    HLProperties            As HyperlinkProps
    DialogState             As CurrentDialogState
    IsCurrentChoiceAFile    As Boolean
    IsCurrentChoiceAFolder  As Boolean
    CurrentFileName         As String
    CurrentFolder           As String
    PreviousFileName        As String
    TextToDisplay           As String
    TextToDisplayDropStyle  As fmDropButtonStyle
    ScreenTip               As String
    IsDispTxtShort          As Boolean
    TxtLong                 As String
    TxtShort                As String
End Type

Private this As TLinkToFile

Private Enum ResponsibleSource
    FilePicker = 1
    ManualInput = 2
End Enum


' ==============
' Public Members
' ==============

Public Function ShowDialog(Optional ByVal argFolder As String) As Boolean
    InitMe argFolder
    Me.Show vbModal
    ShowDialog = Not this.DialogState.IsCancelled
End Function

Public Sub ApplyToRange(ByVal argCell As Range)
    If Not argCell Is Nothing Then
        With this.HLProperties
            argCell.Parent.Hyperlinks.Add Anchor:=argCell.Cells(1, 1), _
                                          Address:=.Address, _
                                          TextToDisplay:=.TextToDisplay, _
                                          ScreenTip:=.ScreenTip
        End With
    Else
        VBA.Err.Raise VBA.vbObjectError + 91, "Class LinkToFile", "Class LinkToFile - ApplyToRange method:" & vbNewLine & _
                                                                  "Range Object variable not set, link could not be created."
    End If
End Sub

Public Property Get Address() As String
    Address = this.HLProperties.Address
End Property

Public Property Get TextToDisplay() As String
    TextToDisplay = this.HLProperties.TextToDisplay
End Property

Public Property Get ScreenTip() As String
    ScreenTip = this.HLProperties.ScreenTip
End Property


' =============
' Dialog Events
' =============

Private Sub CBtnCANCEL_Click()
    OnCancel
End Sub

Private Sub CBtnOK_Click()
    OnAccept
End Sub

Private Sub TbxFileName_Change()
    If Not this.DialogState.IsUpdating Then
        this.DialogState.IsOKReady = False
        this.IsCurrentChoiceAFile = False
        this.IsCurrentChoiceAFolder = False
        With Me.TbxFileName
            If this.FSO.FileExists(.Value) Then
                this.IsCurrentChoiceAFile = True
                this.DialogState.IsOKReady = True
            ElseIf this.FSO.FolderExists(.Value) Then
                this.IsCurrentChoiceAFolder = True
            End If
            this.DialogState.IsChanged = Not AreNamesEqual(.Value, this.PreviousFileName)
            OnFileNameChange .Value, ManualInput
        End With
    End If
End Sub

Private Sub TbxFileName_DropButtonClick()
    With this
        OnBrowse
        OnFileNameChange .CurrentFileName, FilePicker
    End With
End Sub

Private Sub TbxScreenTip_Change()
    this.ScreenTip = Me.TbxScreenTip.Value
End Sub

Private Sub TbxTextToDisplay_Change()
    this.TextToDisplay = Me.TbxTextToDisplay.Value

    ' manual change: don't allow just spaces and/or zero-length string
    Me.CBtnOK.Enabled = Not (VBA.Len(VBA.Trim(this.TextToDisplay)) = 0)
End Sub

Private Sub TbxTextToDisplay_DropButtonClick()
    this.IsDispTxtShort = Not this.IsDispTxtShort
    UpdateDialog
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = VBA.vbFormControlMenu Then
        Cancel = True
        OnCancel
    End If
End Sub


' ===========================
' Private Functions & Methods
' ===========================

Private Sub InitMe(ByVal argFolder As String)
    With Me
        .Caption = "Link to file"
        .TbxFileName.Value = ""
        .TbxFileName.ShowDropButtonWhen = fmShowDropButtonWhenAlways
        .TbxFileName.DropButtonStyle = fmDropButtonStyleEllipsis
        .TbxTextToDisplay.ShowDropButtonWhen = fmShowDropButtonWhenAlways
    End With
    With this
        If .FSO Is Nothing Then
            Set .FSO = VBA.CreateObject("Scripting.FileSystemObject")
        End If
        .DialogState.IsOKReady = False
        .CurrentFileName = ""
        .CurrentFolder = argFolder
        UpdateDialog
    End With
End Sub

Private Sub OnBrowse()
    With this
        If VBA.Len(.CurrentFileName) > 0 Then
            .PreviousFileName = .CurrentFileName
        End If
        If this.FSO.FolderExists(.CurrentFileName) Then
            .CurrentFolder = .CurrentFileName
        End If
        .CurrentFileName = BrowseForFileName(.CurrentFolder)
        If CancelledOnFilePicker(.CurrentFileName) Then
            .CurrentFileName = .PreviousFileName
        End If
        .DialogState.IsOKReady = True
        .DialogState.IsChanged = Not AreNamesEqual(.CurrentFileName, .PreviousFileName)
    End With
End Sub

Private Sub OnFileNameChange(ByVal argNewFileName As String, ByVal argSrc As ResponsibleSource)
    With this
        If .DialogState.IsChanged Then
            If argSrc = ManualInput Then
                .PreviousFileName = argNewFileName
                If .IsCurrentChoiceAFile Then
                    .CurrentFileName = .FSO.GetAbsolutePathName(argNewFileName)
                    .CurrentFolder = .FSO.GetParentFolderName(.CurrentFileName)
                ElseIf .IsCurrentChoiceAFolder Then
                    .CurrentFolder = .FSO.GetAbsolutePathName(argNewFileName)
                    .CurrentFileName = .CurrentFolder
                Else
                    .CurrentFileName = argNewFileName
                End If
                .TextToDisplay = .CurrentFileName

            ElseIf argSrc = FilePicker Then
                If Not CancelledOnFilePicker(.CurrentFileName) Then
                    .CurrentFolder = .FSO.GetParentFolderName(.CurrentFileName)
                End If
            Else
                ' shouldn't happen
            End If
            .TxtLong = .CurrentFileName
            .TxtShort = .FSO.GetFileName(.CurrentFileName)
            .ScreenTip = .TxtShort
            UpdateDialog
        End If
    End With
    Me.CBtnCANCEL.SetFocus
    Me.TbxFileName.SetFocus
End Sub

Private Sub OnCancel()
    With this
        .PreviousFileName = ""
        .HLProperties.Address = ""
        .HLProperties.ScreenTip = ""
        .HLProperties.TextToDisplay = ""
        .DialogState.IsCancelled = True
    End With
    Me.Hide
End Sub

Private Sub OnAccept()
    With this
        .PreviousFileName = ""
        .HLProperties.Address = .CurrentFileName
        .HLProperties.ScreenTip = .ScreenTip
        .HLProperties.TextToDisplay = .TextToDisplay
        .DialogState.IsCancelled = False
    End With
    Me.Hide
End Sub

Private Sub UpdateDialog()
    With this
    ' UpdateTextToDisplay
        If .IsDispTxtShort Then
            .TextToDisplay = .TxtShort
            .TextToDisplayDropStyle = fmDropButtonStylePlain
        Else
            .TextToDisplay = .TxtLong
            .TextToDisplayDropStyle = fmDropButtonStyleReduce
        End If
    
    ' UpdateTextBoxes
        .DialogState.IsUpdating = True
        Me.TbxFileName.Value = .CurrentFileName
        Me.TbxFileName.ControlTipText = .CurrentFileName
        Me.TbxTextToDisplay.Value = .TextToDisplay
        Me.TbxScreenTip.Value = .ScreenTip
        .DialogState.IsUpdating = False
    
    ' UpdateControls
        With .DialogState
            Me.TbxTextToDisplay.DropButtonStyle = this.TextToDisplayDropStyle
            Me.LbTextToDisplay.Enabled = .IsOKReady
            Me.TbxTextToDisplay.Enabled = .IsOKReady
            Me.LbScreenTip.Enabled = .IsOKReady
            Me.TbxScreenTip.Enabled = .IsOKReady
            Me.CBtnOK.Enabled = .IsOKReady
        End With
    End With
End Sub

Private Function AreNamesEqual(ByVal argFirst As String, ByVal argSecond As String) As Boolean
    AreNamesEqual = VBA.CBool(VBA.StrComp(argFirst, argSecond, vbTextCompare) = 0)
End Function

Private Function CancelledOnFilePicker(ByVal argFileName As String) As Boolean
    CancelledOnFilePicker = (VBA.Len(argFileName) = 0)
End Function

Private Function ProperFolderPath(ByVal argPath As String) As String
    Do While VBA.Right(argPath, 1) = "\"
        argPath = VBA.Left(argPath, VBA.Len(argPath) - 1)
    Loop
    ProperFolderPath = argPath & "\"
End Function

Private Function BrowseForFileName(Optional ByVal argFolderOrFile As String = "") As String
    With Excel.Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        If this.FSO.FolderExists(argFolderOrFile) Then
            .InitialFileName = ProperFolderPath(argFolderOrFile)
        ElseIf this.FSO.FileExists(argFolderOrFile) Then
            .InitialFileName = ProperFolderPath(this.FSO.GetParentFolderName(argFolderOrFile))
        Else
            .InitialFileName = ProperFolderPath(VBA.Environ("userprofile")) & "Documents\"
        End If
        If .Show Then
            BrowseForFileName = .SelectedItems(1)
        End If
    End With
End Function