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