Word WaterMark using Excel VBA - Runtime Error 438

[BrotherDude]

Hello all,

I have a project where I am exporting an excel table to word and trying to add a watermark. The loop is as follows, Create folder, create word doc, add table to word doc, save, add watermark, save, close, loop. Everything is working except for the watermark. When I put the watermark code in a Word module it works however in excel I'm getting runtime errors. I've added the Word library to so I'm not sure what I'm doing wrong. Is this one of those early vs late binding situations?

Sub CreatPriceMatrixPDF()


'define variable
Dim r As Long
Dim Name As Range
Dim NewFile As String
Dim NewFolder As String
Dim SavePath As String
Dim appWD As Object
Set appWD = CreateObject("Word.Application")
'Dim appDoc As Object
'Set appDoc = appWD.Documents.Add


Dim ws1 As Worksheet
Dim ws2 As Worksheet




Set ws1 = Sheets("Sheet 1")
Set ws2 = Sheets("Sheet 2")



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



ws1.Range(ws1.UsedRange.Address).CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set Name = ws2.Range("A2")


'With Application
' .EnableEvents = False
' .ScreenUpdating = False
'End With


'creates new folder and save path
NewFolder = "New Folder")
SavePath = "\\PathEX" & "\" & NewFolder
On Error Resume Next
MkDir (SavePath)
On Error GoTo 0


'sets loop
records = Application.CountA(Sheets("Sheet1").Range("B:B"))
For r = 2 To records






NewFile = Name & "-" & Format$(Date, "mm.dd.yy")


With appWD
'opens new Word Doc
.Documents.Add
.Visible = True


'populates Doc with excel data
With .Selection
.Paste
.TypeParagraph


End With

'save the word doc as name and date
.ActiveDocument.SaveAs Filename:=SavePath & "\" & NewFile & ".docx"
End With


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''Found the code below online but I'm getting runtime error 438 when running out of Excel VBE, works in MS Word VBE
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim strWMName As String


'selects all the sheets
ActiveDocument.Sections(1).Range.Select
strWMName = ActiveDocument.Sections(1).Index
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader ''''''ERROR""""" Runtime Error 438
'Change the text for your watermark here
Selection.HeaderFooter.Shapes.AddTextEffect(msoTextEffect1, _ '''''ERROR"""""Runtime Error 438
"DRAFT", "Arial", 1, False, False, 0, 0).Select
With Selection.ShapeRange

.Name = strWMName
.TextEffect.NormalizedHeight = False
.Line.Visible = False

With .Fill

.Visible = True
.Solid
.ForeColor.RGB = Gray
.Transparency = 0.5
End With

.Rotation = 315
.LockAspectRatio = True
.Height = InchesToPoints(2.42)
.Width = InchesToPoints(6.04)

With .WrapFormat
.AllowOverlap = True
.Side = wdWrapNone
.Type = 3

End With

.RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin

'If using Word 2000 you may need to comment the 2
'lines above and uncomment the 2 below.

' .RelativeHorizontalPosition = wdRelativeVerticalPositionPage
' .RelativeVerticalPosition = wdRelativeVerticalPositionPage

.Left = wdShapeCenter
.Top = wdShapeCenter
End With

ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Documents.Save NoPrompt:=True, OriginalFormat:=wdOriginalDocumentFormat


'Kill the object
appWD.Quit False
Set appWD = Nothing


Next r


'Show the folder
Shell "explorer.exe " & SavePath, vbNormalFocus




End Sub




Pretty Long, sorry, If I don't get any responses I will shorten this to just the waterMArk part. Any Help is appreciated.

Thanks ahead of time

-Jeff

 

[BrotherDude]

http://www.mrexcel.com/forum/excel-...l-basic-applications-runtime-error-438-a.html

I shortened the question and sample code in the post above.