VBA word插入图片位置

ColorfulHouse 2015-06-15 04:22:23

如下代码，向打开word文档中每页固定位置插入相同图片：

Sub TestInsertPic()

    Dim bRet As Boolean

    Dim picPath As String

    picPath = "D:\a.bmp"

    

    ret = InsertPic(picPath, 47, 10, 50, 10)

    

    'MsgBox bRet

End Sub



'word中每页插入图片    长度单位均为毫米

'picPath      图片路径

'picWidth     图片宽度

'picHeight    图片高度

'picRight     图片右侧距页面右侧的距离

'picBottom    图片底部距页面底部的距离

'

Function InsertPic(picPath As String, picWidth As Single, picHeight As Single, picRight As Single, picBottom As Single) As Boolean

    Dim pageCount As Integer

    Dim pIndex As Integer

    Dim oDoc  As Document

    Dim oRang As Range

    Dim oShape As Shape

    Dim olShape As InlineShape

    Dim oPage As Page

    Dim pWidth, pHeight, pLeft, pTop, pRight, pBottom As Integer    '图片位置大小信息

    Dim mRight, mBottom, mLeft, mTop As Integer  '页边距

    Dim pageHeight, pageWidth As Integer 'word页面大小(页边距以内)

    Dim tableTop, tableLeft, tableWidth, tablePaddingLeft As Integer

    Dim oTable As Table

    Dim tableType As Integer

    'Dim p2cUnit As Single

    

    Set oDoc = ActiveDocument

    Set oPage = oDoc.ActiveWindow.Panes(1).pages(1)

    '获取页边距

    mLeft = oDoc.PageSetup.LeftMargin

    mRight = oDoc.PageSetup.RightMargin

    mBottom = oDoc.PageSetup.BottomMargin

    mTop = oDoc.PageSetup.TopMargin

    

    '页面大小

    pageHeight = oDoc.PageSetup.pageHeight

    pageWidth = oDoc.PageSetup.pageWidth

    

    '计算单位，从毫米到磅

    'p2cUnit = 2.835     '1毫米大约等于2.835磅

    pWidth = Application.MillimetersToPoints(picWidth)

    pHeight = Application.MillimetersToPoints(picHeight)

    pRight = Application.MillimetersToPoints(picRight)

    pBottom = Application.MillimetersToPoints(picBottom)

  

    '获取总页数

    pageCount = GetPageCount()

    

    '清理之前已经存在的二维码图片

    Dim s As Shape

    For pIndex = 1 To GetPageCount

        On Error Resume Next

        Set oShape = oDoc.Shapes.Item("codebar" & pIndex)

        

        If Not oShape Is Nothing Then

            oShape.Delete

        End If

        Err.Clear

    Next

    

    '遍历每页添加图片

    For pIndex = 1 To pageCount

        Set oRang = oDoc.GoTo(wdGoToPage, wdGoToAbsolute, pIndex)

    

        Set oShape = oDoc.Shapes.AddPicture(picPath, False, True, 0, 0, pWidth, pHeight, oRang)

        oShape.Name = "codebar" & pIndex

        oShape.Select

        

        '图片的水平位置，相对于边距   单位 磅

        oShape.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin

        oShape.Left = -mLeft + pageWidth - pWidth - pRight

        '图片的垂直位置，相对于边距   单位 磅

        oShape.RelativeVerticalPosition = wdRelativeVerticalPositionMargin

        oShape.Top = -mTop + pageHeight - pHeight - pBottom

    Next

    

End Function





Function GetPageCount() As Integer

    Dim pageCount As Integer

    pageCount = ActiveDocument.ComputeStatistics(wdStatisticPages, False)

    'MsgBox pageCount

    GetPageCount = pageCount

End Function