I am trying to reset the hyperlink base in an Excel document to a network
drive. It keeps defaulting to My Network Places. I've followed the steps to
set the base address for the hypelinks in a workbook - but it won't reset.
Any thoughts?

Paste this macro to a new module.
The macro is called 'HyperlinkChangeLinkPath'

'/===========================================/
'32-bit API declarations
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long

'/===========================================/
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
'/===========================================/

Sub HyperlinkChangeLinkPath()
' Change path of all hyperlinks in range to a single new path
' If there is no 'address', then the path does not get changed
'
' Gary L. Brown
' Kinneson Consulting
' 12/18/2001
'
Dim h As Hyperlink
Dim i As Integer, iCount As Integer
Dim x As Integer, y As Integer
Dim rngInput As Range
Dim strInputBox As String, strMsg As String
Dim strAnchor As String, strOriginalAddress As String
Dim strSubAddress As String, strAddress As String
Dim strName As String, strParent As String
Dim strTextToDisplay As String
Dim varAnswer As Variant

On Error Resume Next

'test if back up was performed prior to running this macro
varAnswer = _
MsgBox( _
"If you have NOT Backed up this workbook prior to this processing" _
& vbCr & " select CANCEL and perform backup, otherwise" & _
vbCr & " select OK to continue.", _
vbExclamation + vbOKCancel + vbDefaultButton1, _
"Warning Prior to Processing... www.kinneson.com")

If varAnswer < vbOK Then
MsgBox "The user has canceled this process..." & vbCr & _
"Process halted.", vbCritical + vbOKOnly, "Warning..."
GoTo exit_Sub
End If

'store current selection in a variable
strOriginalAddress = Selection.Address

'get range containing hyperlinks to be changed
Set rngInput = _
Application.InputBox(prompt:= _
"Select Range of Hyperlink cells to be changed", _
Title:="Select Range of hyperlinks.... www.kinneson.com", _
Default:=strOriginalAddress, Type:=8)

' Count the # of hyperlinks in the selected range
i = rngInput.Hyperlinks.Count

If i = 0 Then
MsgBox "No cells with hyperlinks have been selected.", _
vbExclamation + vbOKOnly, _
"Warning... Processed halted... www.kinneson.com"
GoTo exit_Sub
End If

'give choices of how to enter new hyperlink path
varAnswer = _
MsgBox("Yes - 'Browse/Point-and-Click' at a Drive/Folder" & _
vbCr & "No - 'Type in' new Hyperlink path" & _
vbCr & "Cancel - Halt this process", _
vbInformation + vbYesNoCancel + vbDefaultButton1, _
"Select an Action [Yes/No/Cancel]... www.kinneson.com")

Select Case varAnswer
Case vbYes
strMsg = _
" Select location of Hyperlink path or press Cancel."
strInputBox = GetDirectory(strMsg)
If strInputBox = "" Then
MsgBox "A folder has not been selected..." & vbCr & _
"Process halted.", vbCritical + vbOKOnly, "Warning..."
GoTo exit_Sub
End If
If Right(strInputBox, 1) < "\" Then strInputBox = strInputBox & "\"

Case vbNo
strInputBox = _
InputBox(" Enter location of Hyperlink path or press Cancel." & _
vbCrLf & vbCrLf & "NOTES:" & vbCrLf & _
" If you are entering a URL, you MUST end" & _
vbCrLf & " the entry with a back-slash (/) or the hyperlink" & _
vbCrLf & " will not work correctly..." & vbCrLf & vbCrLf & _
" If you are entering a file path, you MUST end" & _
vbCrLf & " the entry with a forward-slash (\) or the hyperlink" & _
vbCrLf & " will not work correctly...", _
"Enter a valid path...")
If strInputBox = "" Then
MsgBox "A folder has not been entered..." & vbCr & _
"Process halted.", vbCritical + vbOKOnly, "Warning..."
GoTo exit_Sub
End If

Case vbCancel
MsgBox "The user has canceled this process..." & vbCr & _
"Process halted.", vbCritical + vbOKOnly, "Warning..."
GoTo exit_Sub

Case Else
MsgBox "Unexpected Error..." & vbCr & _
"Process halted.", vbCritical + vbOKOnly, "Warning..."
GoTo exit_Sub
End Select

' go through each hyperlink in the range and change path
For Each h In rngInput.Hyperlinks
' put the hyperlink's info into variables
' get range
strAnchor = h.Range.Address

'get address
strAddress = h.Address
If Len(h.Address) = 0 Then
strAddress = ""
Else
If Right(Trim(h.Address), 1) = "/" Then
strAddress = strInputBox
Else
If FindSlash(h.Address) < 0 Then
strAddress = strInputBox & _
Right(h.Address, Len(h.Address) - FindSlash(h.Address))
End If
End If
End If

'get sub-address
strSubAddress = h.SubAddress

'get name & parent & text-to-display
If Len(strAddress) < 0 Then
If Len(strSubAddress) < 0 Then
strName = strAddress & " - " & strSubAddress
strParent = strName
strTextToDisplay = strName
Else
strName = strAddress
strParent = strAddress
strTextToDisplay = strAddress
End If
Else
If Len(strSubAddress) < 0 Then
strName = strSubAddress
strParent = _
Right(h.SubAddress, _
Len(h.SubAddress) - InStr(1, h.SubAddress, "!"))
strTextToDisplay = strParent
Else
strName = h.name
strParent = h.Parent
strTextToDisplay = h.TextToDisplay
End If
End If

' change the hyperlink's info
With h
.Range = strAnchor
.Address = strAddress
.SubAddress = strSubAddress
.Parent = strParent
.TextToDisplay = strTextToDisplay
End With
Next h

exit_Sub:
Set rngInput = Nothing

End Sub
'/===========================================/

Private Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, Pos As Integer

' Root folder = Desktop
bInfo.pidlRoot = 0&

' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If

' Type of directory to return
bInfo.ulFlags = &H1

' Display the dialog
x = SHBrowseForFolder(bInfo)

' Parse the result
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
Pos = InStr(Path, Chr$(0))
GetDirectory = Left(Path, Pos - 1)
Else
GetDirectory = ""
End If
End Function
'/===========================================/
Private Function FindSlash(strFullPath As String) As Integer
Dim ix As Integer, iy As Integer

FindSlash = 0

For ix = Len(strFullPath) To 1 Step -1
If Mid(strFullPath, ix, 1) = "\" Or _
Mid(strFullPath, ix, 1) = "/" Then
FindSlash = ix
Exit For
End If
Next ix

End Function
'/===========================================/


HTH,
--
Gary Brown

If this post was helpful, please click the ''''Yes'''' button next to
''''Was this Post Helpfull to you?".


"Diane" wrote:

I am trying to reset the hyperlink base in an Excel document to a network
drive. It keeps defaulting to My Network Places. I've followed the steps to
set the base address for the hypelinks in a workbook - but it won't reset.
Any thoughts?