TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

Sub MakeFillPatterns()

' Start by opening a new blank presentation
' Then run this

    Dim oSh As Shape
    Dim x As Long
    Dim sOutputFolder As String

    On Error GoTo ErrorHandler

    ' edit this to the slash-terminated path to the folder where you want the files created
    ' the folder MUST exist or you'll get an error and the macro won't work
    sOutputFolder = "c:\temp\"

    With ActivePresentation
        .PageSetup.Slideheight = 72
        .PageSetup.Slidewidth = 72
        Set oSh = .Slides(1).Shapes.AddShape(msoShapeRectangle, 0, 0, 72, 72)
        With oSh
            ' we don't want the outline visible ... it'll spoil the pattern
            .Line.Visible = msoFalse
            .Fill.Transparency = 0#
            .Fill.Visible = msoTrue

            ' This is set to use foreground and background scheme colors.
            ' Change the scheme to get different color fills:
            .Fill.ForeColor.SchemeColor = ppForeground
            .Fill.BackColor.SchemeColor = ppBackground

            For x = 1 To 64
                .Fill.Patterned x
                ActivePresentation.Slides(1).Export sOutputFolder & "PatternedFill" & CStr(x) & ".WMF", "WMF"
                'ActivePresentation.SaveAs sOutputFolder & "PatternedFill" & CStr(x) & ".WMF", ppSaveAsMetaFile
            Next

        End With
    End With

NormalExit:
    Exit Sub
ErrorHandler:
    ' if we got here, either the path was wrong or we've asked for a fill number greater than
    ' PPT knows about; either way, quit
    Resume NormalExit

End Sub