Option Explicit Public Sub total_replace() 'Optional ByVal alternate_path As String) On Error GoTo ERROR_HANDLER Const ALTERNATE_PATH As String = "d:\Мои документы\!ПРОЕКТЫ\" Dim cur_ws As Worksheet: Set cur_ws = ActiveSheet Dim cur_cell As Range: For Each cur_cell In cur_ws.UsedRange ' TODO: cache filelist of ALTERNATE_PATH into something (collection/dictionary) ' find hyperlink Dim has_hyperlink As Boolean: has_hyperlink = False Dim hyperlink As String: hyperlink = "" hyperlink = get_hyperlink(cur_cell) has_hyperlink = Len(hyperlink) > 0 ' find alternate link Dim has_alt_link As Boolean: has_alt_link = False Dim alt_link As String: alt_link = "" If has_hyperlink Then alt_link = get_alt_link(ALTERNATE_PATH, hyperlink) has_alt_link = Len(alt_link) > 0 If has_alt_link Then alt_link = Replace(alt_link, ALTERNATE_PATH, "") ' removes origin folder from path (for what ???) End If ' change link ' highlight cell ' white -- hyperlink not found ' red -- hyperlink found / alternate link not found ' green -- hyperlink found / link changed If has_alt_link Then cur_cell.Hyperlinks(1).Address = alt_link cur_cell.Interior.ColorIndex = 4 ' green ElseIf has_hyperlink Then cur_cell.Interior.ColorIndex = 3 ' red Else cur_cell.Interior.ColorIndex = xlNone ' white End If Next cur_cell MsgBox "!" Exit Sub ERROR_HANDLER: End Sub Private Function get_hyperlink(ByRef cur_cell As Range) As String On Error GoTo ERROR_HANDLER get_hyperlink = cur_cell.Hyperlinks(1).Address Exit Function ERROR_HANDLER: get_hyperlink = "" End Function Private Function get_alt_link(ByVal path As String, ByVal old_link As String) As String On Error GoTo ERROR_HANDLER Dim ret_link As String: ret_link = "" Dim fso As FileSystemObject: Set fso = New FileSystemObject Dim searched_obj As String: searched_obj = fso.GetFileName(old_link) ret_link = get_alt_link_folder(path, old_link) If Len(ret_link) = 0 Then ret_link = get_alt_link_file(path, old_link) get_alt_link = ret_link Exit Function ERROR_HANDLER: get_alt_link = "" End Function Private Function get_alt_link_file(ByVal path As String, ByVal old_link As String) As String On Error GoTo ERROR_HANDLER Dim ret_link As String: ret_link = "" Dim fso As FileSystemObject: Set fso = New FileSystemObject Dim searched_file As String: searched_file = LCase(fso.GetFileName(old_link)) Dim cur_dir As Folder: Set cur_dir = fso.GetFolder(path) Dim cur_file As File: For Each cur_file In cur_dir.Files If LCase(cur_file.Name) = searched_file Then ret_link = cur_file.path If Len(ret_link) > 0 Then Exit For Next cur_file ' nothing found in current folder, sifting through subfolders If Len(ret_link) = 0 Then Dim cur_subdir As Folder: For Each cur_subdir In cur_dir.SubFolders ret_link = get_alt_link_file(cur_subdir.path, old_link) If Len(ret_link) > 0 Then Exit For Next cur_subdir End If get_alt_link_file = ret_link Exit Function ERROR_HANDLER: get_alt_link_file = "" End Function Private Function get_alt_link_folder(ByVal path As String, ByVal old_link As String) As String On Error GoTo ERROR_HANDLER Dim ret_link As String: ret_link = "" Dim fso As FileSystemObject: Set fso = New FileSystemObject Dim searched_folder As String: searched_folder = LCase(fso.GetFileName(old_link)) Dim cur_dir As Folder: Set cur_dir = fso.GetFolder(path) Dim cur_subdir As Folder: For Each cur_subdir In cur_dir.SubFolders If LCase(cur_subdir.Name) = searched_folder Then ret_link = cur_subdir.path If Len(ret_link) > 0 Then Exit For Next cur_subdir ' nothing found in current folder, sifting through subfolders If Len(ret_link) = 0 Then For Each cur_subdir In cur_dir.SubFolders ret_link = get_alt_link_folder(cur_subdir.path, old_link) If Len(ret_link) > 0 Then Exit For Next cur_subdir End If get_alt_link_folder = ret_link Exit Function ERROR_HANDLER: get_alt_link_folder = "" End Function |