以下是修改后的代码,它会将折线图和对应的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”)。

VBA代码:将折线图和BMP图片插入Word文档并居中显示

原文地址: http://www.cveoy.top/t/topic/prq 著作权归作者所有。请勿转载和采集!

免费AI点我,无需注册和登录