AW: mit VBA aus Excel Worddatei mit Fusstext erzeugen
05.06.2013 07:21:25
Case
Hallo, :-)
Du hast auch zweimal ein ".Documents.Add" drin. Das erste raus.
Um Word in den Vordergrund zu holen, kannst Du es mal mit den Konstanten "wdWindowStateMinimize" und "wdWindowStateMaximize" bzw. "wdWindowStateNormal" probieren.
Zur Not geht auch noch API.
So funzt es bei mir:
Option Explicit
Const wdWindowStateMinimize = 2
Const wdWindowStateMaximize = 1
'Const wdWindowStateNormal = 0
Public Sub Test()
Dim objFooter As Object
Dim objWDApp As Object
Dim objWDDoc As Object
Dim objRange As Object
On Error GoTo Fin
Set objWDApp = OffApp("Word")
If Not objWDApp Is Nothing Then
With objWDApp
.WindowState = wdWindowStateMinimize
.WindowState = wdWindowStateMaximize
DoEvents
.Activate
End With
'Set objWDDoc = objWDApp.Documents.Open("C:\Temp\Dok1.doc")
Set objWDDoc = objWDApp.Documents.Add
Set objFooter = objWDDoc.Sections(1).Footers(1)
With objFooter.Range
Set objRange = .Characters(Len(objFooter.Range.Text))
objFooter.Range.Text = "Seite "
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.Fields.Add objRange, -1, "PAGE"
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.Text = " von "
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.Fields.Add objRange, -1, "NUMPAGES"
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.Text = vbTab
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.InsertDateTime DateTimeFormat:="dd.MM.yyyy"
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.Text = vbTab
Set objRange = .Characters(Len(objFooter.Range.Text))
objRange.Fields.Add objRange, -1, "AUTHOR"
End With
End If
Fin:
Set objRange = Nothing
Set objFooter = Nothing
Set objWDDoc = Nothing
Set objWDApp = Nothing
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String) 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")
objApp.Visible = True
If Err.Number > 0 Then
MsgBox Err.Number & " " & Err.Description
Set objApp = Nothing
End If
Case 0
Case Else
MsgBox Err.Number & " " & Err.Description
Set objApp = Nothing
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function
Servus
Case