Writing Word Document from Access VBA

  • Thread starter Thread starter Rob Knowlan
  • Start date Start date
R

Rob Knowlan

I've created a function that reads data from a recordset and writes it to a
collection of tables in a word document. The document is arranged so that
each page will have 12 of these tables (4 rows of 3). There are 50+ sites,
so it winds up being about 4½ pages. Unfortunately, during the 15th table,
my MS word crashes. This worked fine in Enterprise 2007, but not in
Professional 2007 SP2. Any ideas?
 
Here's the source for the aforementioned problem
===================================
Public Sub ExportDEPBugSheetToMSWord(sYear As String, Optional lSampleID As
Long)

'Declare variables
Dim sSQL As String
Dim rs As Recordset
Dim blRSOpen As Boolean
Dim lCurrentRecord As Long
Dim lRecordCount As Long
Dim rs2 As Recordset
Dim blRS2Open As Boolean
Dim lRecordCount2 As Long
Dim dblModBeck As Double
Dim dblEPTTaxa As Double
Dim dblTaxaRich As Double
Dim dblShannon As Double
Dim dblHilsenhoff As Double
Dim dblPctIntolerant As Double
Dim dblBeck4 As Double
Dim dblCaddisfly As Double
Dim dblMayfly As Double
Dim dblIBIScore As Double
Dim lRow As Long
Dim lCol As Long
Dim sStatusBar As String
Dim oApp As Word.Application
Dim oWord As Word.Document
Dim oSelection As Word.Selection
Dim oSec As Word.Section
Dim oRange As Word.Range
Dim otblBlueBox As Word.Table
Dim otblIdentifier As Word.Table
Dim otblMetrics As Word.Table
Dim sTest As String
Dim otblTaxa As Word.Table
Dim blWrapTaxaTable As Boolean
Dim sCurrentTaxaOrderGroup As String
Dim lTaxaRow As Long
Dim lLoop As Long
Dim otblStandEq As Word.Table
Dim sHeader As String
Dim sDocName As String
Dim sDocQualifier As String

On Error GoTo ExportDEPBugSheetToMSWord_EH

'Initialize IBI Score values
dblModBeck = 0
dblEPTTaxa = 0
dblTaxaRich = 0
dblShannon = 0
dblHilsenhoff = 0
dblPctIntolerant = 0
dblBeck4 = 0
dblCaddisfly = 0
dblMayfly = 0
dblIBIScore = 0

'Set mouse to hourglass
Screen.MousePointer = gcHourGlass

'Set prep message in status bar
SysCmd acSysCmdInitMeter, "Gathering " & sYear & _
" Benthic Macroinvertebrate Sample Data for Word Document", 3

'Get record
SysCmd acSysCmdUpdateMeter, 1
sSQL = "SELECT SiteLocation, StationID, "
sSQL = sSQL & "sample_id, method_id, MethodDesc, SiteID "
sSQL = sSQL & "FROM qryDEPBugSheet "
If lSampleID > 0 Then
sSQL = sSQL & "WHERE sample_id=" & lSampleID & " "
Else
sSQL = sSQL & "WHERE SampleYear=" & sYear & " "
End If 'lSampleID > 0
sSQL = sSQL & "ORDER BY SampleDtTm "
Set rs = modData.GetRecordset(sSQL)
blRSOpen = True
If Not rs.EOF Then

rs.MoveLast
rs.MoveFirst
lCurrentRecord = 0
lRecordCount = rs.RecordCount

'Get the sample-specific qualifier string
If lSampleID > 0 Then
sDocQualifier = rs.Fields("SiteID") & "-"
Else
sDocQualifier = ""
End If 'lSampleID > 0

'Create new Executive Summary Document
Set oApp = _
CreateObject("Word.Application")
Set oWord = oApp.Documents.Add

'Page setup
oWord.PageSetup.TopMargin = InchesToPoints(1)
oWord.PageSetup.BottomMargin = InchesToPoints(1)
oWord.PageSetup.LeftMargin = InchesToPoints(1)
oWord.PageSetup.RightMargin = InchesToPoints(1)
oWord.PageSetup.Gutter = InchesToPoints(0)
oWord.PageSetup.HeaderDistance = InchesToPoints(0.5)
oWord.PageSetup.FooterDistance = InchesToPoints(0.5)
oWord.PageSetup.PageWidth = InchesToPoints(8.5)
oWord.PageSetup.PageHeight = InchesToPoints(11)

Set oSelection = oApp.Selection

'Write data to MS Word
While Not rs.EOF

'Set default paragraph formatting
oSelection.ParagraphFormat.Space1
oSelection.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
oSelection.ParagraphFormat.SpaceAfter = 0
oSelection.ParagraphFormat.SpaceBefore = 0

'Blue Header Box
oSelection.Font.Size = 12
oSelection.Font.Bold = True
oSelection.Font.Color = wdColorWhite
Set otblBlueBox = oWord.Tables.Add(oSelection.Range, 5, 1)

'Style
otblBlueBox.PreferredWidthType = wdPreferredWidthPercent
otblBlueBox.Columns(1).PreferredWidth = 100
otblBlueBox.Shading.BackgroundPatternColor = -553582593
'Office 2007 Dark Azure-Blue
otblBlueBox.Borders(wdBorderHorizontal).LineStyle =
wdLineStyleNone
otblBlueBox.Borders(wdBorderDiagonalDown).LineStyle =
wdLineStyleNone
otblBlueBox.Borders(wdBorderDiagonalUp).LineStyle =
wdLineStyleNone
otblBlueBox.Borders(wdBorderLeft).LineStyle =
wdLineStyleEmboss3D
otblBlueBox.Borders(wdBorderLeft).LineWidth = wdLineWidth300pt
otblBlueBox.Borders(wdBorderRight).LineStyle =
wdLineStyleEngrave3D
otblBlueBox.Borders(wdBorderRight).LineWidth =
wdLineWidth300pt
otblBlueBox.Borders(wdBorderTop).LineStyle =
wdLineStyleEmboss3D
otblBlueBox.Borders(wdBorderTop).LineWidth = wdLineWidth300pt
otblBlueBox.Borders(wdBorderBottom).LineStyle =
wdLineStyleEngrave3D
otblBlueBox.Borders(wdBorderBottom).LineWidth =
wdLineWidth300pt

'Title
oSelection.Font.Size = 18
otblBlueBox.Cell(1, 1).Range.InsertAfter "Macroinvertebrate
Sample Summary"
oSelection.Font.Size = 12

'Identification Section
Set otblIdentifier = oWord.Tables.Add(otblBlueBox.Cell(3,
1).Range, 3, 2)
If otblIdentifier.Rows.Count = 1 Then
otblIdentifier.Rows.Add
otblIdentifier.Rows.Add
End If 'otblIdentifier.Rows.Count = 1
otblIdentifier.PreferredWidthType = wdPreferredWidthPoints
otblIdentifier.Columns(1).PreferredWidth = InchesToPoints(1)
otblIdentifier.Columns(2).PreferredWidth = InchesToPoints(6.5)
otblIdentifier.Cell(1, 1).Range.InsertAfter "Station ID:"
otblIdentifier.Cell(1, 2).Range.InsertAfter
rs.Fields("StationID")
otblIdentifier.Cell(2, 1).Range.InsertAfter "Method:"
otblIdentifier.Cell(2, 2).Range.InsertAfter
rs.Fields("MethodDesc")
otblIdentifier.Cell(3, 1).Range.InsertAfter "Location:"
otblIdentifier.Cell(3, 2).Range.InsertAfter
rs.Fields("SiteLocation")
Set otblIdentifier = Nothing

'Metrics Table
Set otblMetrics = oWord.Tables.Add(otblBlueBox.Cell(5,
1).Range, 2, 3)
If otblMetrics.Rows.Count = 1 Then
otblMetrics.Rows.Add
End If 'otblMetrics.Rows.Count = 1
'''otblMetrics.PreferredWidthType = wdPreferredWidthPoints
sSQL = "SELECT tblSampleTests.test_id,
tblSampleTests.sample_id, "
sSQL = sSQL & "tblSampleTests.test_type_id,
LU_TestTypes.Test_Type AS Test, "
sSQL = sSQL & "IIf(Nz(LU_TestTypes.Test_Units,'')='List',"
sSQL = sSQL &
"GetListScore(LU_TestTypes.Test_Type,Nz(tblSampleTests.Score)),"
sSQL = sSQL & "IIf(Nz(LU_TestTypes.Test_Units,'')='Ratio',"
sSQL = sSQL & "IIf(Nz(tblSampleTests.test_type_id,0)=8,"
sSQL = sSQL & "Shredder2Insect(tblSampleTests.sample_id),"
sSQL = sSQL & "Decimal2Ratio(Nz(tblSampleTests.Score,0))),"
sSQL = sSQL &
"IIf(Nz(LU_TestTypes.Test_Units,'')='Percentage',"
sSQL = sSQL & "(Round((tblSampleTests.Score*100),2) & '%'),"
sSQL = sSQL & "Round(tblSampleTests.Score,2)))) AS Score, "
sSQL = sSQL & "LU_TestTypes.Test_Units AS Unit,
tblSampleTests.Notes "
sSQL = sSQL & "FROM tblSampleTests LEFT JOIN LU_TestTypes "
sSQL = sSQL & "ON
tblSampleTests.test_type_id=LU_TestTypes.test_type_id "
sSQL = sSQL & "WHERE LU_TestTypes.test_category_id=1 "
sSQL = sSQL & "AND tblSampleTests.sample_id=" &
rs.Fields("sample_id") & " "
sSQL = sSQL & "ORDER BY tblSampleTests.test_type_id "
Set rs2 = modData.GetRecordset(sSQL)
blRS2Open = True
While Not rs2.EOF
If rs.Fields("method_id") = 1 Then
'6-DFrame/Riffle-Run
Select Case rs2.Fields("test_type_id")
Case 87 'Modified Beck's Index
lRow = 1
lCol = 1
sTest = "Modified Beck's Index"
dblModBeck = rs2.Fields("Score")
Case 2 'Total Taxa
lRow = 1
lCol = 2
sTest = "Total Taxa"
dblTaxaRich = rs2.Fields("Score")
Case 6 'EPT Index
lRow = 1
lCol = 3
sTest = "EPT Taxa Richness"
dblEPTTaxa = rs2.Fields("Score")
Case 88 'Shannon Diversity Index
lRow = 2
lCol = 1
sTest = "Shannon Diversity"
dblShannon = rs2.Fields("Score")
Case 5 'Modified Hilsenhoff Biotic Index
lRow = 2
lCol = 2
sTest = "Hilsenhoff Biotic Index"
dblHilsenhoff = rs2.Fields("Score")
Case 7 'Percent Intolerant Taxa
lRow = 2
lCol = 3
sTest = "Percent Intolerant Individuals"
dblPctIntolerant = Left(rs2.Fields("Score"),
(InStr(rs2.Fields("Score"), "%") - 1))
Case Else
lRow = 0
lCol = 0
sTest = ""
End Select 'rs2.Fields("test_type_id")
Else
'10-DFrame/Multihabitat
Select Case rs2.Fields("test_type_id")
Case 88 'Shannon Diversity Index
lRow = 1
lCol = 1
sTest = "Shannon Diversity Index"
dblShannon = rs2.Fields("Score")
Case 2 'Total Taxa
lRow = 1
lCol = 2
sTest = "Taxa Richness"
dblTaxaRich = rs2.Fields("Score")
Case 6 'EPT Index
lRow = 1
lCol = 3
sTest = "EPT Taxa Richness"
dblEPTTaxa = rs2.Fields("Score")
Case 91 '# of Mayfly Taxa
lRow = 2
lCol = 1
sTest = "# Mayfly Taxa"
dblMayfly = rs2.Fields("Score")
Case 90 '# of Caddisfly Taxa
lRow = 2
lCol = 2
sTest = "# Caddisfly Taxa"
dblCaddisfly = rs2.Fields("Score")
Case 89 'Beck4
lRow = 2
lCol = 3
sTest = "Beck4"
dblBeck4 = rs2.Fields("Score")
Case 5 'Modified Hilsenhoff Biotic Index
lRow = 0
lCol = 0
sTest = ""
dblHilsenhoff = rs2.Fields("Score")
Case 7 'Percent Intolerant Taxa
lRow = 0
lCol = 0
sTest = ""
dblPctIntolerant = Left(rs2.Fields("Score"),
(InStr(rs2.Fields("Score"), "%") - 1))
Case 87 'Modified Beck's Index
lRow = 0
lCol = 0
sTest = ""
dblModBeck = rs2.Fields("Score")
Case Else
lRow = 0
lCol = 0
sTest = ""
End Select 'rs2.Fields("test_type_id")
End If 'rs.Fields("method_id") = 1
If lRow > 0 And lCol > 0 Then
otblMetrics.Cell(lRow, lCol).Range.InsertAfter _
sTest & ": " & rs2.Fields("Score")
End If 'lRow > 0 And lCol > 0
rs2.MoveNext
Wend 'rs2.EOF
rs2.Close
Set rs2 = Nothing
blRS2Open = False
Set otblMetrics = Nothing
Set otblBlueBox = Nothing
oSelection.EndKey Unit:=wdStory
oSelection.Font.Size = 10
oSelection.Font.Bold = False
oSelection.Font.Color = wdColorBlack
oSelection.TypeParagraph

'Taxa Table
sSQL = "SELECT GetSciOrderGroup(lT.taxa_id, lT.SciClassCd) AS
OrderGroup, "
sSQL = sSQL & "IIf(Nz(lT.SciClassCd,'')='','',"
sSQL = sSQL & "IIf(Nz(lT.SciClassCd,'')='P','Phylum ',"
sSQL = sSQL & "IIf(Nz(lT.SciClassCd,'')='C','Class ',"
sSQL = sSQL & "IIf(Nz(lT.SciClassCd,'')='O','Order ',"
sSQL = sSQL & "IIf(Nz(lT.SciClassCd,'')='F','Family ',"
sSQL = sSQL & "IIf(Nz(lT.SciClassCd,'')='G','Genus ',"
sSQL = sSQL & "IIf(Nz(lT.SciClassCd,'')='S','Species ',"
sSQL = sSQL & "'SubSpecies '))))))) & lT.TaxaName AS Taxon, "
sSQL = sSQL & "ST.TaxaCount, lT.Tolerance, lT.TrophicCd, "
sSQL = sSQL & "SciClassSort(lT.SciClassCd) AS ScientificOrder "
sSQL = sSQL & "FROM tblSampleTaxa AS ST INNER JOIN LU_Taxa AS lT "
sSQL = sSQL & "ON ST.taxa_id = lT.taxa_id "
sSQL = sSQL & "WHERE sample_id=" & rs.Fields("sample_id") & " "
sSQL = sSQL & "ORDER BY GetSciOrderGroup(lT.taxa_id,
lT.SciClassCd), "
sSQL = sSQL & "SciClassSort(lT.SciClassCd), lT.TaxaName "
Set rs2 = modData.GetRecordset(sSQL)
blRS2Open = True
If Not rs2.EOF Then
rs2.MoveLast
rs2.MoveFirst
lRecordCount2 = rs2.RecordCount
'Set a maximum of 14 content rows (not including column
headers)
If lRecordCount2 < 15 Then
Set otblTaxa = oWord.Tables.Add(oSelection.Range,
(lRecordCount2 + 1), 5)
blWrapTaxaTable = False
Else
Set otblTaxa = oWord.Tables.Add(oSelection.Range,
(Fix((lRecordCount2 + 1) / 2) + 1), 10)
blWrapTaxaTable = True
End If 'lRecordCount2 < 15
'Enter table data
otblTaxa.Rows(1).Range.Font.Bold = True
otblTaxa.Cell(1, 1).Range.Font.Size = 11
otblTaxa.Cell(1, 1).Range.InsertAfter "Taxa"
otblTaxa.Cell(1, 3).Range.Font.Size = 8
otblTaxa.Cell(1, 3).Range.InsertAfter "Number"
otblTaxa.Cell(1, 4).Range.Font.Size = 8
otblTaxa.Cell(1, 4).Range.InsertAfter "Tolerance"
otblTaxa.Cell(1, 5).Range.Font.Size = 8
otblTaxa.Cell(1, 5).Range.InsertAfter "Trophic Code"
If blWrapTaxaTable = True Then
otblTaxa.Cell(1, 8).Range.Font.Size = 8
otblTaxa.Cell(1, 8).Range.InsertAfter "Number"
otblTaxa.Cell(1, 9).Range.Font.Size = 8
otblTaxa.Cell(1, 9).Range.InsertAfter "Tolerance"
otblTaxa.Cell(1, 10).Range.Font.Size = 8
otblTaxa.Cell(1, 10).Range.InsertAfter "Trophic Code"
End If 'blWrapTaxaTable = True
lRow = 2
While Not rs2.EOF
If lRow <= otblTaxa.Rows.Count Then
otblTaxa.Cell(lRow, 1).Range.Font.Size = 8
If sCurrentTaxaOrderGroup <>
Nz(rs2.Fields("OrderGroup"), "") Then
otblTaxa.Cell(lRow, 1).Range.Font.Bold = True
otblTaxa.Cell(lRow, 1).Range.InsertAfter
Nz(rs2.Fields("OrderGroup"), "")
End If 'sCurrentTaxaOrderGroup <>
Nz(rs2.Fields("OrderGroup"), "")
otblTaxa.Cell(lRow, 2).Range.Font.Size = 8
otblTaxa.Cell(lRow, 2).Range.InsertAfter
Nz(rs2.Fields("Taxon"), "")
otblTaxa.Cell(lRow, 3).Range.Font.Size = 8
otblTaxa.Cell(lRow, 3).Range.InsertAfter
Nz(rs2.Fields("TaxaCount"), "")
otblTaxa.Cell(lRow, 4).Range.Font.Size = 8
otblTaxa.Cell(lRow, 4).Range.InsertAfter
Nz(rs2.Fields("Tolerance"), "")
otblTaxa.Cell(lRow, 5).Range.Font.Size = 8
otblTaxa.Cell(lRow, 5).Range.InsertAfter
Nz(rs2.Fields("TrophicCd"), "")
Else
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count - 1)),
6).Range.Font.Size = 8
If (lRow - (otblTaxa.Rows.Count - 1)) = 2 Then
'Repeat current group header when wrapping
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count -
1)), 6).Range.Font.Bold = True
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count -
1)), 6).Range.InsertAfter Nz(rs2.Fields("OrderGroup"), "")
Else
If sCurrentTaxaOrderGroup <>
Nz(rs2.Fields("OrderGroup"), "") Then
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count -
1)), 6).Range.Font.Bold = True
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count -
1)), 6).Range.InsertAfter Nz(rs2.Fields("OrderGroup"), "")
End If 'sCurrentTaxaOrderGroup <>
Nz(rs2.Fields("OrderGroup"), "")
End If '(lRow - Fix((lRecordCount2 + 1) / 2)) = 2
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count - 1)),
7).Range.Font.Size = 8
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count - 1)),
7).Range.InsertAfter Nz(rs2.Fields("Taxon"), "")
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count - 1)),
8).Range.Font.Size = 8
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count - 1)),
8).Range.InsertAfter Nz(rs2.Fields("TaxaCount"), "")
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count - 1)),
9).Range.Font.Size = 8
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count - 1)),
9).Range.InsertAfter Nz(rs2.Fields("Tolerance"), "")
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count - 1)),
10).Range.Font.Size = 8
otblTaxa.Cell((lRow - (otblTaxa.Rows.Count - 1)),
10).Range.InsertAfter Nz(rs2.Fields("TrophicCd"), "")
End If 'lRow <= otblTaxa.Rows.Count
lRow = lRow + 1
sCurrentTaxaOrderGroup = Nz(rs2.Fields("OrderGroup"), "")
rs2.MoveNext
Wend
rs2.Close
Set rs2 = Nothing
blRS2Open = False
'Style the table
otblTaxa.PreferredWidthType = wdPreferredWidthPoints
otblTaxa.Columns(1).Width = InchesToPoints(0.8)
otblTaxa.Columns(2).Width = InchesToPoints(0.8)
otblTaxa.Columns(3).Width = InchesToPoints(0.5)
otblTaxa.Columns(4).Width = InchesToPoints(0.6)
otblTaxa.Columns(5).Width = InchesToPoints(0.5)
otblTaxa.Borders(wdBorderDiagonalDown).LineStyle =
wdLineStyleNone
otblTaxa.Borders(wdBorderDiagonalUp).LineStyle =
wdLineStyleNone
otblTaxa.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
otblTaxa.Borders(wdBorderLeft).LineWidth = wdLineWidth025pt
otblTaxa.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
otblTaxa.Borders(wdBorderRight).LineWidth = wdLineWidth025pt
otblTaxa.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
otblTaxa.Borders(wdBorderTop).LineWidth = wdLineWidth025pt
otblTaxa.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
otblTaxa.Borders(wdBorderBottom).LineWidth = wdLineWidth025pt
otblTaxa.Borders(wdBorderHorizontal).LineStyle =
wdLineStyleSingle
otblTaxa.Borders(wdBorderHorizontal).LineWidth =
wdLineWidth025pt
otblTaxa.Borders(wdBorderVertical).LineStyle =
wdLineStyleSingle
otblTaxa.Borders(wdBorderVertical).LineWidth =
wdLineWidth025pt
otblTaxa.Columns(1).Borders(wdBorderLeft).LineStyle =
wdLineStyleNone
otblTaxa.Columns(1).Borders(wdBorderHorizontal).LineStyle =
wdLineStyleNone
otblTaxa.Columns(1).Borders(wdBorderTop).LineStyle =
wdLineStyleNone
otblTaxa.Columns(1).Borders(wdBorderBottom).LineStyle =
wdLineStyleNone
otblTaxa.Columns(2).Borders(wdBorderLeft).LineStyle =
wdLineStyleNone
otblTaxa.Columns(2).Borders(wdBorderHorizontal).LineStyle =
wdLineStyleNone
otblTaxa.Columns(2).Borders(wdBorderTop).LineStyle =
wdLineStyleNone
otblTaxa.Columns(2).Borders(wdBorderBottom).LineStyle =
wdLineStyleNone
If blWrapTaxaTable = True Then
otblTaxa.Columns(6).Width = InchesToPoints(0.8)

otblTaxa.Columns(6).Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
otblTaxa.Columns(6).Borders(wdBorderTop).LineStyle =
wdLineStyleNone
otblTaxa.Columns(6).Borders(wdBorderBottom).LineStyle =
wdLineStyleNone
otblTaxa.Columns(7).Width = InchesToPoints(0.8)
otblTaxa.Columns(7).Borders(wdBorderLeft).LineStyle =
wdLineStyleNone

otblTaxa.Columns(7).Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone
otblTaxa.Columns(7).Borders(wdBorderTop).LineStyle =
wdLineStyleNone
otblTaxa.Columns(7).Borders(wdBorderBottom).LineStyle =
wdLineStyleNone
otblTaxa.Columns(8).Width = InchesToPoints(0.5)
otblTaxa.Columns(9).Width = InchesToPoints(0.6)
otblTaxa.Columns(10).Width = InchesToPoints(0.5)
End If 'blWrapTaxaTable = True
otblTaxa.AutoFitBehavior wdAutoFitContent
Set otblTaxa = Nothing
End If 'Not rs2.EOF
oSelection.EndKey Unit:=wdStory
oSelection.TypeParagraph
 
Here's the rest of it:
================

'Metric Standardization Equations Table
Set otblStandEq = oWord.Tables.Add(oSelection.Range, 9, 5)
otblStandEq.Range.Font.Size = 8
otblStandEq.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
otblStandEq.Borders(wdBorderBottom).LineWidth = wdLineWidth025pt
otblStandEq.Borders(wdBorderHorizontal).LineStyle =
wdLineStyleSingle
otblStandEq.Borders(wdBorderHorizontal).LineWidth =
wdLineWidth025pt
otblStandEq.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
otblStandEq.Borders(wdBorderLeft).LineWidth = wdLineWidth025pt
otblStandEq.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
otblStandEq.Borders(wdBorderRight).LineWidth = wdLineWidth025pt
otblStandEq.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
otblStandEq.Borders(wdBorderTop).LineWidth = wdLineWidth025pt
otblStandEq.Borders(wdBorderVertical).LineStyle =
wdLineStyleSingle
otblStandEq.Borders(wdBorderVertical).LineWidth = wdLineWidth025pt
'Make header row
otblStandEq.Rows(1).Cells.Merge
otblStandEq.Cell(1, 1).Range.Font.Size = 10
otblStandEq.Cell(1, 1).Range.InsertAfter "Metric Standardization
Equations"
otblStandEq.Rows(1).Range.ParagraphFormat.Alignment =
wdAlignParagraphCenter
'Make column headers row
otblStandEq.Rows(2).Range.Font.Bold = True
otblStandEq.Rows(2).Range.ParagraphFormat.Alignment =
wdAlignParagraphCenter
otblStandEq.Cell(2, 1).Range.InsertAfter "Metric"
otblStandEq.Cell(2, 2).Range.InsertAfter "Standardization
Equation"
otblStandEq.Cell(2, 3).Range.InsertAfter "Observed Metric Value"
If rs.Fields("method_id") = 1 Then
'Riffle/Run
otblStandEq.Cell(2, 4).Range.InsertAfter "Standardized
Metric Score"
otblStandEq.Cell(2, 5).Range.InsertAfter "Adjusted
Standardized Metric Score"
otblStandEq.Cell(2, 5).Range.InsertAfter vbCrLf & "Maximum =
1.000"
Else
'Multihabitat
otblStandEq.Cell(2, 4).Range.InsertAfter "Normalized Metric
Score"
otblStandEq.Cell(2, 5).Range.InsertAfter "Adjusted
Standardized Metric Score"
otblStandEq.Cell(2, 5).Range.InsertAfter vbCrLf & "Maximum =
100"
End If 'rs.Fields("method_id") = 1
'Fill static descriptive column values
If rs.Fields("method_id") = 1 Then
'Riffle/Run
otblStandEq.Cell(3, 1).Range.InsertAfter "Modified Beck's
Index"
otblStandEq.Cell(3, 2).Range.InsertAfter "Observed value / 39"
otblStandEq.Cell(4, 1).Range.InsertAfter "EPT Taxa Richness"
otblStandEq.Cell(4, 2).Range.InsertAfter "Observed value / 23"
otblStandEq.Cell(5, 1).Range.InsertAfter "Total Taxa Richness"
otblStandEq.Cell(5, 2).Range.InsertAfter "Observed value / 35"
otblStandEq.Cell(6, 1).Range.InsertAfter "Shannon Diversity
Index"
otblStandEq.Cell(6, 2).Range.InsertAfter "Observed value /
2.90"
otblStandEq.Cell(7, 1).Range.InsertAfter "Hilsenhoff Biotic
Index"
otblStandEq.Cell(7, 2).Range.InsertAfter "(10 - Observed
value) / (10 - 1.78)"
otblStandEq.Cell(8, 1).Range.InsertAfter "Percent Intolerant
Individuals"
otblStandEq.Cell(8, 2).Range.InsertAfter "Observed value /
92.5"
Else
'Multihabitat
otblStandEq.Cell(3, 1).Range.InsertAfter "EPT"
otblStandEq.Cell(3, 2).Range.InsertAfter "(Observed value /
17) × 100"
otblStandEq.Cell(4, 1).Range.InsertAfter "Taxa Richness"
otblStandEq.Cell(4, 2).Range.InsertAfter "(Observed value /
31) × 100"
otblStandEq.Cell(5, 1).Range.InsertAfter "Beck4"
otblStandEq.Cell(5, 2).Range.InsertAfter "(Observed value /
22) × 100"
otblStandEq.Cell(6, 1).Range.InsertAfter "Shannon Diversity
Index"
otblStandEq.Cell(6, 2).Range.InsertAfter "(Observed value /
2.43) × 100"
otblStandEq.Cell(7, 1).Range.InsertAfter "# Of Caddisfly Taxa"
otblStandEq.Cell(7, 2).Range.InsertAfter "(Observed value /
11) × 100"
otblStandEq.Cell(8, 1).Range.InsertAfter "# Of Mayfly Taxa"
otblStandEq.Cell(8, 2).Range.InsertAfter "(Observed value /
6) × 100"
End If 'rs.Fields("method_id") = 1
'Fill calculated values
If rs.Fields("method_id") = 1 Then
'Riffle/Run
otblStandEq.Cell(3, 3).Range.InsertAfter dblModBeck
otblStandEq.Cell(3, 4).Range.InsertAfter Round((dblModBeck /
39), 3)
If (dblModBeck / 39) > 1 Then
otblStandEq.Cell(3, 5).Range.InsertAfter "1.000"
dblIBIScore = 1
Else
otblStandEq.Cell(3, 5).Range.InsertAfter
Round((dblModBeck / 39), 3)
dblIBIScore = Round((dblModBeck / 39), 3)
End If '(dblModBeck / 39) > 1
otblStandEq.Cell(4, 3).Range.InsertAfter dblEPTTaxa
otblStandEq.Cell(4, 4).Range.InsertAfter Round((dblEPTTaxa /
23), 3)
If (dblEPTTaxa / 23) > 1 Then
otblStandEq.Cell(4, 5).Range.InsertAfter "1.000"
dblIBIScore = dblIBIScore + 1
Else
otblStandEq.Cell(4, 5).Range.InsertAfter
Round((dblEPTTaxa / 23), 3)
dblIBIScore = dblIBIScore + Round((dblEPTTaxa / 23), 3)
End If '(dblEPTTaxa / 23) > 1
otblStandEq.Cell(5, 3).Range.InsertAfter dblTaxaRich
otblStandEq.Cell(5, 4).Range.InsertAfter Round((dblTaxaRich
/ 35), 3)
If (dblTaxaRich / 35) > 1 Then
otblStandEq.Cell(5, 5).Range.InsertAfter "1.000"
dblIBIScore = dblIBIScore + 1
Else
otblStandEq.Cell(5, 5).Range.InsertAfter
Round((dblTaxaRich / 35), 3)
dblIBIScore = dblIBIScore + Round((dblTaxaRich / 35), 3)
End If '(dblTaxaRich / 35) > 1
otblStandEq.Cell(6, 3).Range.InsertAfter dblShannon
otblStandEq.Cell(6, 4).Range.InsertAfter Round((dblShannon /
2.9), 3)
If (dblShannon / 2.9) > 1 Then
otblStandEq.Cell(6, 5).Range.InsertAfter "1.000"
dblIBIScore = dblIBIScore + 1
Else
otblStandEq.Cell(6, 5).Range.InsertAfter
Round((dblShannon / 2.9), 3)
dblIBIScore = dblIBIScore + Round((dblShannon / 2.9), 3)
End If '(dblShannon / 2.9) > 1
otblStandEq.Cell(7, 3).Range.InsertAfter dblHilsenhoff
otblStandEq.Cell(7, 4).Range.InsertAfter Round(((10 -
dblHilsenhoff) / 8.22), 3)
If ((10 - dblHilsenhoff) / 8.22) > 1 Then
otblStandEq.Cell(7, 5).Range.InsertAfter "1.000"
dblIBIScore = dblIBIScore + 1
Else
otblStandEq.Cell(7, 5).Range.InsertAfter Round(((10 -
dblHilsenhoff) / 8.22), 3)
dblIBIScore = dblIBIScore + Round(((10 - dblHilsenhoff)
/ 8.22), 3)
End If '((10 - dblHilsenhoff) / 8.22) > 1
otblStandEq.Cell(8, 3).Range.InsertAfter dblPctIntolerant
otblStandEq.Cell(8, 4).Range.InsertAfter
Round((dblPctIntolerant / 92.5), 3)
If (dblPctIntolerant / 92.5) > 1 Then
otblStandEq.Cell(8, 5).Range.InsertAfter "1.000"
dblIBIScore = dblIBIScore + 1
Else
otblStandEq.Cell(8, 5).Range.InsertAfter
Round((dblPctIntolerant / 92.5), 3)
dblIBIScore = dblIBIScore + Round((dblPctIntolerant /
92.5), 3)
End If '(dblPctIntolerant / 92.5) > 1
'Calculate actual IBI Score
'Average of adjusted standardized core metric scores * 100
dblIBIScore = Round(((dblIBIScore / 6) * 100), 3)
Else
'Multihabitat
otblStandEq.Cell(3, 3).Range.InsertAfter dblEPTTaxa
otblStandEq.Cell(3, 4).Range.InsertAfter Round(((dblEPTTaxa
/ 17) * 100), 2)
If ((dblEPTTaxa / 17) * 100) > 100 Then
otblStandEq.Cell(3, 5).Range.InsertAfter "100"
dblIBIScore = 100
Else
otblStandEq.Cell(3, 5).Range.InsertAfter
Round(((dblEPTTaxa / 17) * 100), 2)
dblIBIScore = Round(((dblEPTTaxa / 17) * 100), 2)
End If '((dblEPTTaxa / 17) * 100) > 100
otblStandEq.Cell(4, 3).Range.InsertAfter dblTaxaRich
otblStandEq.Cell(4, 4).Range.InsertAfter Round(((dblTaxaRich
/ 31) * 100), 2)
If ((dblTaxaRich / 31) * 100) > 100 Then
otblStandEq.Cell(4, 5).Range.InsertAfter "100"
dblIBIScore = dblIBIScore + 100
Else
otblStandEq.Cell(4, 5).Range.InsertAfter
Round(((dblTaxaRich / 31) * 100), 2)
dblIBIScore = dblIBIScore + Round(((dblTaxaRich / 31) *
100), 2)
End If '((dblTaxaRich / 31) * 100) > 100
otblStandEq.Cell(5, 3).Range.InsertAfter dblBeck4
otblStandEq.Cell(5, 4).Range.InsertAfter Round(((dblBeck4 /
22) * 100), 2)
If ((dblBeck4 / 22) * 100) > 100 Then
otblStandEq.Cell(5, 5).Range.InsertAfter "100"
dblIBIScore = dblIBIScore + 100
Else
otblStandEq.Cell(5, 5).Range.InsertAfter
Round(((dblBeck4 / 22) * 100), 2)
dblIBIScore = dblIBIScore + Round(((dblBeck4 / 22) *
100), 2)
End If '((dblBeck4 / 22) * 100) > 100
otblStandEq.Cell(6, 3).Range.InsertAfter dblShannon
otblStandEq.Cell(6, 4).Range.InsertAfter Round(((dblShannon
/ 2.43) * 100), 2)
If ((dblShannon / 2.43) * 100) > 100 Then
otblStandEq.Cell(6, 5).Range.InsertAfter "100"
dblIBIScore = dblIBIScore + 100
Else
otblStandEq.Cell(6, 5).Range.InsertAfter
Round(((dblShannon / 2.43) * 100), 2)
dblIBIScore = dblIBIScore + Round(((dblShannon / 2.43) *
100), 2)
End If '((dblShannon / 2.43) * 100) > 100
otblStandEq.Cell(7, 3).Range.InsertAfter dblCaddisfly
otblStandEq.Cell(7, 4).Range.InsertAfter
Round(((dblCaddisfly / 11) * 100), 2)
If ((dblCaddisfly / 11) * 100) > 100 Then
otblStandEq.Cell(7, 5).Range.InsertAfter "100"
dblIBIScore = dblIBIScore + 100
Else
otblStandEq.Cell(7, 5).Range.InsertAfter
Round(((dblCaddisfly / 11) * 100), 2)
dblIBIScore = dblIBIScore + Round(((dblCaddisfly / 11) *
100), 2)
End If '((dblCaddisfly / 11) * 100) > 100
otblStandEq.Cell(8, 3).Range.InsertAfter dblMayfly
otblStandEq.Cell(8, 4).Range.InsertAfter Round(((dblMayfly /
6) * 100), 2)
If ((dblMayfly / 6) * 100) > 100 Then
otblStandEq.Cell(8, 5).Range.InsertAfter "100"
dblIBIScore = dblIBIScore + 100
Else
otblStandEq.Cell(8, 5).Range.InsertAfter
Round(((dblMayfly / 6) * 100), 2)
dblIBIScore = dblIBIScore + Round(((dblMayfly / 6) *
100), 2)
End If '((dblMayfly / 6) * 100) > 100
'Calculate actual IBI Score
'Average of adjusted normalized core metric scores
dblIBIScore = Round((dblIBIScore / 6), 2)
End If 'rs.Fields("method_id") = 1
'Make footer row
Dim orngStEqCols As Range
Set orngStEqCols = otblStandEq.Cell(9, 1).Range
orngStEqCols.End = otblStandEq.Cell(9, 4).Range.End
orngStEqCols.Cells.Merge
otblStandEq.Cell(9, 1).Range.Font.Bold = True
If rs.Fields("method_id") = 1 Then
'Riffle/Run
otblStandEq.Cell(9, 1).Range.InsertAfter "Average of
adjusted standardized core metric scores * 100 = "
otblStandEq.Cell(9, 1).Range.InsertAfter "IBI Score"
Else
'Multihabitat
otblStandEq.Cell(9, 1).Range.InsertAfter "Average of
adjusted normalized core metric scores = "
otblStandEq.Cell(9, 1).Range.InsertAfter "Total Biological
Score"
End If 'rs.Fields("method_id") = 1
otblStandEq.Cell(9, 2).Range.InsertAfter dblIBIScore
Set otblStandEq = Nothing

'Update status bar and move to next record
lCurrentRecord = lCurrentRecord + 1
sStatusBar = "Exporting Benthic Macroinvertebrate Sample Data To
MS Word: Page " & _
lCurrentRecord & " of " & lRecordCount
SysCmd acSysCmdInitMeter, sStatusBar, lRecordCount
SysCmd acSysCmdUpdateMeter, lCurrentRecord
rs.MoveNext
If Not rs.EOF Then
'Force new page for next record
oSelection.EndKey Unit:=wdStory, Extend:=wdMove
oSelection.Range.InsertBreak Type:=wdPageBreak
oSelection.EndKey Unit:=wdStory, Extend:=wdMove
End If 'Not rs.EOF

Wend

'Jump to the first page of the document
oSelection.HomeKey Unit:=wdStory, Extend:=wdMove

'Save the MS Word Document
sDocName = Environ("userprofile") & "\Desktop\" & sDocQualifier &
sYear & _
" DEP Macroinvertebrate Sample Summaries.doc"
oWord.SaveAs sDocName, wdFormatDocument
oApp.Visible = True

End If 'Not rs.EOF

ExportDEPBugSheetToMSWord_Exit:

If blRS2Open = True Then
rs2.Close
Set rs2 = Nothing
blRS2Open = False
End If 'blRS2Open = True

If blRSOpen = True Then
rs.Close
Set rs = Nothing
blRSOpen = False
Set oWord = Nothing
Set oApp = Nothing
End If 'blRSOpen = True

'Clear status bar
SysCmd acSysCmdClearStatus

Exit Sub 'ExportDEPBugSheetToMSWord

ExportDEPBugSheetToMSWord_EH:

'Handle error
ShowError "Exporting DEP Macroinvertebrate Sample Sheet to MS Word"
oWord.Close wdDoNotSaveChanges
Set oWord = Nothing
oApp.Quit wdDoNotSaveChanges
Set oApp = Nothing
Resume ExportDEPBugSheetToMSWord_Exit

End Sub 'ExportDEPBugSheetToMSWord
 
My mistake, the previous two were from another feature with a similar problem
*****************************************************************************

Public Sub ExportHabitatSummaryToMSWord(sYear As String, Optional lSampleID
As Long)

'Declare variables
Dim sSQL As String
Dim rs As Recordset
Dim blRSOpen As Boolean
Dim lCurrentRecord As Long
Dim lRecordCount As Long
Dim dblHabitatSum As Double
Dim rs2 As Recordset
Dim blRS2Open As Boolean
Dim lRecordCount2 As Long
Dim lLoop As Long
Dim sHeader As String
Dim sTest As String
Dim lRow As Long
Dim lCol As Long
Dim sStatusBar As String
Dim oApp As New Word.Application
Dim oWord As Word.Document
Dim oSelection As Word.Selection
Dim oSec As Word.Section
Dim oRange As Word.Range
Dim otblSiteData As Word.Table
Dim otblHabitat As Word.Table
Dim sDocName As String
Dim sDocQualifier As String

On Error GoTo ExportHabitatSummaryToMSWord_EH

'Set mouse to hourglass
Screen.MousePointer = gcHourGlass

'Set prep message in status bar
SysCmd acSysCmdInitMeter, "Gathering " & sYear & _
" Habitat Summary Data for Word Document", 3

'Set Row & Column indicators for hidden table
lRow = 1
lCol = 1

'Get record
SysCmd acSysCmdUpdateMeter, 1
sSQL = "SELECT Sm.sample_id, S.SiteID, Sm.method_id "
sSQL = sSQL & "FROM tblSamples AS Sm INNER JOIN tblSites AS S "
sSQL = sSQL & "ON Sm.site_id = S.site_id "
If Nz(lSampleID, 0) > 0 Then
sSQL = sSQL & "WHERE Sm.sample_id=" & lSampleID & " "
Else
sSQL = sSQL & "WHERE Year(Sm.SampleDtTm)=" & sYear & " "
End If 'Nz(lSampleID, 0) > 0
sSQL = sSQL & "ORDER BY Sm.SampleDtTm "
'''Debug.Print sSQL
Set rs = modData.GetRecordset(sSQL)
blRSOpen = True
If Not rs.EOF Then

rs.MoveLast
rs.MoveFirst
lCurrentRecord = 0
lRecordCount = rs.RecordCount

'Create new Executive Summary Document
Set oApp = CreateObject("Word.Application")
'''Set oApp = New Word.Application
Set oWord = oApp.Documents.Add

'Get the sample-specific qualifier string
If lSampleID > 0 Then
sDocQualifier = " for " & rs.Fields("SiteID") & "-"
Else
sDocQualifier = " "
End If 'lSampleID > 0

'Save the MS Word Document
sDocName = Environ("userprofile") & _
"\Desktop\Habitat Summary" & sDocQualifier & sYear & ".doc"
oWord.SaveAs sDocName
'''oApp.Visible = True

'Page setup
oWord.PageSetup.TopMargin = InchesToPoints(0.6)
oWord.PageSetup.BottomMargin = InchesToPoints(0.6)
oWord.PageSetup.LeftMargin = InchesToPoints(1)
oWord.PageSetup.RightMargin = InchesToPoints(1)
oWord.PageSetup.Gutter = InchesToPoints(0)
oWord.PageSetup.HeaderDistance = InchesToPoints(0.25)
oWord.PageSetup.FooterDistance = InchesToPoints(0.25)
oWord.PageSetup.PageWidth = InchesToPoints(8.5)
oWord.PageSetup.PageHeight = InchesToPoints(11)

Set oSelection = oApp.Selection

'Set default paragraph formatting
oSelection.ParagraphFormat.Space1
oSelection.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
oSelection.ParagraphFormat.SpaceAfter = 0
oSelection.ParagraphFormat.SpaceBefore = 0

'*** Invisible Content Framework Table ***
oSelection.Font.Size = 8
oSelection.Font.Bold = False
oSelection.Font.Color = wdColorBlack
Set otblSiteData = oWord.Tables.Add(oSelection.Range, 7, 1)

'Style
otblSiteData.PreferredWidthType = wdPreferredWidthPercent
otblSiteData.Columns(1).PreferredWidth = 100

'*** Split rows where content tables go ***
'Row 1 will be split in 3 for Habitat Summaries
otblSiteData.Rows(1).Cells.Split NumRows:=1, NumColumns:=3,
MergeBeforeSplit:=True
'Row 2 stays 1 column to act as a vertical spacer
otblSiteData.Rows(2).Height = InchesToPoints(0.05)
'Row 3 will be split in 3 for Habitat Summaries
otblSiteData.Rows(3).Cells.Split NumRows:=1, NumColumns:=3,
MergeBeforeSplit:=True
'Row 4 stays 1 column to act as a vertical spacer
otblSiteData.Rows(4).Height = InchesToPoints(0.05)
'Row 5 will be split in 3 for Habitat Summaries
otblSiteData.Rows(5).Cells.Split NumRows:=1, NumColumns:=3,
MergeBeforeSplit:=True
'Row 6 stays 1 column to act as a vertical spacer
otblSiteData.Rows(6).Height = InchesToPoints(0.05)
'Row 7 will be split in 3 for Habitat Summaries
otblSiteData.Rows(7).Cells.Split NumRows:=1, NumColumns:=3,
MergeBeforeSplit:=True
'*** Split rows where content tables go ***
 
Here's the rest of the habitat summary export to MS Word
******************************************

'Write data to MS Word
While Not rs.EOF

'*** Habitat Summary Table ***
sSQL = "SELECT lTT.Test_Type AS Test, Nz(ST.Score,0) AS
ShowScore "
sSQL = sSQL & "FROM tblSampleTests AS ST "
sSQL = sSQL & "LEFT JOIN LU_TestTypes AS lTT "
sSQL = sSQL & "ON ST.test_type_id=lTT.test_type_id "
sSQL = sSQL & "WHERE ST.sample_id=" & rs.Fields("sample_id")
& " "
If rs.Fields("method_id") = 1 Then
sSQL = sSQL & "AND lTT.test_type_id IN
(35,36,38,39,41,42,43,44,45,49,50,51) "
Else
sSQL = sSQL & "AND lTT.test_type_id IN
(36,37,38,39,41,42,43,45,48) "
End If 'rs.Fields("method_id") = 1
sSQL = sSQL & "ORDER BY ST.test_type_id "
'''Debug.Print sSQL
Set rs2 = modData.GetRecordset(sSQL)
blRS2Open = True
If Not rs2.EOF Then
rs2.MoveLast
rs2.MoveFirst
lRecordCount2 = rs2.RecordCount
Set otblHabitat =
oWord.Tables.Add(otblSiteData.Cell(lRow, lCol).Range, 1, 2)
If otblHabitat.Rows.Count = 1 Then
'MS Word doesn't seem to like to
'insert multi-row tables into table cells,
'so add more for data
For lLoop = 1 To lRecordCount2 + 2
otblHabitat.Rows.Add
Next lLoop
End If 'otblHabitat.Rows.Count = 1
otblHabitat.Borders(wdBorderBottom).LineStyle =
wdLineStyleSingle
otblHabitat.Borders(wdBorderBottom).LineWidth =
wdLineWidth025pt
otblHabitat.Borders(wdBorderHorizontal).LineStyle =
wdLineStyleSingle
otblHabitat.Borders(wdBorderHorizontal).LineWidth =
wdLineWidth025pt
otblHabitat.Borders(wdBorderLeft).LineStyle =
wdLineStyleSingle
otblHabitat.Borders(wdBorderLeft).LineWidth =
wdLineWidth025pt
otblHabitat.Borders(wdBorderRight).LineStyle =
wdLineStyleSingle
otblHabitat.Borders(wdBorderRight).LineWidth =
wdLineWidth025pt
otblHabitat.Borders(wdBorderTop).LineStyle =
wdLineStyleSingle
otblHabitat.Borders(wdBorderTop).LineWidth =
wdLineWidth025pt
otblHabitat.Borders(wdBorderVertical).LineStyle =
wdLineStyleSingle
otblHabitat.Borders(wdBorderVertical).LineWidth =
wdLineWidth025pt
'Make SiteID row
otblHabitat.Rows(1).Cells.Merge
otblHabitat.Cell(1, 1).Range.Font.Size = 10
otblHabitat.Cell(1, 1).Range.Font.Bold = True
otblHabitat.Cell(1,
1).Range.Shading.BackgroundPatternColor = wdColorGray25
otblHabitat.Cell(1, 1).Range.InsertAfter
rs.Fields("SiteID")
'Make header row
otblHabitat.Rows(2).Cells.Merge
otblHabitat.Cell(2, 1).Range.Font.Size = 9
otblHabitat.Cell(2, 1).Range.Font.Bold = True
otblHabitat.Cell(2,
1).Range.Shading.BackgroundPatternColor = wdColorGray25
otblHabitat.Cell(2, 1).Range.InsertAfter "Habitat Summary"
'Fill details
For lLoop = 3 To (otblHabitat.Rows.Count - 1)
otblHabitat.Cell(lLoop, 1).Range.Font.Bold = True
otblHabitat.Cell(lLoop, 1).Range.InsertAfter
Nz(rs2.Fields("Test"), "")
otblHabitat.Cell(lLoop, 2).Range.InsertAfter
Nz(rs2.Fields("ShowScore"), "")
dblHabitatSum = dblHabitatSum +
Nz(rs2.Fields("ShowScore"), 0)
rs2.MoveNext
Next lLoop
'Make footer row
otblHabitat.Cell(otblHabitat.Rows.Count,
1).Range.Font.Size = 9
otblHabitat.Cell(otblHabitat.Rows.Count,
1).Range.Font.Bold = True
otblHabitat.Cell(otblHabitat.Rows.Count,
1).Range.InsertAfter "Total Habitat Score"
otblHabitat.Cell(otblHabitat.Rows.Count,
2).Range.InsertAfter dblHabitatSum
otblHabitat.AutoFitBehavior wdAutoFitContent
Set otblHabitat = Nothing
dblHabitatSum = 0
End If 'Not rs2.EOF
rs2.Close
Set rs2 = Nothing
blRS2Open = False
'*** Habitat Summary Table ***

'*** Handle hidden table cell usage ***
Select Case lCol
Case 1
lCol = 2
Case 2
lCol = 3
Case 3
lCol = 1
If lRow = 7 Then
lRow = 1
'Force new page for next 15 samples
Set otblSiteData = Nothing
oSelection.EndKey Unit:=wdStory, Extend:=wdMove
oSelection.Range.InsertBreak Type:=wdPageBreak
oSelection.EndKey Unit:=wdStory, Extend:=wdMove
oSelection.Font.Size = 8
oSelection.Font.Bold = False
oSelection.Font.Color = wdColorBlack
Set otblSiteData =
oWord.Tables.Add(oSelection.Range, 7, 1)

'Style
otblSiteData.PreferredWidthType =
wdPreferredWidthPercent
otblSiteData.Columns(1).PreferredWidth = 100

'*** Split rows where content tables go ***
'Row 1 will be split in 3 for Habitat Summaries
otblSiteData.Rows(1).Cells.Split NumRows:=1,
NumColumns:=3, MergeBeforeSplit:=True
'Row 2 stays 1 column to act as a vertical spacer
otblSiteData.Rows(2).Height = InchesToPoints(0.05)
'Row 3 will be split in 3 for Habitat Summaries
otblSiteData.Rows(3).Cells.Split NumRows:=1,
NumColumns:=3, MergeBeforeSplit:=True
'Row 4 stays 1 column to act as a vertical spacer
otblSiteData.Rows(4).Height = InchesToPoints(0.05)
'Row 5 will be split in 3 for Habitat Summaries
otblSiteData.Rows(5).Cells.Split NumRows:=1,
NumColumns:=3, MergeBeforeSplit:=True
'Row 6 stays 1 column to act as a vertical spacer
otblSiteData.Rows(6).Height = InchesToPoints(0.05)
'Row 7 will be split in 3 for Habitat Summaries
otblSiteData.Rows(7).Cells.Split NumRows:=1,
NumColumns:=3, MergeBeforeSplit:=True
'*** Split rows where content tables go ***
Else
lRow = lRow + 2
End If '
End Select 'lCol
'*** Handle hidden table cell usage ***

'Update status bar and move to next record
lCurrentRecord = lCurrentRecord + 1
sStatusBar = "Exporting Habitat Summaries To MS Word: Sample
" & _
lCurrentRecord & " of " & lRecordCount
SysCmd acSysCmdInitMeter, sStatusBar, lRecordCount
SysCmd acSysCmdUpdateMeter, lCurrentRecord
oWord.Save

rs.MoveNext

Wend 'Not rs.EOF

'Jump to the first page of the document
oSelection.HomeKey Unit:=wdStory, Extend:=wdMove

'Close out of word
oWord.Close wdSaveChanges
Set oWord = Nothing
oApp.Quit wdDoNotSaveChanges
Set oApp = Nothing

End If 'Not rs.EOF

ExportHabitatSummaryToMSWord_Exit:

If blRS2Open = True Then
rs2.Close
Set rs2 = Nothing
blRS2Open = False
End If 'blRS2Open = True

If blRSOpen = True Then
rs.Close
Set rs = Nothing
blRSOpen = False
Set oWord = Nothing
Set oApp = Nothing
End If 'blRSOpen = True

'Clear status bar
SysCmd acSysCmdClearStatus

'Reset the mouse
Screen.MousePointer = gcDefault

Exit Sub 'ExportHabitatSummaryToMSWord

ExportHabitatSummaryToMSWord_EH:

'Handle error
ShowError "Exporting Habitat Summary to MS Word"
On Error Resume Next
oWord.Close wdDoNotSaveChanges
Set oWord = Nothing
oApp.Quit wdDoNotSaveChanges
Set oApp = Nothing
Resume ExportHabitatSummaryToMSWord_Exit

End Sub 'ExportHabitatSummaryToMSWord
 
Back
Top