THE CODE RUNS ON MY C"/DRIVE, BUT FAILS WHEN I RUN IT ON THE SERVER,
WHICH IS MAPPED ON S:/DRIVE. I'VE SET THE PATH DRIVE TO S:/
REGENERATELINKS(code below)CHANGES THE HYPERLINK ADDRESS AND SHOULD BE
ABLE TO MOVE FOLDERS DEPENDENT ON THE COMBO BOX IN COLUMN P IN EXCEL
WORKSHEET. THE HYPERLINK ADDRESS IS WORKING PROPERLY, BUT STILL HAVING
PROBLEMS RUNNING THE CODE ON THE SERVER. THANKS FOR HELPING. MYRNA
RODRIGUEZ
"THIS IS THE CODE TO MOVE THE FOLDERS"
Sub RegenerateLinks()
'Declarations
Dim Nextrow As Long
Dim myRange As Range
Dim x As String
Dim cell As Range
Dim fastNumValue As String
Dim fileLocation As String
Dim link As String
Dim rowCount As Integer
Dim h As Hyperlink
Dim newAddress As String
Dim debugThis As Boolean
Dim newfolder As String
debugThis = False
rowCount = 0
Set myRange = Range("A3").CurrentRegion
For Each rw In Worksheets(1).Cells(1, 1).CurrentRegion.Rows
rowCount = rowCount + 1
fastNumValue = rw.Cells(1, 1).Value
If debugThis Then MsgBox "fastNumValue : " & fastNumValue
fileLocation = rw.Cells(1, 16).Value
If debugThis Then MsgBox "fileLocation : " & fileLocation
For Each h In rw.Hyperlinks
'MsgBox ActiveWorkbook.FullName
link = h.Name
If debugThis Then MsgBox "link h.name : " & link
If InStr(fileLocation, "Open") <> 0 Then
If InStr(h.Name, "Open") <> 0 Then
If debugThis Then MsgBox "is ok"
ElseIf InStr(h.Name, "Post-Close") <> 0 Then
If debugThis Then MsgBox "not ok"
newAddress = Replace(h.Address, "Post-Close", "Open")
If debugThis Then MsgBox "newAddress : " & newAddress
'moving the files now
oldFullAddress = HyperLinkTextH(h)
If debugThis Then MsgBox "oldFullAddress : " &
oldFullAddress
newFullAddress = Replace(oldFullAddress, "Post-Close",
"Open")
If debugThis Then MsgBox "newFullAddress : " &
newFullAddress
Set fso = CreateObject("Scripting.FileSystemObject")
'check if file exists first
If fso.folderexists(oldFullAddress) Then
Set mainfolder = fso.GetFolder(oldFullAddress)
mainfolder.Move newFullAddress
End If
h.Address = newAddress
If debugThis Then MsgBox "newAddress added : " &
h.Address
Function HyperLinkTextH(h As Hyperlink) As String
Dim ST1 As String
Dim ST2 As String
Dim LPath As String
Dim ST1Local As String
'If pRange.Hyperlinks.Count = 0 Then
' Exit Function
'End If
If debugThis Then MsgBox "HyperLinkTextH : " & h.Name
LPath = ThisWorkbook.FullName
ST1 = h.Address
ST2 = h.SubAddress
If Mid(ST1, 1, 15) = "..\..\..\..\..\" Then
ST1Local = ReturnPath(LPath, 5) & Mid(ST1, 15)
ElseIf Mid(ST1, 1, 12) = "..\..\..\..\" Then
ST1Local = ReturnPath(LPath, 4) & Mid(ST1, 12)
ElseIf Mid(ST1, 1, 9) = "..\..\..\" Then
ST1Local = ReturnPath(LPath, 3) & Mid(ST1, 9)
ElseIf Mid(ST1, 1, 6) = "..\..\" Then
ST1Local = ReturnPath(LPath, 2) & Mid(ST1, 6)
ElseIf Mid(ST1, 1, 3) = "..\" Then
ST1Local = ReturnPath(LPath, 1) & Mid(ST1, 3)
ElseIf Mid(ST1, 1, 15) = "../../../../../" Then
ST1Local = ReturnPath(LPath, 5) & Mid(ST1, 15)
ElseIf Mid(ST1, 1, 12) = "../../../../" Then
ST1Local = ReturnPath(LPath, 4) & Mid(ST1, 12)
ElseIf Mid(ST1, 1, 9) = "../../../" Then
ST1Local = ReturnPath(LPath, 3) & Mid(ST1, 9)
ElseIf Mid(ST1, 1, 6) = "../../" Then
ST1Local = ReturnPath(LPath, 2) & Mid(ST1, 6)
ElseIf Mid(ST1, 1, 3) = "../" Then
ST1Local = ReturnPath(LPath, 1) & Mid(ST1, 3)
Else
ST1Local = ST1
End If
If ST2 <> "" Then
ST1Local = "[" & ST1Local & "]" & ST2
End If
If debugThis Then MsgBox "ST1Local : " & ST1Local
HyperLinkTextH = ST1Local
End Function
Function ReturnPath(pAppPath As String, pCount As Integer) As String
Dim LPos As Integer
Dim LTotal As Integer
Dim LLength As Integer
LTotal = 0
LLength = Len(pAppPath)
Do Until LTotal = pCount + 1
If Mid(pAppPath, LLength, 1) = "\" Then
LTotal = LTotal + 1
End If
LLength = LLength - 1
Loop
ReturnPath = Mid(pAppPath, 1, LLength)
End Function
