Hyperlink in Word-Doc durch Excel
03.06.2020 10:13:43
David
ich habe mal wieder ein Problem damit aus Excel heraus Word anzusprechen. Ich möchte gerne eine Word-Vorlage aufrufen und diese mit Daten aus Excel befüllen, das klappt auch. Jetzt möchte ich noch Hyperlinks in dem Word-Dokument setzen. Da fangen leider die Probleme an. Und zwar möchte ich an jeder Stelle im Word-Dokument, wo "siehe Anlage Berechnungsergebnisse" auf die Überschrift "Zusammenfassung der Berechnungsergebnisse" verlinken. Dabei erhalte ich leider immer die Fehlermeldung "Objekt unterstützt diese Eigenschaft oder Methode nicht". Kann mir jemand helfen? Mein Code sieht folgendermaßen aus:
Option Explicit
Public objWordRange As Object
Public objDocument As Object
Public objDialog As Object
Public objApp As Object
Public strVorlage As String
Sub BerichtGesamt()
Dim Link As String
strVorlage = "Mein Pfad"
Set objApp = OffApp("Word")
If Not objApp Is Nothing Then
Set objDocument = objApp.Documents.Add(Template:=strVorlage)
'Unterprogramm zum befüllen des Word-Dokuments
If Berechnungsergebnisse = 1 Then
Call Berechnungsergebnisse_Subroutine
Else
Exit Sub
End If
'bis hier klappt alles
'------------------------------------------------------------------------
'ab hier fange die Probleme an
Link = "siehe Anlage Berechnungsergebnisse"
With objApp
objApp.Hyperlinks.Add Anchor:=Link, Adress:="", _
SubAdress:="_Zusammenfassung_der_Berechnungsergebnisse", ScreenTip:=""
End With
Application.CutCopyMode = True
' Objektvariable objWordRange leeren
Set objWordRange = Nothing
Set objDialog = objApp.Dialogs(wdDialogFileSaveAs)
With objDialog
' Pfad vorgeben
.Name = "Mein Pfad"
' Wenn auf Speichern geklickt wurde...
If .Display = -1 Then
objDocument.SaveAs Filename:=.Name
End If
' Dokument schliessen
objDocument.Close
End With
Else
' Ausgabe, wenn die Objektvariable objApp Nothing ist...
MsgBox "Applikation nicht installiert!"
End If
Fin:
If Not objApp Is Nothing Then
' Word war nicht offen, also...
If blnTMP = True Then
' ... Word schliessen
objApp.Quit
blnTMP = False
End If
End If
' Objektvariablen leeren
Set objWordRange = Nothing
Set objDocument = Nothing
Set objApp = Nothing
Application.CutCopyMode = True
' Wenn die Fehlernummer NICHT 0 ist, dann gib die Fehlernummer
' und die Fehlerbeschreibung aus
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
Optional blnVisible As Boolean = True) As Object
Dim objApp 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
Ich hoffe mir kann jemand helfen,
vielen Dank im Voraus,
Beste Grüße David