[原创]WORD调用EXCEL.CHART

守柔

这是一个WORD中使用OLE(EXCEL.CHART)的实例,它较之之前所作WORD中调用MS GRAPH,运行速度更快,编辑更方便.

注意:版本不同,可能会出现意外情况,主要为图表未按代码要求生成指定的尺寸.

本程序在OFFICE 2000和XP中通过.

成品附件如下:

ZmfTnlkn.zip (32.56 KB, 下载次数: 757)

2005-4-12 06:55 上传

点击文件名下载附件
[原创]WORD调用EXCEL.CHART

以下代码供参考:

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-4-12 06:53:06 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋ '* Created By I Love You_Word!@ExcelHome 2005-3-31 4:41:00 '仅测试于System: Windows NT Word: 10.0 Language: 2052 '^The Code CopyIn [ThisDocument-ThisDocument]^' '* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－ '为hpw所作/ShouRou,整理于2005/4/11日晨 Option Explicit Sub DelInLineShapes() '删除嵌入式图片 Dim i As InlineShape On Error Resume Next Application.ScreenUpdating = False For Each i In ActiveDocument.InlineShapes i.Delete Next Application.ScreenUpdating = True End Sub '---------------------- Sub DelParagraphs() '删除冗长的说明性标题 Dim i As Paragraph On Error Resume Next Application.ScreenUpdating = False For Each i In ActiveDocument.Paragraphs If i.Next.Range.Tables.Count = 0 Then i.Range.Delete Next Application.ScreenUpdating = True End Sub '---------------------- Sub DelColumns() Dim i As Table, N As Integer, ColCount As Byte, ErrCount As Integer On Error Resume Next '忽略错误 Application.ScreenUpdating = False '关闭屏幕更新 For Each i In ActiveDocument.Tables '在活动文档表格中循环 With i ColCount = .Columns.Count '获得总列数 If (.Rows(1).Cells.Count - 1) * 2 = ColCount - 1 Then .Rows(2).Delete '第二行删除 For N = (ColCount + 1) / 2 To 2 Step -1 '循环 .Cell(1, N).Split 1, 2 '分列 .Cell(1, N + 1).Range = VBA.Replace(.Cell(1, N).Range, Chr(13), "") .Cell(1, N).Select '选定单元格 Selection.Columns.Delete '整列删除 Next '如果仅为三列且表格列数一致的话 ElseIf .Rows(1).Cells.Count = 3 And .Rows(1).Cells.Count = ColCount Then .Columns(2).Delete '第二列删除 Else ErrCount = ErrCount + 1 '进入计数 GoTo GoNext End If .PreferredWidthType = 2 '度量单位为% .PreferredWidth = 100 '表格调整为100%页面宽度 End With GoNext: Next Application.ScreenUpdating = True '恢复屏幕更新 '友情提示 If ErrCount > 0 Then MsgBox "您的文档中,共发现有" & ErrCount & "个表格出现了不规则的单元格合并情况!" & vbCrLf _ & "请按下CTRL+F,以频数为关键字进行搜索.", vbOKOnly + vbExclamation End Sub '---------------------- Sub CreateSetupChart() Dim aTable As Table, aCell As Cell, MyRange As Range, LastCell As String, aString As Variant Dim MyChart As Object, ColCount As Byte, Percent As Variant, RowCount As Integer, aInLineShape As InlineShape Dim i As Integer, R1 As Integer, C1 As Integer, HeadingRange As Range, OldTablesCount As Integer Dim RunStartTime As Date, RunEndTime As Date, TablesCount As Integer, InLineShapesCount As Integer On Error Resume Next RunStartTime = Now '记录程序运行时间 Application.ScreenUpdating = False With ActiveDocument .ActiveWindow.Visible = False '活动窗口隐藏 Options.Pagination = False '取消后台分页功能 OldTablesCount = .Tables.Count For Each aTable In .Tables '在活动文档中循环 Set HeadingRange = aTable.Range.Previous(4) '定义一个表格上方的文字(标题)区域 HeadingRange.Style = ActiveDocument.Styles(-10) '设为标题9样式 ColCount = aTable.Columns.Count '获得aTable的列数 RowCount = aTable.Rows.Count '获得aTable的行数 If ColCount > 7 Then GoTo GoNext '列数>3 则进入下一个循环 Percent = .Range(aTable.Cell(RowCount, ColCount).Range.Start, aTable.Cell(RowCount, ColCount).Range.End - 1) If ColCount = 2 Then ' 如果为2列 '如果为二列的表格的总行数>10则进入下一个循环 '如果最后一个单元格的值不为100则进入下一个循环 If VBA.Val(Percent) <> 100 Or RowCount > 10 Then GoTo GoNext End If '如果表格列数在4-7之间并且表格的行数大于8则进入下一个循环 If ColCount > 3 And ColCount < 8 Then If RowCount > 10 Then GoTo GoNext End If Set MyRange = .Range(HeadingRange.End - 1, HeadingRange.End - 1) MyRange.InsertAfter vbCrLf '插入一个空白段落标记 '重新定义一个RANGE对象,其位置为表格前的一个空白段落标记前的位置 Set MyRange = .Range(HeadingRange.End - 1, HeadingRange.End - 1) '定义一个InLineShape对象 Set aInLineShape = ActiveDocument.InlineShapes.AddOLEObject(ClassType:="Excel.Chart", DisplayAsIcon:=False, _ Range:=MyRange) Set MyChart = aInLineShape.OLEFormat.Object '定义一个OLE Object对象 With MyChart .Application.Visible = False .sheets(1).ChartArea.Clear .sheets(2).Range("A1:D7").Delete End With For Each aCell In aTable.Range.Cells '在aTable的单元格区域中循环 With aCell '取得aCell单元格中的文本 aString = ActiveDocument.Range(.Range.Start, .Range.End - 1) '如果是数字则aString变量返回数字型,否则为文本型 If VBA.IsNumeric(aString) Then aString = VBA.Val(aString) '将单元格数据写入工作表中 MyChart.sheets(2).Cells(.RowIndex, .ColumnIndex) = aString End With Next aCell LastCell = MyChart.sheets(2).Cells(RowCount - 1, ColCount).Address With MyChart.sheets(1) .SetSourceData Source:=MyChart.sheets(2).Range("A1:" & LastCell), PlotBy:=2 .ChartArea.Width = 340: .ChartArea.Height = 170 '先宽后高,如果是先高后宽则易出错 .ChartArea.AutoScaleFont = False '不自动改变字体大小 Select Case ColCount '列数 '++++++++++++++++++++++++++++++++++++++++++++++ '表格列数为2列时,生成三维饼图及其格式设置 Case 2 .ChartType = 70 '三维饼图 .Elevation = 15 '设置图表仰角为15度 .Perspective = 30 '图表的透视系数设置为 30 .HeightPercent = 50 '设置三维图表的高度为宽度的50% .HasLegend = False '图表无图例 .HasTitle = False '图表无标题 .Rotation = 0 '图表无转角 '所有数据系列应用数据标签 .ApplyDataLabels Type:=5, LegendKey:=False, HasLeaderLines:=True With .SeriesCollection(1) '数据系列1 .Border.Weight = 2: .Border.LineStyle = -4142 .Interior.ColorIndex = -4105 '设置填充色为自动 .Explosion = 30 '扇区的分离程度值 .DataLabels.NumberFormatLocal = "0.0%" '数据标签格式设置 End With With .PlotArea '绘图区 .Width = 229 '宽度为8厘米 .Height = 85 '高度为3厘米 .Left = (340 - .Width) / 2 '居中 .Top = (170 - .Height) / 2 '居中 .Border.LineStyle = -4142 '无框线 End With '++++++++++++++++++++++++++++++++++++++++++++++ '表格列数为3列时,生成二维柱形图及其格式设置 Case 3 .ChartType = 51 '二维柱形图 .ApplyDataLabels Type:=2, LegendKey:=False, HasLeaderLines:=True .PlotArea.ClearFormats '清除绘图区格式 .HasLegend = True '具有图例 .Legend.Position = -4160 '图例在上方 With .Axes(2) 'Y轴 .Border.Weight = 1 '边框线宽 .Border.LineStyle = -4105 '边框的线型 .HasMajorGridlines = True '主要网格线 .HasMinorGridlines = False '无次要网格线 .MinimumScaleIsAuto = True '自动计算坐标轴的最大刻度值 .MaximumScaleIsAuto = True '自动计算坐标轴的最小刻度值 .MajorTickMark = 3 '坐标轴的主刻度线型 .MinorTickMark = -4142 '次要刻度线类型无 .TickLabelPosition = 4 '刻度线标签的位置 .TickLabels.NumberFormatLocal = "#""%""" '刻度线的数字格式 With .MajorGridlines.Border .ColorIndex = 37 .Weight = 1 .LineStyle = 4 End With End With With .Axes(1) 'X轴 .HasMajorGridlines = False '无主要网格线 .HasMinorGridlines = False '无次要网格线 .TickLabels.Orientation = 30 'X轴刻度线标签倾斜30度 .TickLabelSpacing = 1 '数据系列数为1 With .TickLabels '刻度线标志 .Alignment = -4108 '居中 .Orientation = 30 '文本方向倾斜30度 End With .Border.Weight = 1 .Border.LineStyle = -4105 End With For i = 1 To .SeriesCollection.Count '调整集合中每个数据系列的各个格式设置 With .SeriesCollection(i) .Border.Weight = 2 '边框线粗细 .Border.LineStyle = -4142 .Shadow = False '无阴影 .InvertIfNegative = False '不以互补色显示对应于负值的对象中的图案 .Fill.OneColorGradient Style:=2, Variant:=4, Degree:=0.231372549019608 .Fill.Visible = True '可见 .Fill.ForeColor.SchemeColor = i + 16 '前景色 End With Next i '++++++++++++++++++++++++++++++++++++++++++++++ '表格列数为4-7列时,生成百分比堆积柱形图及其格式设置 Case 4 To 7 .ChartType = 53 '百分比堆积柱形图 .ApplyDataLabels Type:=2, LegendKey:=False For i = 1 To 2 With .Axes(i) .HasMajorGridlines = False 'Y轴的主要网格线为无 .HasMinorGridlines = False 'Y轴的次要网格线为无 .Border.Weight = 1: .Border.LineStyle = -4142 .MajorTickMark = 3 '坐标轴的主刻度线型 .MinorTickMark = -4142 '次要刻度线类型无 .TickLabelPosition = 4 '刻度线标签的位置 End With Next i .HasLegend = True '具有图例 .Legend.Position = -4160 '图例置于图表区的顶部 With .PlotArea '绘图区 .ClearFormats '清除格式 .Border.Weight = 2 '边框细线 .Border.LineStyle = -4105 '自动 .Interior.ColorIndex = -4142 '无填充色 End With For i = 1 To .SeriesCollection.Count '调整集合中每个数据系列的各个格式设置 With .SeriesCollection(i) .Border.Weight = 1 '边框线粗细 .Border.LineStyle = -4142 .Shadow = False '无阴影 .InvertIfNegative = False '不以互补色显示对应于负值的对象中的图案 .Interior.ColorIndex = -4105 '自动填充内部颜色 .Fill.OneColorGradient Style:=2, Variant:=4, _ Degree:=0.231372549019608 .Fill.Visible = True '可见 .Fill.ForeColor.SchemeColor = i + 16 '前景色 End With Next i End Select .ChartArea.Font.Size = 10: .ChartArea.Font.Name = "Tahoma" End With aTable.Delete '删除表格 Set MyChart = Nothing With aInLineShape .Range.Paragraphs(1).Style = -1 '设置为正文样式 .Range.Previous(4).Text = VBA.Replace(.Range.Previous(4).Text, "表", "图") .Range.Previous(4).Style = ActiveDocument.Styles(-9) '标题8 End With .UndoClear '及时清空撤消步骤,减少WORD内存调用 GoNext: Next aTable TablesCount = .Tables.Count '获得表格总数(程序运行结束) InLineShapesCount = .InlineShapes.Count .ActiveWindow.Visible = True '恢复活动窗口文档 End With ' If Tasks.Exists("Microsoft Excel") = True Then Tasks("Microsoft Excel").Close Options.Pagination = True '恢复后台分页功能 Application.ScreenUpdating = True RunEndTime = Now '程序运行结束的时间 MsgBox "程序已经运行结束,谢谢使用,请检查!" & vbCrLf & "程序运行结果:共有表格" _ & OldTablesCount & "个,生成图表" & InLineShapesCount & "个,余表格" & TablesCount & "个." & _ vbCrLf & "程序运行时间:" & RunStartTime & "-" & RunEndTime, vbOKOnly + vbExclamation, "Microsoft Word_Graph" End Sub '----------------------

守柔

程序运行前的表格截图:

程序运行后的图表截图:

chenjun

好!我在office2000中可以运行，采用了后期绑定，可以取消对excel库的引用。

chenwintek

[em02][em02][em02][em02]

如意

我在2003里测试成功。

plxmm

偶这里：WInxp+Excel2003 测试OK。但是。在Excel2003工作的时候运行这个东东出现如图ExcelVBA视窗：。

要是这个东东退出时还原隐藏的Excel视窗就好了。

wenz

有意义，应做成加载宏呀。

konggs

wez兄，我注意，你在研究老大的高深理论！PFPF，

我也想的，可是没能力。有机会也加入你的行列。

wenz

To孔老弟： 老大就是老大，就是我们学习的榜样，或许VBA上你不如我，但对Word的使用上，我绝对不如你，各有所长而已。你在主页上编辑了不少Word的专题，我都读了，特别是你把不传的秘籍都献了出来，令人钦佩，也不知你是从那里学得。 如果你有幸走进VBA的殿堂，你才发现：使用Word是学别人的，学VBA是做自己的。当然辛酸不少呀。 今天是我最后一天假期，以后又很少上网了，一是Word版的一个新秀，特守坛，相信你能从这里，特别是几位老大的作品中体会到他们的学问与修为。 祝你能早日入室。

konggs

谢谢 wenz兄的教导！我会把他复制下来，慢慢品味。（老大的教悔我也复制下来了）

其实那个秘籍是出自七兄的一句话“mrcrosoft的脚本编辑器也有很多知识，只是很少有人挖掘”(可以说的不太对，但意思就是这样)。所以，我在用word的时候，有意无意在脚本编辑器在转一转，看一看，再想一想，再做一做。所以，发现了这个，不敢独享，所以，拿出来大家分享了。 VBA我真的很想学，所以，我就努力在看老大的教程，看前辈的案例。 有时很累，说真的，这几天晚上睡觉，都在想word问题、上厕所、聊天等所有的时间都在想，我自己有时都怕自己会着魔！ 问一句：能否介绍一个入门的书？让我进入你们的VBA的殿堂。