макрос для создания гиперссылок на файлы

Автор xsenia, 25.02.2011, 15:04

« назад - далее »

xsenia

Добрый день!
Есть папка с графическими файлами (jpg, gif и png). Есть файл, в котором перечислены названия файлов без расширения. Нужно создать макрос, который бы проставлял а таблице гиперссылки на эти файлы. Excel 2007! Помогите, пожалуйста!

GWolf

Цитата: xsenia от 25.02.2011, 15:04
Добрый день!
Есть папка с графическими файлами (jpg, gif и png). Есть файл, в котором перечислены названия файлов без расширения. Нужно создать макрос, который бы проставлял а таблице гиперссылки на эти файлы. Excel 2007! Помогите, пожалуйста!

Доброго дня!
Макрорекордером получается, что то типа:

Sub Макрос1()
'
' Макрос1 Макрос
' Макрос записан 25.02.2011 (Gregory)
'

'
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
        "E:\00_Моя канцелярия\Wolf_01.BMP", TextToDisplay:="Wolf"
End Sub

теперь модифицируем сию запись под нашу задачу: (Предполагая что список файлов находится в диапазоне ячеек активного листа B3:B12, например)

Sub huPLink()
    '
    with thisworkbook.ActiveSheet
.Hyperlinks.Add Anchor:=Selection, Address:= _
        "E:\00_Моя канцелярия\Wolf_01.BMP", TextToDisplay:="Wolf"
End Sub
Путей к вершине - множество. Этот один из многих!

xsenia

Спасибо, но у меня что-то не получается. Объясните, пожалуйста, подробнее, как это должно работать.

GWolf

#3
Цитата: xsenia от 25.02.2011, 16:03
Спасибо, но у меня что-то не получается. Объясните, пожалуйста, подробнее, как это должно работать.


Sub huPLink()
   'за основу взят макрос fss(), разработанный в этой теме:
    'https://forum.msexcel.ru/proekty_vba/poisk_fayla_i_sozdanie_na_nego_giperssylki_s_makrosa-t3617.0.html

   Dim c As Range
   Dim rgn As Range
   
   With ActiveSheet
       Set rgn = .Range("b3").Offset(0, 1).CurrentRegion

       With Application.FileSearch
           For Each c In rgn.Cells
               .Filename = CStr(c.Value)
               .NewSearch
               
               'замените на ВАШ путь к папке с файлами
               .LookIn = "E:\00_Моя канцелярия\"
               
               .SearchSubFolders = False
               .MatchTextExactly = True
               .FileType = msoFileTypeAllFiles

               If .Execute() > 0 Then
                   For i = 1 To .FoundFiles.Count
                       nmFl = Right(.FoundFiles(i), Len(.FoundFiles(i)) - InStrRev(.FoundFiles(i), "\"))
                       stroka = Left(nmFl, InStrRev(nmFl, ".", -1, vbTextCompare) - 1)
                       
                       If ActiveSheet.Range(Cells(i + 2, 2), Cells(i + 2, 2)).Value = stroka Then
                           ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Range(Cells(i + 2, 3), Cells(i + 2, 3)), _
                                   Address:=.FoundFiles(i), TextToDisplay:=stroka
                               
                       End If
                       Application.AutoFormatAsYouTypeReplaceHyperlinks = True
                   Next i
                   
                   Exit For
               Else
                   MsgBox "Файлы не обнаружены."
               End If
           Next
       End With
   End With
End Sub
Путей к вершине - множество. Этот один из многих!

xsenia

Пишет Run-time error 445 Object doesn't support this action  :'(

GWolf

Цитата: xsenia от 25.02.2011, 17:39
Пишет Run-time error 445 Object doesn't support this action  :'(

Какую строку при этом подсвечивает?
Путей к вершине - множество. Этот один из многих!

xsenia

Никакую не посвечивает.
В той теме было написано, что это для 2003-го, а у меня 2007. Может, с этим связано.
И еще было бы классно объединить этот макрос с другим макросом (см. приложение), который я нашла здесь http://www.planetaexcel.ru/forum.php?thread_id=9966
и который использовала, чтобы эти картинки отобрать. Но там расширение файла нужно менять несколько раз, т.к. у меня разные файлы встречаются.

GWolf

Цитата: xsenia от 25.02.2011, 17:57
Никакую не посвечивает.
В той теме было написано, что это для 2003-го, а у меня 2007. Может, с этим связано.

ну само собой. Я не спец в 2007-ом, наверное через FSO надо делать.

ЦитироватьИ еще было бы классно объединить этот макрос с другим макросом (см. приложение), который я нашла здесь http://www.planetaexcel.ru/forum.php?thread_id=9966
и который использовала, чтобы эти картинки отобрать. Но там расширение файла нужно менять несколько раз, т.к. у меня разные файлы встречаются.

;) счастье штука призрачная. Ну я бы не стал менять в коде расширения, а написал их через запятую в ячейку листа и передал в код в виде одномерного массива, а затем в цикле For ... Next обработал элементы массива. Как то так.
Путей к вершине - множество. Этот один из многих!