# VBA to write in a header/title/anything into a Word document, then VBA to read it.



## Stildawn (Aug 1, 2013)

Hi All

I have a macro that I run in Outlook. At the end of that macro there is this code:


```
job = ImputBox("Enter Job Number")

Dim word As Object
Set word = CreateObject("Word.Application") 
Template = "C:\Users\tbaker\Documents\Template.docm" 

With word 
    .Visible = True
    .Application.Activate 
    .Documents.Open (Template) 
End With
```

I am wondering if there is some code I can put into the "With word" block that would write the "job" variable into the Word document, and then some Word VBA code to read this "job" variable for use inside some Word macros saved in the Template.docm file that this code is opening.

I don't have any idea how to write this, but something like this mock code:


```
With word
     .Visible = True
     .Application.Activate
     .Documents.Open (Template)
     .Write.Header = job 'made up code haha I have no idea what the code would actually be but you get the idea
End with
```

And then in the Template.docm file a macro would be something like this:


```
Sub readjob()

Dim job As String
job = Header.Value 'Completely made up code but you get the idea, its passing the variable from Outlook into Word via writing it in the word document and then VBA reading it again into a variable in Word
```

Is anything like this possible? I imagine (though I haven't tested it) that it would be possible in excel by using something like "Excel.Sheets("Sheet1").Range("A1") = job" and then in excel "job = Sheets("Sheet1").Range("A1")" or something similar, but don't have any idea how/if its possible with word and outlook?

Thanks in advance.

With a little googling I found this: HeadersFooters Object (Word) using the second vba example could I use something like the below in my Outlook code:


```
ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = job
```

I have tried various positions of the this in:


```
job = ImputBox("Enter Job Number") 

Dim word As Object
Set word = CreateObject("Word.Application") 
Template = "C:\Users\tbaker\Documents\Template.docm" 

With word 
    .Visible = True
    .Application.Activate 
    .Documents.Open (Template) 
End With
```

But nothing has worked so far??

Cheers


----------



## DJeng (Aug 4, 2013)

Hi,

I have some code here from an Access application which I wrote a very  long time ago which may help you understand.  This created an expenses return using a word template. The object model for word seems a bit strange to those of us used to Excel, but you could learn more from word VBA help along with the object browser.  I had hoped to give you a copy of the associated word template but cannot post attachments here.


```
Public Sub WriteForm()
'note that the mileage and expenses data etc has been obtained by the getdata procedure in module 1
'and stored in public array variables
Dim wordApp As Object, strTemplate As String
Dim lngChar As Long, lngTextLength As Long
Dim intCol As Integer, intRow As Integer, intWriteRow(8) As Integer 'same as the table ref, ignore spare rows in array
Dim intTable As Integer, sngCost As Single, sngSubTotal(8, 2) As Single 'ditto
Dim strDescript As String, intDays As Integer
Dim lngTotMls As Long, sngGrandTotal(2) As Single
strTemplate = "C:\Users\acer\Documents\ExpReturnWeek_Template.dotx"
With Forms![claims].SiteCombo
    For intCol = 0 To 4
        strText(intCol) = .Column(intCol)
    Next intCol
    
End With
If WordRunning = False Then
            Set wordApp = CreateObject("Word.Application")
        Else
            Set wordApp = GetObject(, "Word.Application")
        End If
        With wordApp
            'create  the word document
                Documents.Add strTemplate, , , True
                wordApp.Visible = True
                
                If .ActiveWindow.View.SplitSpecial <> wdPaneNone Then
                    .ActiveWindow.Panes(2).Close
                End If
                
                If .ActiveWindow.ActivePane.View.Type = wdNormalView Or .ActiveWindow. _
                ActivePane.View.Type = wdOutlineView Then
                    .ActiveWindow.ActivePane.View.Type = wdPrintView
                End If
          
            With .ActiveDocument
                With .Shapes(3).TextFrame.TextRange 'header info
                'worksite start character(156) .Characters(161).Text
                
                For intchar = 1 To Len(strText(2))
                    .Characters(intchar + 155).Text = Mid(strText(2), intchar, 1)
                Next intchar
                
                'Site start date start character(205)
                
                For intchar = 1 To Len(strText(1))
                    .Characters(intchar + 204).Text = Mid(strText(1), intchar, 1)
                Next intchar
                
                'Mobile number start character(332)
                'not used
                
                'Job title start character(80)
                For intchar = 1 To Len(strText(3))
                    .Characters(intchar + 79).Text = Mid(strText(3), intchar, 1)
                Next intchar
                
                'Site number start character(358)
                For intchar = 1 To Len(strText(4))
                    .Characters(intchar + 357).Text = Mid(strText(4), intchar, 1)
                Next intchar
                
                End With
                
                With .Tables(1) 'car
                    For intCol = 1 To 5
                        .Cell(2, intCol) = varVehicle(intCol)
                    Next intCol
                End With
                
                lngTotMls = 0
                
            If blnHasMiles = True Then
                With .Tables(2) 'main site miles
                    intWriteRow(0) = 1 'increments to start at table row 2
                    
                    For intRow = 0 To UBound(varMiles, 2)
                        If varMiles(4, intRow) = 1 Then
                        
                            intWriteRow(0) = intWriteRow(0) + 1
                            
                            If varMiles(5, intRow) < 6 Then 'this is day number so adjusted to date
                                intDays = varMiles(5, intRow) - 5
                            Else
                                intDays = varMiles(5, intRow) - 12
                            End If
                            
                            .Cell(intWriteRow(0), 1) = DateAdd("d", intDays, dtClaim)
                            strDescript = varMiles(2, intRow) & " to " & varMiles(3, intRow)
                            
                            'add return if necessary
                            If varMiles(7, intRow) = True Then
                                strDescript = strDescript & " & return"
                            End If
                            
                            .Cell(intWriteRow(0), 2) = strDescript
                            .Cell(intWriteRow(0), 3) = varMiles(6, intRow) 'miles
                            lngTotMls = lngTotMls + varMiles(6, intRow)
                        End If
                        
                    Next intRow
                    
                    .Cell(9, 2) = lngTotMls
                    If lngTotMls > 0 Then
                        Call UpdateTotalMiles(CLng(varVehicle(0)), lngTotMls)
                    End If
                    
                End With
                lngTotMls = 0
                
                With .Tables(3) 'other miles
                    intWriteRow(0) = 1 'increments to start at table row 2
                    For intRow = 0 To UBound(varMiles, 2)
                    
                        If varMiles(4, intRow) <> 1 Then
                            intWriteRow(0) = intWriteRow(0) + 1
                            
                            If varMiles(5, intRow) < 6 Then 'this is day number so adjusted to date
                                intDays = varMiles(5, intRow) - 5
                            Else
                                intDays = varMiles(5, intRow) - 12
                            End If
                            
                            .Cell(intWriteRow(0), 1) = DateAdd("d", intDays, dtClaim)
                            strDescript = varMiles(2, intRow) & " to " & varMiles(3, intRow)
                            
                            'add return if necessary
                            If varMiles(7, intRow) = True Then
                                strDescript = strDescript & " & return"
                            End If
                            
                            .Cell(intWriteRow(0), 2) = strDescript
                            .Cell(intWriteRow(0), 3) = varMiles(6, intRow) 'miles
                            lngTotMls = lngTotMls + varMiles(6, intRow)
                        End If
                        
                    Next intRow
                    
                    .Cell(9, 2) = lngTotMls
                    
                    If lngTotMls > 0 Then
                        Call UpdateTotalMiles(CLng(varVehicle(0)), lngTotMls)
                    End If
                    
                End With
            End If
            
                For intTable = 4 To 8
                    intWriteRow(intTable) = 1 'increments to start at table row 2
                    sngSubTotal(intTable, 0) = 0
                    sngSubTotal(intTable, 1) = 0
                    sngSubTotal(intTable, 2) = 0
                Next intTable
                
                For intCol = 0 To 2
                    sngGrandTotal(intCol) = 0
                Next intCol
                
                For intRow = 0 To UBound(varExpense, 2)
                intTable = varExpense(1, intRow) + 3 'align to table ref
                intWriteRow(intTable) = intWriteRow(intTable) + 1
                With .Tables(intTable) 'travel / subsistence
                
                    If varExpense(5, intRow) < 6 Then 'this is day number so adjusted to date
                        intDays = varExpense(5, intRow) - 5
                    Else
                        intDays = varExpense(5, intRow) - 12
                    End If
                    
                    strDescript = DateAdd("d", intDays, dtClaim) & " "
                    strDescript = strDescript & varExpense(2, intRow) & ", "
                    strDescript = strDescript & varExpense(7, intRow)
                    .Cell(intWriteRow(intTable), 2) = strDescript
                    sngCost = varExpense(3, intRow) 'net cost
                    .Cell(intWriteRow(intTable), 3) = Format(sngCost, "##,##0.00") 'net cost
                    sngSubTotal(intTable, 0) = sngSubTotal(intTable, 0) + sngCost
                    sngCost = sngCost * varExpense(4, intRow) 'calc vat
                    sngSubTotal(intTable, 1) = sngSubTotal(intTable, 1) + sngCost
                    .Cell(intWriteRow(intTable), 4) = Format(sngCost, "##,##0.00")
                    sngCost = varExpense(6, intRow)
                    .Cell(intWriteRow(intTable), 5) = Format(sngCost, "##,##0.00") 'total cost
                    sngSubTotal(intTable, 2) = sngSubTotal(intTable, 2) + sngCost
                End With
                
                Next intRow
                With .Tables(intTable) 'sub totals
                    Select Case intTable
                        Case 4
                            intRow = 14
                        Case 5
                            intRow = 7
                        Case 6
                            intRow = 5
                        Case 7
                            intRow = 6
                        Case 8
                            intRow = 3
                    End Select
                    
                    For intCol = 0 To 2
                        .Cell(intRow, intCol + 2) = Format(sngSubTotal(intTable, intCol), "##,##0.00") 'subtotals
                    Next intCol
                    
                End With
                
                For intTable = 4 To 8 'grand totals
                
                    For intCol = 0 To 2
                        sngGrandTotal(intCol) = sngGrandTotal(intCol) + sngSubTotal(intTable, intCol)
                    Next intCol
                    
                Next intTable
                
                With .Tables(9)
                
                    For intCol = 0 To 2
                        .Cell(2, intCol + 2) = Format(sngGrandTotal(intCol), "##,##0.00")
                    Next intCol
                    
                End With
            End With
            'save the word file and write the full name to the claims form
            'and disable the create button to prevent duplication of mileage update
            're-enable on new record
            '################
            
            
        End With
End Sub

Public Function WordRunning() As Boolean
'checks if word already running
Dim wordApp As Object
WordRunning = True
On Error Resume Next    ' Defer error trapping.
' Getobject function called without the first argument returns a
' reference to an instance of the application. If the application isn't
' running, an error occurs.
Set wordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then WordRunning = False
Err.Clear    ' Clear Err object in case error occurred
End Function
```


Regards,

DJ


----------



## apo (Aug 4, 2013)

HI..

This might get you started for the part about writing values into a Word doc..

You need to Insert a Bookmark called "Job" in your Word doc (positioned where you want the data to go)..  Go to "Insert Tab" then click on the "Bookmark" icon..

Change the file path and file names to suit your town testing..


```
Private Sub CommandButton1_Click()
Dim objWord As Object
Dim ws As Worksheet
Dim job As Long
Dim FileName As String


job = InputBox("Enter Job Number")
Set ws = ThisWorkbook.Sheets("Sheet1")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "D:\test.docx"


With objWord.ActiveDocument
.Bookmarks("Job").Range.Text = job


    FileName = "test-" & job
    objWord.ActiveDocument.SaveAs "D:\" & FileName & ".docx"
End With
Set objWord = Nothing
End Sub
```


----------



## Stildawn (Aug 4, 2013)

Thanks Apo

I have been messing around with your solution.

This is the code now in Outlook:


```
Dim job As String
job = InputBox("Enter Job Number")

Dim objWord As Object
Dim FileName As String
Set objWord = CreateObject("Word.Application")

objWord.Visible = True
objWord.Documents.Open "G:\Airfreight_Export\Export Airfreight\Template.docm"
objWord.Activate

With objWord.ActiveDocument
.Bookmarks("Job").Range.Text = job
.Application.Run MacroName:="Run"
End With

Set objWord = Nothing
```

This now carries across the job number into a bookmark in the Word template.

In the Word template I now have this code which I was hoping would read the bookmark (and hence the job number carried across from Outlook):


```
Dim job As String
Selection.GoTo What:=wdGoToBookmark, Name:="Job"
Selection.Expand wdLine
job = Selection.Text
MsgBox ("Click Print Screen")
Selection.Paste

Dim DocName As String
DocName = "N:\Customs\Customs_Docs\" & job & "\" & job & ".pdf"
ActiveDocument.SaveAs2 FileName:=DocName, FileFormat:=wdFormatPDF
ActiveDocument.Saved = True
```

But now I am getting a run time 4198 command failed error on the "ActiveDocument.SaveAs2 FileName:=DocName, FileFormat:=wdFormatPDF" line.

When I hit debug and hover over DocName it comes up correctly, showing the full path as well as the job number (carried from Outlook) with .pdf on the end. It all looks in order but its just not working???

Any ideas?


----------



## Stildawn (Aug 4, 2013)

Thanks Apo 

I have been messing around with your solution.

This is the code now in Outlook:


```
Dim job As String
job = InputBox("Enter Job Number")

Dim objWord As Object
Dim FileName As String
Set objWord = CreateObject("Word.Application")

objWord.Visible = True
objWord.Documents.Open "G:\Airfreight_Export\Export Airfreight\Template.docm"
objWord.Activate

With objWord.ActiveDocument
.Bookmarks("Job").Range.Text = job
.Application.Run MacroName:="Run"
End With

Set objWord = Nothing
```

This now carries across the job number into a bookmark in the Word template.

In the Word template I now have this code which I was hoping would read the bookmark (and hence the job number carried across from Outlook):


```
Dim job As String
Selection.GoTo What:=wdGoToBookmark, Name:="Job"
Selection.Expand wdLine
job = Selection.Text
MsgBox ("Click Print Screen")
Selection.Paste

Dim DocName As String
DocName = "N:\Customs\Customs_Docs\" & job & "\" & job & ".pdf"
ActiveDocument.SaveAs2 FileName:=DocName, FileFormat:=wdFormatPDF
ActiveDocument.Saved = True
```

But now I am getting a run time 4198 command failed error on the "ActiveDocument.SaveAs2 FileName:=DocName, FileFormat:=wdFormatPDF" line.

When I hit debug and hover over DocName it comes up correctly, showing the full path as well as the job number (carried from Outlook) with .pdf on the end. It all looks in order but its just not working???

Any ideas?


----------



## apo (Aug 5, 2013)

Hi..

Instead of SaveAs.. try using "ExportAsFixedFormat"..

Hers a couple of links..

Export word document to PDF via Excel VBA

Save WordDocument as pdf using VBA


----------



## Stildawn (Aug 5, 2013)

Hi Apo

This is what I have in Word now:


```
Dim job As String
Selection.GoTo What:=wdGoToBookmark, Name:="Job"
Selection.Expand wdLine
job = Selection.Text
Selection.GoTo What:=wdGoToBookmark, Name:="Screen"
Selection.Paste

Dim DocName As String
DocName = "N:\Customs\Customs_Docs\" & job & "\" & job & ".pdf"
ActiveDocument.ExportAsFixedFormat DocName, 17
ActiveDocument.Saved = True
```

When I step through this code (and also using a MsgBox(job) line to check) it works as intended, the text populates into the "job" variable correctly etc. However when it gets to the Export line it errors out, now with a "That is not a valid filename" error??

When you debug and hover over DocName, it equals "N:\Customs\Customs_Docs\test5\test5.pdf" (test5 begin this example). I can't see whats wrong with this? I can't see any invalid characters or anything?

I also tried this code instead:


```
ActiveDocument.ExportAsFixedFormat Filename:=DocName Type:=wdExportFormatPDF
```

But with this code I get a Name Arguement error on both "Filename:=" and "Type:="

Any other ideas?

Thanks in advance.


----------



## Stildawn (Aug 5, 2013)

Realised I messed up the second format code so here is what I tried now:


```
ActiveDocument.ExportAsFixedFormat OutputFileName:=DocName, ExportFormat:=wdExportFormatPDF
```

Now this gets the "This is not a valid filename" error the same as the other code above, so I guess both are identical.

I tried just manually typing in the file name so that the code was this:


```
ActiveDocument.ExportAsFixedFormat OutputFileName:="N:\Customs\Customs_Docs\test1\test1.pdf", ExportFormat:=wdExportFormatPDF
```

And low and behold this worked, it saved the document as a pdf under that folder and name???? So there must be something wrong with how vba generates the "DocName" variable. It looks identical to me when I hover over it though??

Check for yourselves, this is a picture of me hovering over the DocName variable when I have debugged:







Looks identical to what I've manually typed out right?

So I think it all comes back to making the "job" variable from reading the Job bookmark. I don't know how but somehow I believe this is messing it all up.

Cheers


----------



## apo (Aug 5, 2013)

Hi..

Try adding this..


```
DocName[I] = Replace(DocName, Chr(13),"")[/I]
```

Add it just before this line..

```
[COLOR=#574123]ActiveDocument.ExportAsFixedFormat OutputFileName:=DocName, ExportFormat:=wdExportFormatPDF[/COLOR]
```

Might work?

[SOLVED] ExportAsFixedFormat FileName problem


----------



## Stildawn (Aug 5, 2013)

Ah brilliant. I was working down that route myself thinking a sneaky invisible character was getting in there somewhere.

Thanks works a treat now.


----------

