Frage: Aus vielen Worddokumenten eines Verzeichnisses sollen alle Hyperlinks nach Excel kopiert werden. Ausgabe soll sein: Spalte A Dateiname (Pfad in Kommentar), Spalte B Hyperlink wie in Word dargestellt (muss anklickbar sein), Spalte C die Hyperlinkadresse und Spalte D den angezeigten Text. Wie geht das?
From many Word documents in a directory all hyperlinks should be copied to Excel. Output should be: Column A file name (path in comment) Column B Hyperlink (must be clickable) as shown in Word, the hyperlink address in column C and column D the displayed text. How does it work?
Hier noch eine Beispieldatei / Here's a sample file:
Word - Dokumente mit Hyperlinks - alle nach Excel...[ZIP 200 KB]
From many Word documents in a directory all hyperlinks should be copied to Excel. Output should be: Column A file name (path in comment) Column B Hyperlink (must be clickable) as shown in Word, the hyperlink address in column C and column D the displayed text. How does it work?
Hier noch eine Beispieldatei / Here's a sample file:
Word - Dokumente mit Hyperlinks - alle nach Excel...[ZIP 200 KB]
OptionExplicit
DimblnTMPAsBoolean
DimobjAppAsObject
'--------------------------------------------------------------------------
' Module : Module1
' Procedure : Main
' Author : Case (Ralf Stolzenburg)
' Date : 20.06.2013
' Purpose : Aus Worddokumenten Hyperlinks nach Excel kopieren...
'--------------------------------------------------------------------------
PublicSubMain()
' Dimensionieren der Variablen
DimobjDocumentAsObject
DimintHLinkAsInteger
DimlngLastRowAsLong
DimstrFileAsString
DimstrPathAsString
DimlngCalcAsLong
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
OnErrorGoToFin
' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
WithApplication
' Das Bildschirmaktualisierung wird unterbrochen
.ScreenUpdating=False
' Ereignisroutinen werden deaktiviert
.EnableEvents=False
' Auslesen der momentanen Einstellung für die Berechnung
lngCalc=.Calculation
' Setzen der Berechnung auf "Manuell"
.Calculation=xlCalculationManual
' Eingabeaufforderungen und Warnmeldungen unterdrücken
.DisplayAlerts=False
EndWith
' Pfad anpassen - fester Pfad vorgeben
'strPath = "C:\Temp\Word\"
' Pfad anpassen - Worddateien sind im gleichen
' Verzeichnis wie diese Exceldatei
strPath=ThisWorkbook.Path&Application.PathSeparator
' Die Wordapplikation sichtbar starten
SetobjApp=OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
IfNotobjAppIsNothingThen
strFile=Dir$(strPath&"*.doc*",vbDirectory)
' Der Code bezieht sich auf ein bestimmtes Objekt
' Hier Sheet1 = der CodeName der Tabelle
' im deutschen Excel in der Regel Tabelle1
' Alles was sich auf dieses "With" bezieht
' MUSS mit einem Punkt beginnen
WithSheet1
' Schleife bis keine Datei mehr vorhanden
DoWhilestrFile<>""
' Worddokument öffnen und der Objektvariablen zuweisen
SetobjDocument=objApp.Documents.Open_
(strPath&strFile)
' Alle Hyperlinks durchlaufen
ForintHLink=1ToobjDocument.Hyperlinks.Count
' Letzte belegte Zeile plus 1
lngLastRow=IIf(IsEmpty(.Cells(.Rows.Count,1)),_
.Cells(.Rows.Count,1).End(xlUp).Row,.Rows.Count)+1
' Dateiname schreiben Spalte A
.Cells(lngLastRow,1).Value=strFile
' Kommentar hinzufügen Spalte A
.Cells(lngLastRow,1).AddComment
' Kommentartext schreiben Spalte A
.Cells(lngLastRow,1).Comment.TextText:=strPath
' Hyperlink schreiben Spalte B wie in Word (anklickbar)
.Cells(lngLastRow,2).Value=_
objDocument.Hyperlinks(intHLink).TextToDisplay
' Hyperlink in Excel setzen Spalte B
.Cells(lngLastRow,2).Hyperlinks.Add_
Anchor:=.Cells(lngLastRow,2),_
Address:=objDocument.Hyperlinks(intHLink).Address
' Hyperlinkadresse schreiben Spalte C
.Cells(lngLastRow,3).Value=_
objDocument.Hyperlinks(intHLink).Address
' Hyperlink in Excel setzen Spalte C
.Cells(lngLastRow,3).Hyperlinks.Add_
Anchor:=.Cells(lngLastRow,3),_
Address:=objDocument.Hyperlinks(intHLink).Address
' Angezeigter Text schreiben Spalte D
.Cells(lngLastRow,4).Value=_
objDocument.Hyperlinks(intHLink).TextToDisplay
NextintHLink
' Worddokument ohne speichern schlissen
objDocument.CloseFalse
' Die nächste Datei nehmen
strFile=Dir$()
' Setze die Objektvariable auf Nothing
SetobjDocument=Nothing
Loop
' Spalte A:C optimale Breite setzen
.Columns("A:C").AutoFit
EndWith
Else
' Application auf PC nicht vorhanden
MsgBox"Application not installed!"
EndIf
Fin:
' Wenn noch ein Worddokument offen ist - schliessen ohne speichern
IfNotobjDocumentIsNothingThenobjDocument.CloseFalse
' Wenn die Applikation noch offen ist - schliessen
' Aber nur, wenn sie nicht vorher schon offen war
IfNotobjAppIsNothingThen
IfblnTMP=TrueThen
objApp.Quit
blnTMP=False
EndIf
EndIf
' Objektvariablen leeren
SetobjDocument=Nothing
SetobjApp=Nothing
' Die Applikation aufwecken
WithApplication
' Bildschirmaktualisierung wieder einschalten
.ScreenUpdating=True
' Ereignisroutinen werden wieder aktiviert
.EnableEvents=True
' Setzen der Berechnung auf den gemerkten Wert
.Calculation=lngCalc
' Eingabeaufforderungen und Warnmeldungen wieder zulassen
.DisplayAlerts=True
' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens
.CutCopyMode=True
EndWith
' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
IfErr.Number<>0ThenMsgBox"Fehler: "&_
Err.Number&" "&Err.Description
EndSub
'--------------------------------------------------------------------------
' Module : Module1
' Procedure : OffApp
' Author : Case (Ralf Stolzenburg)
' Date : 20.06.2013
' Purpose : Start application...
'--------------------------------------------------------------------------
PrivateFunctionOffApp(ByValstrAppAsString,_
OptionalblnVisibleAsBoolean=True)AsObject
OnErrorResumeNext
SetobjApp=GetObject(,strApp&".Application")
SelectCaseErr.Number
Case429
Err.Clear
SetobjApp=CreateObject(strApp&".Application")
blnTMP=True
IfblnVisible=TrueThen
OnErrorResumeNext
objApp.Visible=True
Err.Clear
EndIf
EndSelect
OnErrorGoTo0
SetOffApp=objApp
SetobjApp=Nothing
EndFunction