【原创】PPT最佳打印法(8张/页法、9张/页法)|:: ＩＴ数码 :: - 啄木论坛

Attribute VB_Name = "NewMacros"
Sub 一页8张PPT自动排版()
Attribute 一页8张PPT自动排版.VB_Description = "宏在 2008-6-16 由欣宇录制"
Attribute 一页8张PPT自动排版.VB_ProcData.VB_Invoke_Func = "Normal.NewMacros.Macro1"
'
'制作：啄木论坛(www.zhuomu.cn) 欣宇版权所有
'

'【调整页边距及页眉页脚距，适用于A4纸】

    With ActiveDocument.Styles(wdStyleNormal).Font
        If .NameFarEast = .NameAscii Then
            .NameAscii = ""
        End If
        .NameFarEast = ""
    End With
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = CentimetersToPoints(1.6)
        .BottomMargin = CentimetersToPoints(0.9)
        .LeftMargin = CentimetersToPoints(1.4)
        .RightMargin = CentimetersToPoints(1)
        .Gutter = CentimetersToPoints(0)
        .HeaderDistance = CentimetersToPoints(0.5)
        .FooterDistance = CentimetersToPoints(0.9)
        .PageWidth = CentimetersToPoints(21)
        .PageHeight = CentimetersToPoints(29.7)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
        .LayoutMode = wdLayoutModeLineGrid
    End With

'【加页码，页脚居中处】

    Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:= _
        wdAlignPageNumberCenter, FirstPage:=True
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    If Selection.HeaderFooter.IsHeader = True Then
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Else
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        If ActiveWindow.Panes.Count = 2 Then
            ActiveWindow.Panes(2).Close
        End If
        ActiveWindow.View.SplitSpecial = wdPaneCurrentPageHeader
    Else
        ActiveWindow.View.SeekView = wdSeekCurrentPageHeader
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    ActiveWindow.ActivePane.VerticalPercentScrolled = 0

'【调整每张幻灯片的大小为高184宽262，也许还有更佳的值，可自己尝试】

    Dim i As Integer
    For i = 1 To ActiveDocument.InlineShapes.Count
        ActiveDocument.InlineShapes(i).Height = 184
        ActiveDocument.InlineShapes(i).Width = 262
    Next i

'【给每张幻灯片加边框，感觉没有边框很难看】

    Selection.HomeKey Unit:=wdStory

    Dim j As Integer
    For j = 1 To ActiveDocument.InlineShapes.Count

    Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    With Selection.InlineShapes(1)
        With .Borders(wdBorderLeft)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        With .Borders(wdBorderRight)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        With .Borders(wdBorderTop)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        With .Borders(wdBorderBottom)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        .Borders.Shadow = False
    End With
    With Options
        .DefaultBorderLineStyle = wdLineStyleSingle
        .DefaultBorderLineWidth = wdLineWidth050pt
        .DefaultBorderColor = wdColorAutomatic
    End With

        Selection.MoveRight Unit:=wdCharacter, Count:=1

    Next j

End Sub