Word - Dokumente mit Hyperlinks - alle nach Excel...

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]

Option Explicit
Dim blnTMP As Boolean
Dim objApp As Object
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.06.2013
' Purpose   : Aus Worddokumenten Hyperlinks nach Excel kopieren...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Dimensionieren der Variablen
    Dim objDocument As Object
    Dim intHLink As Integer
    Dim lngLastRow As Long
    Dim strFile As String
    Dim strPath As String
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        ' 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
    End With
    ' 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
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objApp Is Nothing Then
        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
        With Sheet1
            ' Schleife bis keine Datei mehr vorhanden
            Do While strFile <> ""
                ' Worddokument öffnen und der Objektvariablen zuweisen
                Set objDocument = objApp.Documents.Open _
                    (strPath & strFile)
                    ' Alle Hyperlinks durchlaufen
                    For intHLink = 1 To objDocument.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.Text Text:=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
                    Next intHLink
                ' Worddokument ohne speichern schlissen
                objDocument.Close False
                ' Die nächste Datei nehmen
                strFile = Dir$()
                ' Setze die Objektvariable auf Nothing
                Set objDocument = Nothing
            Loop
            ' Spalte A:C optimale Breite setzen
            .Columns("A:C").AutoFit
        End With
    Else
        ' Application auf PC nicht vorhanden
        MsgBox "Application not installed!"
    End If
Fin:
    ' Wenn noch ein Worddokument offen ist - schliessen ohne speichern
    If Not objDocument Is Nothing Then objDocument.Close False
    ' Wenn die Applikation noch offen ist - schliessen
    ' Aber nur, wenn sie nicht vorher schon offen war
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    ' Objektvariablen leeren
    Set objDocument = Nothing
    Set objApp = Nothing
    ' Die Applikation aufwecken
    With Application
        ' 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
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.06.2013
' Purpose   : Start application...
'--------------------------------------------------------------------------
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...