Question : Insert File VBA issues with Styles

Experts

I have some VBA running from Access 2007 which loads up Word 2007, opens a document and then starts inserting lots of other documents (Code Attached)

The problem I have is with styles, the document being merged are from a variety of different sources and thus when the files are inserted styles get applied and it does not look like the original file

The only styles I really need to utilise are Heading 1 and Heading 2 as these are used in the TOC

Any help / recommendations are greatly appreciated

My users do not like the fact that they might need to sanitise the source documents

Some options are to remove all styles but leave the formatting from the source documents except header 1 and 2
If this is possible
Code Snippet:
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:

           
           
             Public Sub CreateDoc(mvpartnerid As Long, mvQuarterid As Long)
Dim AP As New Word.Application
Dim DOC As Word.Document
Dim DOC2 As Word.Document
 
Dim db As DAO.Database
Dim rstPartner As DAO.Recordset
Dim rstQuarter As DAO.Recordset
Dim rstPortfolio As DAO.Recordset
 
Dim mvTemplateLocation As String
Dim mvPortfolioLocation As String
Dim mvInvestmentLocation As String
 
Dim mvNoOfPortfoliosProcessed As Long
Dim mvNoOfKeyInvestments As Long
 
mvTemplateLocation = DLookup("GlobalDocumentLocation", "System Documents")
mvPortfolioLocation = DLookup("PortfolioDocumentLocation", "System Documents")
mvInvestmentLocation = DLookup("InvestmentDocumentLocation", "System Documents")
 
Set db = CurrentDb
Set rstPartner = db.OpenRecordset("Select * from partners where partnerid = " & mvpartnerid, dbReadOnly)
Set rstQuarter = db.OpenRecordset("Select * from Quarter where quarterid = " & mvQuarterid, dbReadOnly)
 
 
 
'Set DOC = AP.Documents.Add
Set DOC = AP.Documents.Open(mvTemplateLocation & "\blank.docx")
 
AP.Visible = False
 
With AP.Selection.PageSetup
        .Orientation = wdOrientPortrait
        .TopMargin = CentimetersToPoints(1)
        .BottomMargin = CentimetersToPoints(0.6)
        .LeftMargin = CentimetersToPoints(2.54)
        .RightMargin = CentimetersToPoints(2.54)
        .Gutter = CentimetersToPoints(0)
        .PageWidth = CentimetersToPoints(21)
        .PageHeight = CentimetersToPoints(29.7)
End With
 
If Dir(mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\COVERPAGE" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx") <> "" Then
    AP.Selection.InsertFile mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\COVERPAGE" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx"
    AP.Selection.EndKey Unit:=wdStory
    AP.Selection.InsertBreak Type:=wdSectionBreakNextPage
End If
 
 
'Plan Information
AP.Selection.InsertFile mvTemplateLocation & "\Quarter\" & Trim(rstQuarter!Quarter) & "\plan info.docx"
AP.Selection.EndKey Unit:=wdStory
 
'Reset Page Number to start at 1
With AP.Selection.Sections(1).Headers(1).PageNumbers
    .RestartNumberingAtSection = True
    .StartingNumber = 1
End With
 
AP.Selection.InsertBreak Type:=wdSectionBreakNextPage
 
'Plan Managers Investment Report
AP.Selection.InsertFile mvTemplateLocation & "\Quarter\" & Trim(rstQuarter!Quarter) & "\Plan Managers Investment Report.docx"
AP.Selection.EndKey Unit:=wdStory
'Reset Page Numbers
With AP.Selection.Sections(1).Headers(1).PageNumbers
    .RestartNumberingAtSection = False
    .StartingNumber = 0
End With
 
AP.Selection.InsertBreak Type:=wdSectionBreakNextPage
 
'IAR
With AP.Selection.PageSetup
        .Orientation = wdOrientPortrait
        .TopMargin = CentimetersToPoints(1.5)
        .BottomMargin = CentimetersToPoints(1.5)
        .LeftMargin = CentimetersToPoints(2.3)
        .RightMargin = CentimetersToPoints(2.3)
        .Gutter = CentimetersToPoints(0)
        .PageWidth = CentimetersToPoints(21)
        .PageHeight = CentimetersToPoints(29.7)
End With
 
If Dir(mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\IAR" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx") <> "" Then
    AP.Selection.InsertFile mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\IAR" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx"
    AP.Selection.EndKey Unit:=wdStory
    AP.Selection.InsertBreak Type:=wdSectionBreakNextPage
End If
 
'Investment Charts
AP.Selection.InsertFile mvTemplateLocation & "\Quarter\" & Trim(rstQuarter!Quarter) & "\Investment Charts.docx"
AP.Selection.EndKey Unit:=wdStory
AP.Selection.InsertBreak Type:=wdSectionBreakNextPage
 
 
If Dir(mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\SKI" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx") <> "" Then
    'SKI
    'AP.WordBasic.TogglePortrait Orientation:=1 'Landscape
    With AP.Selection.PageSetup
            .Orientation = wdOrientLandscape
            .TopMargin = CentimetersToPoints(1.68)
            .BottomMargin = CentimetersToPoints(2.54)
            .LeftMargin = CentimetersToPoints(2.86)
            .RightMargin = CentimetersToPoints(2.54)
            .Gutter = CentimetersToPoints(0)
            .PageWidth = CentimetersToPoints(29.7)
            .PageHeight = CentimetersToPoints(21)
    End With
    
    
    AP.Selection.InsertFile mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\SKI" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx"
    AP.Selection.EndKey Unit:=wdStory
    AP.Selection.InsertBreak Type:=wdSectionBreakNextPage
End If
 
 
If Dir(mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\FS" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx") <> "" Then
    'Financial Summary
    With AP.Selection.PageSetup
            .Orientation = wdOrientPortrait
            .TopMargin = CentimetersToPoints(0.9)
            .BottomMargin = CentimetersToPoints(0.9)
            .LeftMargin = CentimetersToPoints(3.17)
            .RightMargin = CentimetersToPoints(3.17)
            .Gutter = CentimetersToPoints(0)
            .PageWidth = CentimetersToPoints(21)
            .PageHeight = CentimetersToPoints(29.7)
    End With
    AP.Selection.InsertFile mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\FS" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx"
    AP.Selection.EndKey Unit:=wdStory
    AP.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    AP.Selection.HeaderFooter.LinkToPrevious = False
    'AP.Selection.HeaderFooter.LinkToPrevious = Not AP.Selection.HeaderFooter.LinkToPrevious
    AP.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    AP.WordBasic.RemoveHeader
    AP.Selection.InsertBreak Type:=wdSectionBreakNextPage
End If
 
'Now put in the 2 Page Reports
'quarterpartner.keyinvestments
 
mvNoOfKeyInvestments = Nz(DLookup("KeyInvestments", "QuarterPartner", "quarterid = " & mvQuarterid & " AND Partnerid = " & mvpartnerid), 0)
mvNoOfPortfoliosProcessed = 0
 
Set rstPortfolio = db.OpenRecordset("SELECT Investments.InvestmentFolder FROM Participation LEFT JOIN Investments ON Participation.investmentid = Investments.InvestmentId WHERE Investments.Active = True And Participation.categoryid = 2 And Participation.quarterid = " & mvQuarterid & " And Participation.partnerid = " & mvpartnerid & " ORDER BY Participation.BVCA DESC", dbReadOnly)
While Not rstPortfolio.EOF
        
    Set DOC2 = AP.Documents.Open(mvInvestmentLocation & "\" & Trim(rstPortfolio!investmentFolder) & "\2PR" & Trim(rstPortfolio!investmentFolder) & Trim(rstQuarter!Quarter) & ".docx")
    DOC.Activate
    'DOC.Select
    'AP.Selection.EndKey Unit:=wdStory
    'Insert the 2 Page Summary
    With AP.Selection.PageSetup
            .Orientation = wdOrientPortrait
            .TopMargin = DOC2.PageSetup.TopMargin
            .BottomMargin = DOC2.PageSetup.BottomMargin
            .LeftMargin = DOC2.PageSetup.LeftMargin
            .RightMargin = DOC2.PageSetup.RightMargin
            .Gutter = DOC2.PageSetup.Gutter
            .PageWidth = DOC2.PageSetup.PageWidth
            .PageHeight = DOC2.PageSetup.PageHeight
    End With
    DOC2.Close
    DOC.Activate
    'DOC.Select
    If "a" = "b" Then
    With AP.Selection.PageSetup
            .Orientation = wdOrientPortrait
            .TopMargin = CentimetersToPoints(1.27)
            .BottomMargin = CentimetersToPoints(1.27)
            .LeftMargin = CentimetersToPoints(1.27)
            .RightMargin = CentimetersToPoints(1.27)
            .Gutter = CentimetersToPoints(0)
            .PageWidth = CentimetersToPoints(21)
            .PageHeight = CentimetersToPoints(29.7)
    End With
    End If
    AP.Selection.InsertFile mvInvestmentLocation & "\" & Trim(rstPortfolio!investmentFolder) & "\2PR" & Trim(rstPortfolio!investmentFolder) & Trim(rstQuarter!Quarter) & ".docx"
    
    'If its a key investment then insert the picture and align correctly
    If mvNoOfPortfoliosProcessed < mvNoOfKeyInvestments And 1 = 2 Then
        AP.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        AP.Selection.InlineShapes.AddPicture FileName:="Y:\Reports\Templates\watermarkportrait.JPG", LinkToFile:=False, SaveWithDocument:=True
        AP.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    End If
    
    AP.Selection.EndKey Unit:=wdStory
    
    AP.Selection.InsertBreak Type:=wdSectionBreakNextPage
    mvNoOfPortfoliosProcessed = mvNoOfPortfoliosProcessed + 1
    rstPortfolio.MoveNext
Wend
rstPortfolio.Close
 
'Passive
With AP.Selection.PageSetup
        .Orientation = wdOrientLandscape
        .TopMargin = CentimetersToPoints(2)
        .BottomMargin = CentimetersToPoints(2)
        .LeftMargin = CentimetersToPoints(2.69)
        .RightMargin = CentimetersToPoints(1.25)
        .Gutter = CentimetersToPoints(0)
        .PageWidth = CentimetersToPoints(29.7)
        .PageHeight = CentimetersToPoints(21)
End With
 
If Dir(mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\PASSIVE" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx") <> "" Then
    AP.Selection.InsertFile mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\PASSIVE" & Trim(rstPartner!Folder) & Trim(rstQuarter!Quarter) & ".docx"
    AP.Selection.EndKey Unit:=wdStory
    AP.Selection.InsertBreak Type:=wdSectionBreakNextPage
End If
 
'Semi Annual Report
If Dir(mvTemplateLocation & "\Quarter\" & Trim(rstQuarter!Quarter) & "\Semi Annual Plan Report.docx") <> "" Then
    With AP.Selection.PageSetup
            .Orientation = wdOrientPortrait
            .TopMargin = CentimetersToPoints(1)
            .BottomMargin = CentimetersToPoints(0.6)
            .LeftMargin = CentimetersToPoints(2.54)
            .RightMargin = CentimetersToPoints(2.54)
            .Gutter = CentimetersToPoints(0)
            .PageWidth = CentimetersToPoints(21)
            .PageHeight = CentimetersToPoints(29.7)
    End With
    AP.Selection.InsertFile mvTemplateLocation & "\Quarter\" & Trim(rstQuarter!Quarter) & "\Semi Annual Plan Report.docx"
End If
 
'Delete the Last Page
AP.Selection.TypeBackspace
 
DOC.Fields.Update
 
DOC.SaveAs mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\Full Report " & Trim(rstQuarter!Quarter) & ".docx"
DOC.ExportAsFixedFormat mvPortfolioLocation & "\" & Trim(rstPartner!Folder) & "\Full Report " & Trim(rstQuarter!Quarter) & ".pdf", wdExportFormatPDF, False, wdExportOptimizeForPrint, wdExportAllDocument, 1, 1, wdExportDocumentContent, True, True, wdExportCreateHeadingBookmarks, True, True, False
AP.Visible = True
'DOC.Close
'AP.Quit
 
On Error Resume Next
rstPartner.Close
rstQuarter.Close
Set db = Nothing
 
End Sub

           
         
Open in New Window
Select All
Answer : Insert File VBA issues with Styles

What you might try to do is this:

In Word 2007, go to Word Options, Advanced, and go to Cut, Copy and Paste. There, you can select options for documents with styles -- Keep Text Only... I know this works with pasting text, but am not sure if it will work with inserting files... but you can give it a try.

See attached screenshot.

2007-Paste-Styles-Options.jpg (122 KB) (File Type Details)

Paste with Styles Options
