VBA代码:将折线图和BMP图片插入Word文档并居中显示
以下是修改后的代码,它会将折线图和对应的BMP图片插入到一个新建的名为'vib.docx'的Word文件中,并将图片居中显示。
Sub CreateChartSaveAsBMP()
Dim MyChart As ChartObject
Dim MyXValues1 As Range
Dim MyYValues1 As Range
Dim MyXValues2 As Range
Dim MyYValues2 As Range
Dim MyXValues3 As Range
Dim MyYValues3 As Range
Dim ChartTitle As String
Dim SeriesName1 As String
Dim SeriesName2 As String
Dim SeriesName3 As String
Dim FilePath As String
Dim m, n, i As Long
Dim FolderPath As String
Dim picFolderPath As String
Dim picFile As String
Dim wspro As Worksheet
Dim wdApp As Object ' Word.Application
Dim wdDoc As Object ' Word.Document
Dim wdShape As Object ' Word.InlineShape
Set wspro = ThisWorkbook.Sheets("DataPro")
FolderPath = ThisWorkbook.Path
picFolderPath = FolderPath & "\pic"
If Dir(picFolderPath, vbDirectory) = "" Then
MkDir picFolderPath
Else
picFile = Dir(picFolderPath & "\*.*")
Do While picFile <> ""
Kill picFolderPath & "\" & picFile
picFile = Dir
Loop
End If
m = wspro.UsedRange.Rows.Count
n = wspro.UsedRange.Columns.Count
' 创建并打开新的Word文档
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
For i = 3 To n Step 3
Set MyXValues1 = wspro.Range(wspro.Cells(4, 1), wspro.Cells(m, 1))
Set MyYValues1 = wspro.Range(wspro.Cells(4, i - 1), wspro.Cells(m, i - 1))
Set MyXValues2 = wspro.Range(wspro.Cells(4, 1), wspro.Cells(m, 1))
Set MyYValues2 = wspro.Range(wspro.Cells(4, i), wspro.Cells(m, i))
Set MyXValues3 = wspro.Range(wspro.Cells(4, 1), wspro.Cells(m, 1))
Set MyYValues3 = wspro.Range(wspro.Cells(4, i + 1), wspro.Cells(m, i + 1))
ChartTitle = wspro.Cells(1, i).Value
SeriesName1 = wspro.Cells(3, i - 1).Value
SeriesName2 = wspro.Cells(3, i).Value
SeriesName3 = wspro.Cells(3, i + 1).Value
Set MyChart = wspro.ChartObjects.Add(Left:=100, Width:=600, Top:=75, Height:=360)
MyChart.Chart.ChartType = xlLine
With MyChart.Chart.SeriesCollection.NewSeries
.XValues = MyXValues1
.Values = MyYValues1
.Name = SeriesName1
.Format.Line.DashStyle = msoLineSolid
.Format.Line.Weight = 1.5
End With
With MyChart.Chart.SeriesCollection.NewSeries
.XValues = MyXValues2
.Values = MyYValues2
.Name = SeriesName2
.Format.Line.DashStyle = msoLineSysDot
.Format.Line.Weight = 2
End With
With MyChart.Chart.SeriesCollection.NewSeries
.XValues = MyXValues3
.Values = MyYValues3
.Name = SeriesName3
.Format.Line.DashStyle = msoLineSysDash
.Format.Line.Weight = 2.5
End With
MyChart.Chart.HasTitle = True
MyChart.Chart.ChartTitle.Text = ChartTitle
MyChart.Chart.Axes(xlCategory, xlPrimary).HasTitle = True
MyChart.Chart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "转速(r/min)"
MyChart.Chart.Axes(xlValue, xlPrimary).HasTitle = True
MyChart.Chart.Axes(xlValue, xlPrimary).AxisTitle.Text = "响应值(mm/s)"
MyChart.Chart.Axes(xlCategory).CategoryType = xlAutomatic
MyChart.Chart.Axes(xlCategory).CategoryType = xlCategoryScale
MyChart.Chart.Axes(xlCategory).TickLabelSpacing = 5
FilePath = picFolderPath & "\" & ChartTitle & ".bmp"
MyChart.Chart.Export Filename:=FilePath, FilterName:="BMP"
' 将图片插入到Word文档中并居中显示
Set wdShape = wdDoc.Shapes.AddPicture(FilePath, False, True)
With wdShape
.WrapFormat.Type = 3 ' wdWrapSquare
.Left = wdApp.CentimetersToPoints(2.54) ' 2.54 cm
.Top = wdApp.CentimetersToPoints(2.54) ' 2.54 cm
.Width = wdApp.CentimetersToPoints(15.24) ' 15.24 cm
.Height = wdApp.CentimetersToPoints(9.6) ' 9.6 cm
End With
MyChart.Delete
Next i
' 保存并关闭Word文档
wdDoc.SaveAs FolderPath & "\vib.docx"
wdDoc.Close
wdApp.Quit
Set wdShape = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
End Sub
这样修改后的代码将会创建一个新的Word文档,并将每个图表的BMP图片插入到该文档中,并将图片居中显示。最后将该Word文档保存为名为“vib.docx”的文件。请确保你已经安装了Microsoft Word以及VBA引用了Word对象库(在VBA编辑器中选择“工具”->“引用”,并勾选“Microsoft Word xx.x Object Library”)。
原文地址: http://www.cveoy.top/t/topic/prq 著作权归作者所有。请勿转载和采集!