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

S

Stildawn

Board Regular
Joined
Aug 26, 2012
Messages
201
Hi All

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

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:

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:

Code: 
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:

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

I have tried various positions of the this in:

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

But nothing has worked so far??

Cheers
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
Sort by date Sort by votes
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.

Code: 
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
 
Upvote 0
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..

Code: 
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
 
Upvote 0
Thanks Apo

I have been messing around with your solution.

This is the code now in Outlook:

Code: 
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):

Code: 
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?
 
Upvote 0
Thanks Apo

I have been messing around with your solution.

This is the code now in Outlook:

Code: 
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):

Code: 
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?
 
Upvote 0
Hi Apo

This is what I have in Word now:

Code: 
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:

Code: 
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.
 
Last edited:
Upvote 0
Realised I messed up the second format code so here is what I tried now:

Code: 
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:

Code: 
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:

whyisntthisworking_zps286af881.jpg


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
 
Last edited:
Upvote 0
Ah brilliant. I was working down that route myself thinking a sneaky invisible character was getting in there somewhere.

Thanks works a treat now.
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Create VBA Tools - Linked Word & Excel Files / MailMerge?
Replies
8
Views
199
Macropod
Macropod
A
  • Question Question
Copying whole word document, into excel + formatting columns and cells
Replies
1
Views
370
Macropod
Macropod
J
  • Question Question
Word VBA to access 'Linked Object > Edit Link' path in Context Menu
Replies
1
Views
151
jdarner
J
S
  • Question Question
VBA code to update/refresh a mail merge in word
Replies
0
Views
998
StephenBart
S
C
  • Question Question
Word VBA: Running a macro that takes the row number of Named Range for coordinates but seeing error Method 'Range of object'_Worksheet.
Replies
7
Views
110
circusnight
C

Forum statistics

Threads
1,225,651
Messages
6,186,185
Members
453,339
Latest member
Stu61

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top