Hyperlinks to network files keeps changing

[Rekd]

I've got a spreadsheet that I run from our intranet that has a macro that builds hyperlinks to files elsewhere on our intranet.

The link is built like this in the macro:

N:\pdfs\engineering\1234567101.PDF

Once it creates the link, it looks like this, which stillworks:

\\companydoc1\designs\pdfs\engineering\1234567101.PDF

But as soon as I save the spreadsheet it changes the link to this, which does not work:

../../designs/pdfs/engineering/1234567101.PDF

Is there a way to prevent Excel from changing the path when I save it? I can get it to work if I copy the spreadsheet to my local drive, but that kind of defeats the purpose and would create more work than it's worth.

 

[btadams]

Welcome to the board.

Can you post the code?

 

[Rekd]

I can post the code but that's not what's changing the path. It's excel. If I were to type the path manually it does the same thing.

The path created by the macro works good until I save the spreadsheet, then it changes from

\\companydoc1\designs

to

../../designs

which breaks the link.

 

[Rekd]

Here's the un-offending code:

Sub AddURL()
'-----------------------
' Add URLs to drawings in excel spreadsheets exported from Intranet
' Created by MF on Jan 25, 2010
' Some PDFs have spaces at the end which are not caught in Intranet,
'      those PDFs are not tested for in this version.
'-----------------------
Dim i As Long ' Start at row
Dim lastRow As Long ' How many rows
Dim cellPointer As Variant ' Part Number value
Dim curCell As Variant ' Processed cell value and comment
Dim sWS As String ' Worksheet name
Dim Msg, Style, Title, Response, oSFO, whatColumn, iC
Dim iRow As Integer
On Error Resume Next ' Skip errors
'Column number to use for part number
iRow = InputBox("What Column NUMBER Has The Part Number?", _
                "Linker: Select Column Number", 3)
If iRow = 0 Then Exit Sub
Select Case iRow
    Case 1
    whatColumn = "A"
    iC = "B"
    Case 2
    whatColumn = "B"
    iC = "C"
    Case 3
    whatColumn = "C"
    iC = "D"
    Case 4
    whatColumn = "D"
    iC = "E"
    Case 5
    whatColumn = "E"
    iC = "F"
    Case 6
    whatColumn = "F"
    iC = "G"
    Case 7
    whatColumn = "G"
    iC = "H"
    Case 8
    whatColumn = "H"
    iC = "I"
    Case 9
    whatColumn = "I"
    iC = "J"
    Case 10
    whatColumn = "J"
    iC = "K"
    Case 11
    whatColumn = "K"
    iC = "L"
    Case 12
    whatColumn = "L"
    iC = "M"
    Case 13
    whatColumn = "M"
    iC = "N"
End Select
lastRow = Range(whatColumn & Rows.Count).End(xlUp).Row ' Get number of rows in worksheet
If lastRow > 5000 Then ' If more than 5000 warn user and allow to bail.
    Msg = "There are " & lastRow & " items!" & vbCrLf & vbCrLf _
        & "Are you sure you want to continue?"
    Style = vbYesNo + vbCritical + vbDefaultButton2
    Title = "Caution: Long File Operation"
    Response = MsgBox(Msg, Style, Title)
    If Response = vbNo Then Exit Sub ' bail
End If
With frmMain 'Show what's going on (helps on long files)
    .Label2.Caption = "Checking for PDF Column..."
    .Show
    .Repaint
End With
'Check for and add column to put URL in
If Range(iC & "1").Value <> "PDF" Then
    frmMain.Label2.Caption = "Checking for PDF Column: Adding"
    frmMain.Repaint
    Columns(iC & ":" & iC).Select
    Selection.Insert Shift:=xlToRight
    Range(iC & "1").Select
    ActiveCell.FormulaR1C1 = "PDF"
    With ActiveCell.Characters(Start:=1, Length:=3).Font
        .Name = "Arial Unicode MS"
        .FontStyle = "Regular"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With
    Range(iC & "2").Select
    Columns(iC & ":" & iC).ColumnWidth = 5.14
    frmMain.Label2.Caption = "Done!"
    frmMain.Repaint
End If
sWS = ActiveSheet.Name ' Set worksheet name
Application.ScreenUpdating = False ' Make it process faster
Set oFSO = CreateObject("Scripting.FileSystemObject") ' Create FSO
For i = 2 To lastRow ' Start on Row 2' Iterate through rows
    Set cellPointer = Worksheets(sWS).Cells(i, iRow) ' Get value of cell
' If PDF exists, process cell into link and rename cell
If oFSO.FileExists("N:\pdfs\engineering\" & cellPointer & ".PDF") Then
    If cellPointer <> "" Then 'And cellPointer.Offset(0, 1).Value <> "" Then
        Worksheets(sWS).Cells(i, iRow + 1).Hyperlinks.add Anchor:=Worksheets(sWS).Cells(i, iRow + 1), _
            Address:="N:\pdfs\engineering\" & cellPointer & ".PDF", _
            TextToDisplay:="Yes"
    End If
 
' Can't find the PDF. Try adding " - Sheet1" to end of string
ElseIf oFSO.FileExists("N:\pdfs\engineering\" & _
        cellPointer & " - Sheet1" & ".PDF") Then
    If cellPointer <> "" Then 'And cellPointer.Offset(0, 1).Value <> "" Then
        Worksheets(sWS).Cells(i, iRow + 1).Hyperlinks.add Anchor:=Worksheets(sWS).Cells(i, iRow + 1), _
            Address:="N:\pdfs\engineering\" & cellPointer & " - Sheet1.PDF", _
            TextToDisplay:="Yes"
    End If
 
' Can't find the PDF. Try changing last digit to "X"
ElseIf oFSO.FileExists("N:\pdfs\engineering\" & _
        Left(cellPointer, Len(cellPointer) - 1) & "X" & ".PDF") Then
    If cellPointer <> "" Then 'And cellPointer.Offset(0, 1).Value <> "" Then
        Worksheets(sWS).Cells(i, iRow + 1).Hyperlinks.add Anchor:=Worksheets(sWS).Cells(i, iRow + 1), _
            Address:="N:\pdfs\engineering\" & (Left(cellPointer, (Len(cellPointer) - 1)) & "X") & ".PDF", _
            TextToDisplay:="Yes"
    End If
 
' Still Can't find PDF... try trimming down to 7 chars, needs work
Else
    cellPointer = Left(cellPointer, 7)
    If oFSO.FileExists("N:\pdfs\engineering\" & cellPointer & ".PDF") Then
    If cellPointer <> "" Then 'And cellPointer.Offset(0, 1).Value <> "" Then
        Worksheets(sWS).Cells(i, iRow + 1).Hyperlinks.add Anchor:=Worksheets(sWS).Cells(i, iRow + 1), _
            Address:="N:\pdfs\engineering\" & cellPointer & ".PDF", _
            TextToDisplay:="Yes"
    End If
    End If
' If still can't find it, bail. (To Do: Test for spaces in PDF names)
End If
'Show what's going on
With frmMain
sSuccess = FormatPercent(i / lastRow, 1)
    .Label2.Caption = "Working on row " & i & " of " & lastRow & "  (" & sSuccess & ")"
    .Repaint
End With
Next i ' Next row
Application.ScreenUpdating = True
frmMain.Hide
End Sub

 

[Rekd]

I can't find anything in help, but will locking the cells then protecting the sheet for those cells prevent excel from changing the path?