Подсветка работающих гиперссылок

[stream71]

Уважаемые специалисты, подскажите,

мне необходимо на листе Excel 2003 проверить все гиперссылки на прикрепленные файлы и подсветить красным фоном те из них, которые не открываются по причине отсутствия файла или неправильно указанного пути к файлу.
Заранее премного благодарен.
Устроит решение как VBA так и через условное форматирование.

[The_Prist]

Сообщение от stream71

проверить все гиперссылки на прикрепленные файлы и подсветить красным фоном те из них, которые не открываются по причине отсутствия файла или неправильно указанного пути к файлу.

Проверить можно, но надо знать каким образом у Вас записана гиперссылка. У Вас адрес гиперссылки совпадает со значением гиперссылки в ячейке? Набросайте пару строк в примере Excel.

[stream71]

Гиперлинк к файлам D у меня рассчитывается исходя из значений 2х ячеек A,B.

[The_Prist]

Смотрите.Так?

[stream71]

Не совсем :-( Макрос подсветил все непустые ячейки.
Файл, к которым указывает гиперссылка находится в папке August_09.
Гиперссылки проверять нужно в столбцах 7 и 15.

[The_Prist]

Сообщение от stream71

Гиперссылки проверять нужно в столбцах 7 и 15.

Я ориентировался на выложенный Вами пример. Сравните выложенный Вами сначала файл и последний. Кажись они немного разные. Вторая попытка.

[stream71]

На мой взгляд, макрос не работает как бы мне хотелось.

Option Explicit
Sub Check_HiperLincks()
Dim rCell As Range

For Each rCell In Union(Range(Cells(1, 7), Cells(Cells(Rows.Count, 7).End(xlUp).Row, 7)), Range(Cells(1, 15), Cells(Cells(Rows.Count, 15).End(xlUp).Row, 15)))
If IsError(rCell) Then
rCell.Interior.Color = vbRed
ElseIf rCell <> "" Then
If Dir(rCell) = "" Then rCell.Interior.Color = vbRed
End If
Next rCell
End Sub

По-прежнему, подсвечиваются красным фоном все ячейки, независимо от того, открывается ли по указанной гиперссылке файл или нет.

Внутри моей формулы по расчету гиперссылки не может быть ошибки, так как там простое "склеивание" текстовой информации. С функцией ISERROR я пробовал решить задачу условным форматированием, но безуспешно.
Нужна какая-то функция, которая бы проверяла на ошибку "Cannot open the specified file" (см приложенный снимок) при попытке открытия файла по гиперссылке.
Очень на Вас надеюсь!

[stream71]

Нашел в поиске аналогичный запрос : http://forum.developing.ru/archive/i...hp/t-4705.html

Но не могу разобраться как решить мой вариант.

Помогите довести первоначальную задачу до решению.
Спасибо заранее за помощь.

[AChrist]

Добры.
У меня такая же задача появилась, что надо проверить на работоспособность гиперссылок.

Во общем написал следующее:

Public Function FileFolderExists(strFullPath As String) As Boolean

    If Dir(strFullPath) <> vbNullString Then FileFolderExists = True Else FileFolderExists = False
    
End Function

Public Sub TestFileExistence()
rr = 15 '  ставим в какой столбец записывать результат
For Each cell In Range([A1], Range("A" & Rows.Count).End(xlUp)).Cells

    If FileFolderExists(cell.Hyperlinks(1).Address) Then
       cell(1, rr) = 1 ' true
    Else
        cell(1, rr) = 0 ' false
    End If
Next cell

End Sub

Однако не работает как надо. Возвращает false даже на правильный линк.

If FileFolderExists(cell.Hyperlinks(1).SubAddress) Then

А в этом случае на все true. Так как путь есть какой то, а вот файл на наличие не проверяет...

Может я не в ту сторону пошел ? Помогите пожалуйста разобраться.

ЗЫ: Гиперсссылки на файлы все на компе и путь с название ссылки не совпадает.
И заметил, что если путь будет на D:\ где и файл то проверяет с Hyperlinks(1).SubAddress, а вот если будет на C:\ то работает с просто Hyperlinks(1).Address

Вообщем я окончательно запутался и не могу понять, что к чему...

[EducatedFool]

Вообщем я окончательно запутался и не могу понять, что к чему...

Ну так выложите файл с гиперссылками, поглядим.

If FileFolderExists(cell.Hyperlinks(1) .SubAddress) Then

А в этом случае на все true.

Это происходит потому, что SubAddress="", а функция Dir("") возвращает непустое значение.


(добавлено)
Проблема в том, что после сохранения файла абсолютные гиперссылки
(вида C:\Documents and Settings\August_09\images.jpg )
автоматически преобразуются в относительные
(вида August_09/images.jpg)

Я в подобных случаях использую такой код:

thisworkbookpath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "")

HL_photo = cell.Hyperlinks(1).Address
If Dir(HL_photo) = "" Then HL_photo = thisworkbookpath & Replace(HL_photo, "/", "\")
If Dir(HL_photo) = "" Then MsgBox "Файл отсутствует"

В Вашем случае код быдет выглядеть так:

Public Function FileFolderExists(ByRef cell As Range) As Boolean
    On Error Resume Next
    thisworkbookpath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, "")

    HL = cell.Hyperlinks(1).Address
    If Dir(HL) = "" And HL <> "" Then HL = thisworkbookpath & Replace(HL, "/", "\")
    FileFolderExists = Dir(HL) = ""
End Function

Public Sub TestFileExistence()
    rr = 15    '  ставим в какой столбец записывать результат
    For Each cell In Range([A1], Range("A" & Rows.Count).End(xlUp)).Cells
        cell(1, rr) = Val(FileFolderExists(cell))
    Next cell
End Sub