Word中用VBA插入一个文件夹里的所有.jpg图片

Posted 2020-11-19 maple-sir

每四张图片放在一页，第一行为四张图片的文件名

插入图片调整尺寸参考

Sub final()
Dim FN As String, N%, W#, H#, PW#, PH#
With ActiveDocument.PageSetup  ‘以下设置纸型及页边距（A4，页边距2cm），并计算出图片应有的宽高
    .Orientation = wdOrientPortrait
    .TopMargin = CentimetersToPoints(2)
    .BottomMargin = CentimetersToPoints(2)
    .LeftMargin = CentimetersToPoints(2)
    .RightMargin = CentimetersToPoints(2)
    .Gutter = CentimetersToPoints(0)
    .PageWidth = CentimetersToPoints(21)
    .PageHeight = CentimetersToPoints(29.7)
    PW = (.PageWidth - .LeftMargin - .RightMargin) / 2
    PH = .PageHeight - .TopMargin - .LeftMargin
End With
FN = Dir("F:\*.jpg") ‘循环当前文件目录下各个jpg文件
Dim f(3) As String
    b = 0
Do While FN <> "" ‘当文件名不为空时持续循环
    Selection.InlineShapes.AddPicture "F:\" & FN ‘插入当前循环到的jpg文件
    a = b Mod 4
    f(a) = FN
        With ActiveDocument.InlineShapes(b + 1)
        W = .Width ‘取得宽与高
        H = .Height
        .LockAspectRatio = msoTrue
        If W / H >= PW / PH Then ‘如果图片的宽高比大于应设置的宽高比，则
            .Width = PW * 0.99 ‘调整宽度为应设置的宽度，高度按调整前后的宽度比进行缩放
            ‘.Height = H * PW / W
        Else    ‘如果图片的宽高比小于应设置的宽高比，则
            .Height = PH * 0.99 ‘调整高度为应设置的高度，宽度按调整前后的高度比进行缩放
            ‘.Width = W * PH / H
        End If
    End With
    FN = Dir ‘循环到下一个文件
    If a = 3 Then
    Selection.InsertBreak Type:=wdPageBreak
    Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=3
        With Selection.Range
            .Text = f(0) & "、" & f(1) & "、" & f(2) & "、" & f(3) & vbCrLf
            .Font.Name = "times new roman"
            .Font.Size = 12
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
    End If
    b = b + 1
Loop
    If a <> 3 Then
        Select Case a
            Case 0
                Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=1
                Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
                With Selection.Range
                    .Text = f(0) & vbCrLf
                    .Font.Name = "times new roman"
                    .Font.Size = 12
                    .ParagraphFormat.Alignment = wdAlignParagraphCenter
                End With
                Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
            Case 1
                Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=1
                Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
                With Selection.Range
                    .Text = f(0) & "、" & f(1) & vbCrLf
                    .Font.Name = "times new roman"
                    .Font.Size = 12
                    .ParagraphFormat.Alignment = wdAlignParagraphCenter
                End With
                Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
            Case 2
                Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=2
                Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
                With Selection.Range
                    .Text = f(0) & "、" & f(1) & "、" & f(2) & vbCrLf
                    .Font.Name = "times new roman"
                    .Font.Size = 12
                    .ParagraphFormat.Alignment = wdAlignParagraphCenter
                End With
                Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
        End Select
    End If
End Sub