Private Sub FixSingleCellHyperlink()
Application.ScreenUpdating = False ' Turn off Screen updating
Dim Fname As String
Dim bNoRights As Boolean
Sheets("Artifacts").Select ' Select Artifact Worksheet
Cells(Application.ActiveCell.Row, 1).Select 'Go to 1st cell of current row
ActiveCell.Offset(0, 9).Select ' Select the Artifact Column
Set rngArea = Range("Direct_Artifact_Link_Group") 'Set the Defined range
Fname = Selection.Value ' Select active cell
If Fname = "" Then ' Check if cell is empty, if so, warn user.
MsgBox "Sorry, There is no data in the cell.", vbOKOnly
Exit Sub
End If
ActiveCell.Value = ConvertDrive2ServerName(Fname) ' Convert Path to UNC, if mapped, and copy selected path to the Active cell.
Fname = Selection.Value ' Get the Active Cell Text
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Fname, TextToDisplay:=Fname ' Create Hyperlink from active cell text
'***********************************************************************
' Hyperlink Validation - Check single
'***********************************************************************
ExistPath = False
If Left(Fname, 7) = "http://" Or Left(Fname, 8) = "https://" Or Left(Fname, 6) = "ftp://" Or Left(Fname, 7) = "ftps://" Then
ExistPath = InternetCheckConnection(Fname, 1, 0) '1=FLAG_ICC_FORCE_CONNECTION
Else
'Fname = " "" " + Fname + " "" "
On Error Resume Next
Err.Clear
If Len(Dir(Fname)) > 0 Then ' verify path
If Err.Number = 52 Then
'Error thrown due to lack of directory access
bNoRights = True
Else
ExistPath = True
End If
Else
If Len(Dir(Fname, vbDirectory)) > 0 Then ' verify the file
If Err.Number = 52 Then
'Error thrown due to lack of directory access
bNoRights = True
Else
ExistPath = True
End If
End If
End If
If ExistPath Then
ActiveCell.Font.Color = RGB(0, 0, 255) ' Turn font blue if valid
'Debug.Print "Valid"
Else
If bNoRights Then
ActiveCell.Font.Color = RGB(0, 255, 0)
Else
ActiveCell.Font.Color = RGB(255, 0, 0) ' Turn font red if not valid
'Debug.Print "Not Valid"
End If
'test = ConvertDrive2ServerName(Fname)
End If
Set rngArea = Nothing ' clear range value
Application.ScreenUpdating = True ' Turn on Screen updating
Err_Trap:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub