Hyperlink Automatisieren
03.09.2006 18:46:37
Heinz
Habe die Frage schon vor einigen Tagen gestellt,hatte aber leider keine Lösung gefunden.
Vielleicht könnte mir heute jemand weiterhelfen ?
Habe Dankenderweise in diesen Forum einen Code für meine MP3 Sammlung erhalten.
Nur muss ich mit Command Button2 auf jede Datei klicken,so das es,wenn vorhanden einen Hyperlink einfügt.
Würde es nicht gehen.
Wenn ich auf Command Button2 klicke das Automatisch alle Dateien durchsucht werden und wenn verfügbar,gleich einen Hyperlink einfügt.
Also bei Click die ganze Liste E2:E30000 dann in Spalte C als Hyperlink einfügt.
Unten ist der Code den ich erhalten habe.
Danke & Gruss, Heinz
Modul 1
Sub SetHyperLink()
Dim rngC As Range, strPfad As String
Set rngC = Cells(ActiveCell.Row, 3)
strPfad = "H:\Musik\Musik\" ' ggf. Durch eigene Angabe oder Zelleninhalt ersetzen
ActiveSheet.Hyperlinks.Add _
Anchor:=rngC, _
Address:=strPfad & rngC.Offset(0, 2).Value, _
TextToDisplay:=rngC.Value
End Sub
Code im Tab.Blatt Tabelle 1
'Suche Datei im Ausgangs- und zugehörige Unterverzeichnisse:
Private Sub CommandButton2_Click()
Dim rngC As Range, strPfad As String, strFName As String, anzF As Integer, msg As String
Set rngC = Cells(ActiveCell.Row, 3)
strPfad = "H:\Musik\Musik\"
strFName = rngC.Offset(0, 2).Value
With Application.FileSearch
.LookIn = strPfad ' setze Ausgangspfad
.SearchSubFolders = True ' bindet Unterverzeichnisse in den Suchvorgang
.Filename = strFName 'setzt den Suchnamen
anzF = .Execute 'führt FileSearch aus und liefert Anzahl der Funde,
' in anzf gespeichert
If Not anzF = 1 Then 'mehr als ein Fund oder aber kein Fund
msg = "Datei " & strFName & " existiert " & IIf(anzF > 1, "mehrmals", "nicht") & "!"
MsgBox msg
Else
strFName = .FoundFiles(1) 'vollständiger Pfad-Dateiname
ActiveSheet.Hyperlinks.Add _
Anchor:=rngC, _
Address:=strFName, _
TextToDisplay:=rngC.Value
End If
Set rngC = Nothing
End With
End Sub