Перейти из форума на сайт.

НовостиФайловые архивы
ПоискАктивные темыТоп лист
ПравилаКто в on-line?
Вход Забыли пароль? Первый раз на этом сайте? Регистрация
Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Задачи на Visual Basic (VB).

Модерирует : ShIvADeSt

 Версия для печати • ПодписатьсяДобавить в закладки
На первую страницук этому сообщениюк последнему сообщению

Открыть новую тему     Написать ответ в эту тему

Legio



Advanced Member
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
такое:

Код:
 
 
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
 
 

Всего записей: 695 | Зарегистр. 01-08-2003 | Отправлено: 09:38 04-08-2013
Открыть новую тему     Написать ответ в эту тему

На первую страницук этому сообщениюк последнему сообщению

Компьютерный форум Ru.Board » Компьютеры » Прикладное программирование » Задачи на Visual Basic (VB).


Реклама на форуме Ru.Board.

Powered by Ikonboard "v2.1.7b" © 2000 Ikonboard.com
Modified by Ru.B0ard
© Ru.B0ard 2000-2024

BitCoin: 1NGG1chHtUvrtEqjeerQCKDMUi6S6CG4iC

Рейтинг.ru