20.06.2013

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

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...