Word2007 - Normal.dotm errors - Have to close Word first

[bg18461]

I have a program that pulls in word docs that are setup with different headers and information based on selections in excel. The problem I have is that I have to quit word before I create a new document in the program. If I don't, I get "Normal.dotm" errors - it states that the file is in use and it prompts me to save it. Is there any way my program can loop through word files without quitting word in between?

[Nelviticus]

That depends on the program. Is it VBA code running from Excel? If so, can you post the part of the code that deals with Word (don't forget to use the 'VBA' button in the message editor to make it readable).

[bg18461]

Yes its VBA code running from Excel to manipulate Word.
I will post both sections of this function. Heres the first.


Sub GrabTemplates()
Dim iVal As Integer
Dim sVal As String
Dim sReportLibPath As String
Dim sThisReportPath As String
Dim sThisFinalReportPath As String

sThisReportPath = Sheets("CalcSheet").Range("N9").Value
sReportLibPath = "\\rt122\VA443\Report TEMPLATE LIBRARY\"
sThisFinalReportPath = Sheets("CalcSheet").Range("N11").Value
For iVal = 1 To Sheets("CalcSheet").Range("J65536").End(xlUp).Row
If Sheets("CalcSheet").Range("K" & iVal).Value = True Then
If Dir(sThisReportPath & "\" & Sheets("CalcSheet").Range("L" & iVal).Value) = "" Then
FileCopy sReportLibPath & Sheets("CalcSheet").Range("J" & iVal).Value, sThisReportPath & "\" & _
Sheets("CalcSheet").Range("L" & iVal).Value
Select Case iVal
Case 1 To 3
FormatTemplates sThisReportPath & "\" & Sheets("CalcSheet").Range("L" & iVal).Value, iVal
Case Else
FormatTemplates sThisReportPath & "\" & Sheets("CalcSheet").Range("L" & iVal).Value, 0
End Select
End If
End If
Next iVal
'Final Compiled Report
FileCopy sReportLibPath & "Final Report Report.docm", sThisFinalReportPath & "\" & _
Sheets("CalcSheet").Range("N14").Value
FormatTemplates sThisFinalReportPath & "\" & Sheets("CalcSheet").Range("N14").Value, 5
End Sub

[bg18461]

Heres the second (its long so i will use parts A - E for this)
PART A:

Sub FormatTemplates(sTemplate As String, iKeyTemplates As Integer)
On Error GoTo FormatTemplates_Error:
Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet
Dim wdInfo As Word.Range
Dim myNamed As Excel.Range
Dim txtAcctName As Word.Range, txtCoName As Word.Range, txtContact As Word.Range
Dim txtConTitle As Word.Range, txtConPh As Word.Range, txtBillAdd1 As Word.Range
Dim txtBillAdd2 As Word.Range, txtBillAdd3 As Word.Range, txtAE As Word.Range
Dim txtSqft As Word.Range, txtRate As Word.Range, txtAcct As Word.Range
Dim bulletLoc As Word.Range, txtCoName1 As Word.Range, txtCoName2 As Word.Range
Dim txtCostIndexUnit As Word.Range, txtUmIndeUnit As Word.Range, txtCostUnit As Word.Range
Dim txtCostSum As Word.Range, txtUmbIndexSum As Word.Range, txtBasisUnit As Word.Range
Dim txtECostUnit As Word.Range, txtLFac As Word.Range, txtCostIndexSum As Word.Range
Dim txtEcologyCostSum As Word.Range, txtImprov As Word.Range
Dim i As Long
Dim iCount As Integer
Dim iVal As Integer
Dim sImprovHyperLink As String
Dim sBulletBkMrk As String
Dim sProgHeaderPic As String
Dim sCompLogoPic As String
Dim sCompLogoPicBlank As String
Dim thisReportPath As String
Dim iFileCount As Integer
Dim objAcct(1 To 10) As Range
Dim theChart As ChartObject
Dim objBillAdd1 As Range, objCoName As Range, objContact As Range, objConTitle As Range
Dim objConPh As Range, objAcctName As Range, objBillAdd2 As Range, objBillAdd3 As Range
Dim objAE As Range, objSqft As Range, objUmIndeUnit As Range, objECostUnit As Range
Dim objRate As Range, objImprov As Range, objEcologyCost As Range, objCostIndex As Range
Dim objCost As Range, objUmIndex As Range, objLFac As Range, objBasisUnit As Range
Dim objCostIndexUnit As Range, objCostUnit As Range
sCompLogoPic = Sheets("CalcSheet").Range("N10").Value
sCompLogoPicBlank = "\\rt122\VA443\Report TEMPLATE LIBRARY\Misc Images\Blank Logo.bmp"
' Application.ScreenUpdating = True
' Application.StatusBar = "Creating new document..."

Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True

Set wdDoc = wdApp.Documents.Open(sTemplate)
If iKeyTemplates = 5 Then
Else
If Sheets("CalcSheet").Range("B3").Value = True Then
wdDoc.ChangePic sCompLogoPic
Else
wdDoc.ChangePic sCompLogoPicBlank
End If
End If

Select Case iKeyTemplates

Case 1
Set objAcctName = Sheets("CalcSheet").Range("B1")
Set objCoName = Sheets("CalcSheet").Range("B2")
Set objContact = Sheets("CalcSheet").Range("B9")
Set objConTitle = Sheets("CalcSheet").Range("B10")
Set objConPh = Sheets("CalcSheet").Range("B11")
Set objBillAdd1 = Sheets("CalcSheet").Range("B12")
Set objBillAdd2 = Sheets("CalcSheet").Range("B13")
Set objBillAdd3 = Sheets("CalcSheet").Range("B17")
Set objAE = Sheets("CalcSheet").Range("B18")
Set objSqft = Sheets("CalcSheet").Range("B19")
Set objRate = Sheets("CalcSheet").Range("B20")

iVal = 1
For iVal = 1 To 10
Set objAcct(iVal) = Sheets("CalcSheet").Range("B" & iVal + 30)
Next iVal

With wdDoc
For i = 1 To .ContentControls.Count
Select Case .ContentControls(i).Title
Case "Account Name"
Set txtAcctName = wdDoc.ContentControls(i).Range
txtAcctName.Text = objAcctName
Set txtAcctName = Nothing
Set objAcctName = Nothing
Case "CompanyName"
Set txtCoName = wdDoc.ContentControls(i).Range
txtCoName.Text = objCoName
Set txtCoName = Nothing
Set objCoName = Nothing
Case "Contact"
Set txtContact = wdDoc.ContentControls(i).Range
txtContact.Text = objContact
Set txtContact = Nothing
Set objContact = Nothing
Case "ContactTitle"
Set txtConTitle = wdDoc.ContentControls(i).Range
txtConTitle.Text = objConTitle
Set txtConTitle = Nothing
Set objConTitle = Nothing
Case "ContactPhone"
Set txtConPh = wdDoc.ContentControls(i).Range
txtConPh.Text = objConPh
Set txtConPh = Nothing
Set objConPh = Nothing
Case "BillingAddress1"
Set txtBillAdd1 = wdDoc.ContentControls(i).Range
txtBillAdd1.Text = objBillAdd1
Set txtBillAdd1 = Nothing
Set objBillAdd1 = Nothing

[bg18461]

PART B:


Case "BillingAddress2"
Set txtBillAdd2 = wdDoc.ContentControls(i).Range
txtBillAdd2.Text = objBillAdd2
Set txtBillAdd2 = Nothing
Set objBillAdd2 = Nothing
Case "BillingAddress3"
Set txtBillAdd3 = wdDoc.ContentControls(i).Range
txtBillAdd3.Text = objBillAdd3
Set txtBillAdd3 = Nothing
Set objBillAdd3 = Nothing
Case "PEAcctExe"
Set txtAE = wdDoc.ContentControls(i).Range
txtAE.Text = objAE
Set txtAE = Nothing
Set objAE = Nothing
Case "Acct Num 1"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Acct Num 2"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Acct Num 3"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Acct Num 4"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Acct Num 5"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Acct Num 6"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Acct Num 7"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Acct Num 8"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Acct Num 9"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Acct Num 10"
Set txtAcct = wdDoc.ContentControls(i).Range
txtAcct.Text = objAcct(i - 9)
Case "Facility SqFt"
Set txtSqft = wdDoc.ContentControls(i).Range
txtSqft.Text = objSqft
Set txtSqft = Nothing
Set objSqft = Nothing
Case "Rate"
Set txtRate = wdDoc.ContentControls(i).Range
txtRate.Text = objRate
Set txtRate = Nothing
Set objRate = Nothing
End Select
Next

Set txtAcct = Nothing
For i = 1 To 10
Set objAcct(i) = Nothing
Next i
End With

Case 2
Set objEcologyCost = Sheets("CalcSheet").Range("I50")
Set objCostIndex = Sheets("CalcSheet").Range("I51")
Set objCost = Sheets("CalcSheet").Range("I52")
Set objUmIndex = Sheets("CalcSheet").Range("I53")
Set objLFac = Sheets("CalcSheet").Range("I54")

Set objBasisUnit = Sheets("CalcSheet").Range("I60")
Set objCostUnit = Sheets("CalcSheet").Range("I61")
Set objECostUnit = Sheets("CalcSheet").Range("I62")
Set txtCostSum = wdDoc.ContentControls(1).Range
Set txtEcologyCostSum = wdDoc.ContentControls(3).Range
Set txtBasisUnit = wdDoc.ContentControls(4).Range
Set txtUmbIndexSum = wdDoc.ContentControls(5).Range
Set txtCostUnit = wdDoc.ContentControls(6).Range
Set txtCostIndexSum = wdDoc.ContentControls(7).Range
Set txtECostUnit = wdDoc.ContentControls(8).Range
Set txtLFac = wdDoc.ContentControls(9).Range

txtCostSum.Text = Format(objCost, "#,##0")
txtEcologyCostSum.Text = Format(objEcologyCost, "#,##0")
txtBasisUnit.Text = objBasisUnit
txtUmbIndexSum.Text = Format(objUmIndex, "#,##0.00")
txtCostUnit.Text = objCostUnit
txtCostIndexSum.Text = Format(objCostIndex, "#,##0.00")
txtECostUnit.Text = objECostUnit
txtLFac.Text = Format(objLFac, "Percent")

Set txtCostSum = Nothing
Set txtEcologyCostSum = Nothing
Set txtUmbIndexSum = Nothing
Set txtCostIndexSum = Nothing
Set txtLFac = Nothing
Set txtBasisUnit = Nothing
Set txtCostUnit = Nothing
Set txtECostUnit = Nothing

Set objEcologyCost = Nothing
Set objCostIndex = Nothing

[bg18461]

PART C:


Set objCost = Nothing
Set objUmIndex = Nothing
Set objLFac = Nothing

Set objBasisUnit = Nothing
Set objCostUnit = Nothing
Set objECostUnit = Nothing

iCount = 1

For iVal = 4 To 20
If Sheets("CalcSheet").Range("P" & iVal).Value = True Then
Set objImprov = Sheets("CalcSheet").Range("O" & iVal)
Set txtImprov = wdDoc.ContentControls(iCount + 9).Range
sImprovHyperLink = Sheets("CalcSheet").Range("R" & iVal).Value

txtImprov.Text = objImprov
wdApp.ActiveDocument.Hyperlinks.Add Anchor:=txtImprov, Address:= _
sImprovHyperLink, SubAddress:="", ScreenTip:="", TextToDisplay:=""
sBulletBkMrk = "Improv" & iCount

Set bulletLoc = wdDoc.Goto(what:=wdGoToBookmark, Name:=sBulletBkMrk)

wdApp.ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1). _
ApplyPictureBullet Filename:= _
"\\rt122\VA443\Report TEMPLATE LIBRARY\Misc Images\EE BulletPoint.JPG"

wdApp.ListGalleries(wdBulletGallery).ListTemplates(1).Name = ""

bulletLoc.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _
ListGalleries(wdBulletGallery).ListTemplates(1), ContinuePreviousList:= _
False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:= _
wdWord10ListBehavior

iCount = iCount + 1
End If
Next iVal
Set objImprov = Nothing
Set txtImprov = Nothing
Set bulletLoc = Nothing

Case 3

Set myNamed = Sheets("Ecology His").Range("Table1")
Set wdInfo = wdDoc.Goto(what:=wdGoToBookmark, Name:="Table1")

Set objCoName = Sheets("CalcSheet").Range("B2")
Set objCostIndexUnit = Sheets("Ecology His").Range("AR53")
Set objUmIndeUnit = Sheets("Ecology His").Range("AS53")

Set txtCoName1 = wdDoc.ContentControls(1).Range
Set txtCoName2 = wdDoc.ContentControls(2).Range
Set txtCostIndexUnit = wdDoc.ContentControls(3).Range
Set txtUmIndeUnit = wdDoc.ContentControls(4).Range

'Copy Table1 (Ecology History) from Excel
myNamed.Copy

'Paste Table1 (Ecology History) into Word
wdInfo.PasteSpCostIndexal link:=False, _
DataType:=2, _
Placement:=0, DisplayAsIcon:=False

txtCoName1.Text = objCoName
txtCoName2.Text = objCoName

txtCostIndexUnit.Text = objCostIndexUnit
txtUmIndeUnit.Text = objUmIndeUnit

Set theChart = Sheets("Ecology His").ChartObjects("Chart 8")
theChart.Chart.ChartArea.Copy

Set wdInfo = wdDoc.Goto(what:=wdGoToBookmark, Name:="Chart1a")

With wdInfo
.PasteSpCostIndexal link:=False, DataType:=wdPasteEnhancedMetafile, Placement:= _
wdFloatOverText, DisplayAsIcon:=False
End With

[bg18461]

PART D:


With wdDoc.Shapes(wdDoc.Shapes.Count)
.LockAspectRatio = msoFalse
.Height = 344
.Width = 564.75
End With

Set myNamed = Sheets("Ecology His").Range("Table2")
Set wdInfo = wdDoc.Goto(what:=wdGoToBookmark, Name:="Table2")

myNamed.Copy

wdInfo.PasteSpCostIndexal link:=False, _
DataType:=2, _
Placement:=0, DisplayAsIcon:=False

Set theChart = Sheets("Ecology His").ChartObjects("Chart 6")
theChart.Chart.ChartArea.Copy
Set wdInfo = wdDoc.Goto(what:=wdGoToBookmark, Name:="Chart2a")

With wdInfo
.PasteSpCostIndexal link:=False, DataType:=wdPasteEnhancedMetafile, Placement:= _
wdFloatOverText, DisplayAsIcon:=False
End With

With wdDoc.Shapes(wdDoc.Shapes.Count)
.LockAspectRatio = msoFalse
.Height = 344
.Width = 564.75
End With

Set myNamed = Sheets("Billing Profile").Range("BillProfile1Top")
Set wdInfo = wdDoc.Goto(what:=wdGoToBookmark, Name:="ProfileTop")

myNamed.Copy

With wdInfo
.PasteSpCostIndexal link:=False, DataType:=wdPasteEnhancedMetafile, Placement:= _
wdInLine, DisplayAsIcon:=False
End With

With Sheets("Billing Profile")
With .Shapes.Range(Array("Chart 4", "Chart 3")).Group
.Copy
.Ungroup
End With
End With

Set wdInfo = wdDoc.Goto(what:=wdGoToBookmark, Name:="ProfileBottom")

With wdInfo
.PasteSpCostIndexal link:=False, DataType:=wdPasteEnhancedMetafile, Placement:= _
wdInLine, DisplayAsIcon:=False
End With

Set myNamed = Sheets("Billing Profile").Range("BillProfile2Top")
Set wdInfo = wdDoc.Goto(what:=wdGoToBookmark, Name:="ProfileTop2")
myNamed.Copy

With wdInfo
.PasteSpCostIndexal link:=False, DataType:=wdPasteEnhancedMetafile, Placement:= _
wdInLine, DisplayAsIcon:=False
End With

With Sheets("Billing Profile")
With .Shapes.Range(Array("Chart 7", "Chart 8", "Chart 10")).Group
.Copy
.Ungroup
End With
End With

Set wdInfo = wdDoc.Goto(what:=wdGoToBookmark, Name:="ProfileBottom2")

With wdInfo
.PasteSpCostIndexal link:=False, DataType:=wdPasteEnhancedMetafile, Placement:= _
wdInLine, DisplayAsIcon:=False
End With
Set myNamed = Nothing
Set wdInfo = Nothing

Set txtCoName1 = Nothing
Set txtCoName2 = Nothing
Set txtCostIndexUnit = Nothing
Set txtUmIndeUnit = Nothing
Set objCoName = Nothing
Set objCostIndexUnit = Nothing
Set objUmIndeUnit = Nothing
Set theChart = Nothing

Case 5
thisReportPath = Sheets("CalcSheet").Range("N9").Value
iFileCount = Sheets("CalcSheet").Range("N13").Value
wdDoc.InsertDocs iFileCount, thisReportPath

End Select

With wdApp.ActiveDocument
.Save
.Close
End With

wdApp.Quit

[bg18461]

PART E:


Set wdDoc = Nothing
Set wdApp = Nothing

Exit Sub

FormatTemplates_Error:
wdApp.Quit
Resume Next

End Sub