AW: Excel Hyperlinks auf Word-Bookmarks
22.04.2008 17:45:02
fcs
Hallo Werner,
man kann in Excel Hyperlinks auf Textmarken in Worddokumenten anlegen.
Das folgende Excel-Makro (erstellt mit Office 2003) erstellt eine Exceldatei mit den Hyperlinks auf alle Textmarken im Worddokument. Wahlweise kann man auch eine schon vorhandene Liste aktualisieren.
Mit etwas Arbeiten an der Objekt-Welt sollte es auch funktionieren, ohne dass Word vor dem Starten des Makros geöffnet sein muss.
Gruß
Franz
Sub HyperlinksTextmarken_nach_Excel()
'Liest die Textmarken eines Worddokuments in Excel ein und erstellt Hyperlinks
' Für Funktion des Makros muss im Excel VBA-Editor unter Extras-Verweise _
die Microsoft Word Object Library aktiviert werden
'Word muss vor dem Starten des Makros geöffnet sein!
Dim varDateiname As Variant
Dim objDok As Word.Document
Dim objWB As Excel.Workbook, objWks As Excel.Worksheet
On Error GoTo Fehlerbehandlung
'Worddateiname wählen
varDateiname = Excel.Application.GetOpenFilename(Filefilter:="Wordfile,*.doc", _
Title:="Bitte Worddatei wählen, aus der die Textmarken ausgelesen werden sollen")
If varDateiname = False Then Exit Sub
'Worddatei öffnen
Set objDok = Word.Documents.Open(Filename:=Abfrage, ReadOnly:=True)
'Prüfen ob Textmarken vorhanden
If objDok.Bookmarks.Count > 0 Then
If MsgBox("Vorhandene Exceldatei mit Hyperlinks aktualiseren?", vbYesNo, _
"Textmarken aus Dokument nach Excel") = vbYes Then
'Vorhandene Exceldatei aktualiseren
'Exceldatei wählen
varDateiname = Application.GetOpenFilename(Filefilter:="Exceldateien,*.xls", _
Title:="Bitte Datei wählen, in der die Hyperlinks eingetragen werden sollen")
If varDateiname = False Then
'do nothing
Else
Set objWB = Application.Workbooks.Open(Filename:=Abfrage)
Set objWks = objWB.Worksheets(1)
Call ReadBookmarks(objWS:=objWks, objDokument:=objDok)
Application.Windows(objWB.Name).Activate
objWB.Save
End If
Else
'Neue Excel-Datei für Textmarken-Hyperlinks anlegen
Set objWB = Workbooks.Add(Template:=xlWBATWorksheet)
Set objWks = objWB.Worksheets(1)
Call ReadBookmarks(objWS:=objWks, objDokument:=objDok)
'Aktuelles Fenster in Excel fixieren
Range("A5").Select
ActiveWindow.FreezePanes = True
'Speichern unter Dialog anzeigen
Application.Dialogs(xlDialogSaveAs).Show Arg1:=objDok.Path & _
Application.PathSeparator & Left(objDok.Name, Len(objDok.Name) - 4) _
& "_Textmarken.xls"
End If
Else
MsgBox "Im Word-Dokument sind keine Textmarken!"
End If
objDok.Close 'Word-Datei wieder schliessen
Exit Sub
Fehlerbehandlung:
Select Case Err.Number
Case 429
MsgBox "Fehler Nr. " & Err.Number & " ist aufgetretten" & vbLf & Err.Description _
& vbLf & vbLf & "Bitte Microsoft Word vor dem Starten des Makros öffnen!"
Case Else
MsgBox "Fehler Nr. " & Err.Number & " ist aufgetretten" & vbLf & Err.Description
End Select
End Sub
Sub ReadBookmarks(objWS As Worksheet, objDokument As Word.Document)
'Textmarken aus Dokument auslesen und als Hyperlink in Excelblatt einfügen
Dim lngZeile As Long, objBookmark As Word.Bookmark
With objWS
'Titelzeilen ausfüllen
.Range(.Columns(1), .Columns(2)).Clear
lngZeile = 1
.Cells(lngZeile, 1) = "Worddokument"
lngZeile = 2
.Cells(lngZeile, 1) = "Verzeichnis"
.Cells(lngZeile, 2) = objDokument.Path
lngZeile = 3
.Cells(lngZeile, 1) = "Name"
.Cells(lngZeile, 2) = objDokument.Name
lngZeile = 4
.Cells(lngZeile, 1) = "Textmarke"
.Cells(lngZeile, 2) = "TextmarkenInhalt"
'Hyperlinks für textmarken anlegen
For Each objBookmark In objDokument.Bookmarks
lngZeile = lngZeile + 1
.Cells(lngZeile, 1).Value = objBookmark.Name 'Name der Textmarke
.Cells(lngZeile, 2).Value = objBookmark.Range.Text 'Inhalt der Textmarke
.Cells.Hyperlinks.Add Anchor:=.Cells(lngZeile, 1), _
Address:=objDokument.FullName, _
SubAddress:=objBookmark.Name
Next
End With
End Sub