Srhobbs
10-12-2011, 01:40 PM
Im trying to do a mail merge into word that would include pie charts. I have been able to figure out several errors so far but I'm getting stumped on this one:banghead: . I have pasted the code below and highlighted the problem I am unable to fix. I get a run time error (91). Help?: pray2:
Option Explicit
Public x As New Class1
Public BeforeMergeExecuted As Boolean
Public CancelMerge As Boolean
Public recordIndex As Long
Const ChartDataDoc As String = "constChartDataDocs.docx"
Sub MergeWithChart()
'Preset the global variables
BeforeMergeExecuted = False
CancelMerge = False
recordIndex = 1
'The events in the class module
'clsMergeEvents will be enabled
ActivateEvents
'As each record is merged
'the MailMergeBeforeMerge
'event will be called
ActiveDocument.MailMerge.Execute Pause:=False
'Turn the events off so that they
'only execute for this document
DeactivateEvents
End Sub
Sub ActivateEvents()
Set x.WdApp = Word.Application
End Sub
Sub DeactivateEvents()
Set x.WdApp = Nothing
End Sub
Function OpenChartDataFile(LocalPath As String) _
As Word.Document
Dim FilePath As String
'Combine the path where the main merge doc
'is stored plus the specified name of the
'document containing the data for the chart
FilePath = LocalPath & "\" & ChartDataDoc
'Make sure the data file exists
'before trying to open it
If Dir(FilePath) <> "" Then
Set OpenChartDataFile = Documents.Open( _
FileName:=FilePath, _
ReadOnly:=True, _
AddToRecentFiles:=False, _
Visible:=False)
End If
End Function
Sub EditChart(rng As Word.Range, _
DataDoc As Word.Document)
Dim of As Word.OLEFormat
Dim oChart As Graph.Chart
Dim oDataSheet As Graph.DataSheet
Dim tbl As Word.Table
Dim chartType As Long
Set tbl = DataDoc.Tables(1)
'Activate the MS Graph object in the
'main merge document
Set of = rng.InlineShapes(1).OLEFormat
of.DoVerb wdOLEVerbInPlaceActivate
'Pick up the chart for automation
Set oChart = of.Object
'We want to know whether we have a
'pie chart or not
chartType = oChart.chartType
'We also need the data sheet
Set oDataSheet = oChart.Application.DataSheet
oChart.DisplayBlanksAs = xlNotPlotted
FillDataSheet oDataSheet, tbl, chartType
'Finish with the chart
oChart.Application.Update
oChart.Application.Quit
DoEvents
Set oChart = Nothing
End Sub
Sub FillDataSheet(ByRef ds As Graph.DataSheet, _
tbl As Word.Table, chartType As Long)
Dim nrDataCols As Long
recordIndex = recordIndex + 1
nrDataCols = tbl.Columns.Count
'Delete all entries in the datasheet
ds.Cells.ClearContents
If chartType = xlPie Then
ProcessPieChart ds, tbl, nrDataCols
Else
ProcessOtherChart ds, tbl, nrDataCols
End If
DoEvents
End Sub
Sub ProcessPieChart(ByRef ds As Graph.DataSheet, _
tbl As Word.Table, ByVal nrDataCols As Long)
Dim rwData As Word.Row
Dim datavalue As Double
Dim rwLabels As Word.Row
Dim colcounter As Long, i As Long
colcounter = 1
'Data series in rows!
ds.Application.PlotBy = xlRows
'First column contains record ID
'Following columns contain data
'One row per record
'First row contains Legend labels
Set rwLabels = tbl.Rows(1)
Set rwData = tbl.Rows(recordIndex)
'Loop through the data columns
For i = 2 To nrDataCols
With ds
datavalue = CDbl(Val( _
TrimCellText(rwData.Cells(i).Range.Text)))
'Don't carry over 0 values
'If you want to use 0 values
'comment out If and End If lines
If datavalue > 0 Then
colcounter = colcounter + 1
'carry over the column header
.Cells(1, colcounter).Value _
= TrimCellText(rwLabels.Cells(i).Range.Text)
'and the data to the data sheet
.Cells(2, colcounter).Value _
= datavalue
End If
End With
Next i
End Sub
Sub ProcessOtherChart(ByRef ds As Graph.DataSheet, _
tbl As Word.Table, ByVal nrDataCols As Long)
Dim rwData As Word.Row
Dim rwLabels As Word.Row
Dim rowCounter As Long
Dim totalRows As Long
Dim ID As String
Dim datavalue As Double
Dim colcounter As Long, i As Long
colcounter = 1
rowCounter = 1
totalRows = tbl.Rows.Count
'Data series in columns!
ds.Application.PlotBy = xlColumns
'First column contains record ID
'Second column contains legend labels
'Following columns contain data
'First row contains x-axis labels
Set rwLabels = tbl.Rows(1)
Set rwData = tbl.Rows(recordIndex)
'There can be multiple rows / merge record
'therefore loop through table rows until
'ID (value in col 1) changes
Do
colcounter = 1
rowCounter = rowCounter + 1
ID = TrimCellText(rwData.Cells(1).Range.Text)
'carry over row header to datasheet
ds.Cells(rowCounter, 1).Value = _
TrimCellText(rwData.Cells(2).Range.Text)
'loop through the columns
For i = 3 To nrDataCols
colcounter = colcounter + 1
With ds
'carry over column header only on first pass
If rowCounter = 2 Then
.Cells(1, colcounter).Value _
= TrimCellText(rwLabels.Cells(i).Range.Text)
End If
'and the data to the data sheet
.Cells(rowCounter, colcounter).Value _
= TrimCellText(rwData.Cells(i).Range.Text)
End With
Next i
recordIndex = recordIndex + 1
'Stop if we've reached the end
If totalRows < recordIndex Then Exit Do
'Otherwise, move to the next row
'Then perform the ID check before looping back
Set rwData = tbl.Rows(recordIndex)
Loop While ID = TrimCellText(rwData.Cells(1).Range.Text)
'Reset in order to start with correct row for next record
recordIndex = recordIndex - 1
End Sub
Function TrimCellText(s As String) As String
'Remove end-of-cell markers
TrimCellText = Left(s, Len(s) - 2)
End Function
Option Explicit
Public x As New Class1
Public BeforeMergeExecuted As Boolean
Public CancelMerge As Boolean
Public recordIndex As Long
Const ChartDataDoc As String = "constChartDataDocs.docx"
Sub MergeWithChart()
'Preset the global variables
BeforeMergeExecuted = False
CancelMerge = False
recordIndex = 1
'The events in the class module
'clsMergeEvents will be enabled
ActivateEvents
'As each record is merged
'the MailMergeBeforeMerge
'event will be called
ActiveDocument.MailMerge.Execute Pause:=False
'Turn the events off so that they
'only execute for this document
DeactivateEvents
End Sub
Sub ActivateEvents()
Set x.WdApp = Word.Application
End Sub
Sub DeactivateEvents()
Set x.WdApp = Nothing
End Sub
Function OpenChartDataFile(LocalPath As String) _
As Word.Document
Dim FilePath As String
'Combine the path where the main merge doc
'is stored plus the specified name of the
'document containing the data for the chart
FilePath = LocalPath & "\" & ChartDataDoc
'Make sure the data file exists
'before trying to open it
If Dir(FilePath) <> "" Then
Set OpenChartDataFile = Documents.Open( _
FileName:=FilePath, _
ReadOnly:=True, _
AddToRecentFiles:=False, _
Visible:=False)
End If
End Function
Sub EditChart(rng As Word.Range, _
DataDoc As Word.Document)
Dim of As Word.OLEFormat
Dim oChart As Graph.Chart
Dim oDataSheet As Graph.DataSheet
Dim tbl As Word.Table
Dim chartType As Long
Set tbl = DataDoc.Tables(1)
'Activate the MS Graph object in the
'main merge document
Set of = rng.InlineShapes(1).OLEFormat
of.DoVerb wdOLEVerbInPlaceActivate
'Pick up the chart for automation
Set oChart = of.Object
'We want to know whether we have a
'pie chart or not
chartType = oChart.chartType
'We also need the data sheet
Set oDataSheet = oChart.Application.DataSheet
oChart.DisplayBlanksAs = xlNotPlotted
FillDataSheet oDataSheet, tbl, chartType
'Finish with the chart
oChart.Application.Update
oChart.Application.Quit
DoEvents
Set oChart = Nothing
End Sub
Sub FillDataSheet(ByRef ds As Graph.DataSheet, _
tbl As Word.Table, chartType As Long)
Dim nrDataCols As Long
recordIndex = recordIndex + 1
nrDataCols = tbl.Columns.Count
'Delete all entries in the datasheet
ds.Cells.ClearContents
If chartType = xlPie Then
ProcessPieChart ds, tbl, nrDataCols
Else
ProcessOtherChart ds, tbl, nrDataCols
End If
DoEvents
End Sub
Sub ProcessPieChart(ByRef ds As Graph.DataSheet, _
tbl As Word.Table, ByVal nrDataCols As Long)
Dim rwData As Word.Row
Dim datavalue As Double
Dim rwLabels As Word.Row
Dim colcounter As Long, i As Long
colcounter = 1
'Data series in rows!
ds.Application.PlotBy = xlRows
'First column contains record ID
'Following columns contain data
'One row per record
'First row contains Legend labels
Set rwLabels = tbl.Rows(1)
Set rwData = tbl.Rows(recordIndex)
'Loop through the data columns
For i = 2 To nrDataCols
With ds
datavalue = CDbl(Val( _
TrimCellText(rwData.Cells(i).Range.Text)))
'Don't carry over 0 values
'If you want to use 0 values
'comment out If and End If lines
If datavalue > 0 Then
colcounter = colcounter + 1
'carry over the column header
.Cells(1, colcounter).Value _
= TrimCellText(rwLabels.Cells(i).Range.Text)
'and the data to the data sheet
.Cells(2, colcounter).Value _
= datavalue
End If
End With
Next i
End Sub
Sub ProcessOtherChart(ByRef ds As Graph.DataSheet, _
tbl As Word.Table, ByVal nrDataCols As Long)
Dim rwData As Word.Row
Dim rwLabels As Word.Row
Dim rowCounter As Long
Dim totalRows As Long
Dim ID As String
Dim datavalue As Double
Dim colcounter As Long, i As Long
colcounter = 1
rowCounter = 1
totalRows = tbl.Rows.Count
'Data series in columns!
ds.Application.PlotBy = xlColumns
'First column contains record ID
'Second column contains legend labels
'Following columns contain data
'First row contains x-axis labels
Set rwLabels = tbl.Rows(1)
Set rwData = tbl.Rows(recordIndex)
'There can be multiple rows / merge record
'therefore loop through table rows until
'ID (value in col 1) changes
Do
colcounter = 1
rowCounter = rowCounter + 1
ID = TrimCellText(rwData.Cells(1).Range.Text)
'carry over row header to datasheet
ds.Cells(rowCounter, 1).Value = _
TrimCellText(rwData.Cells(2).Range.Text)
'loop through the columns
For i = 3 To nrDataCols
colcounter = colcounter + 1
With ds
'carry over column header only on first pass
If rowCounter = 2 Then
.Cells(1, colcounter).Value _
= TrimCellText(rwLabels.Cells(i).Range.Text)
End If
'and the data to the data sheet
.Cells(rowCounter, colcounter).Value _
= TrimCellText(rwData.Cells(i).Range.Text)
End With
Next i
recordIndex = recordIndex + 1
'Stop if we've reached the end
If totalRows < recordIndex Then Exit Do
'Otherwise, move to the next row
'Then perform the ID check before looping back
Set rwData = tbl.Rows(recordIndex)
Loop While ID = TrimCellText(rwData.Cells(1).Range.Text)
'Reset in order to start with correct row for next record
recordIndex = recordIndex - 1
End Sub
Function TrimCellText(s As String) As String
'Remove end-of-cell markers
TrimCellText = Left(s, Len(s) - 2)
End Function