Posts Tagged ‘VBA’

VBA: Create Slide for every Picture in a Folder

Wednesday, November 23rd, 2011

This short script runs in PowerPoint VBA. It looks in a given folder for any image and creates a new slide for that image. Once the image has been inserted it determines if the image is portrait or landscape and then resizes the picture, keeping the proportions, to fit the given slide layout as best it can.  

Option Explicit
Sub CreatePictureSlidesByFolder()
    'Define Variables
    Dim PictureFolder As String
    Dim CurrentSlide As Slide
    Dim CurrentFile As String
    Dim CurrentFileFullName As String
    Dim AllowedExtensions() As Variant
   
    'Set the Path to the folder of pictures
    PictureFolder = "\\data\staffdata\ctolley\My Pictures\Sample Pictures"
   
    'Check that the Picture folder path has a trailing \
    If Right(PictureFolder, 1) <> "\" Then PictureFolder = PictureFolder & "\"
   
    'Define the allowed picture extensions
    AllowedExtensions = Array("jpg", "png", "bmp")
   
    'Check that 1 slide exists in the presentation
    If ActivePresentation.Slides.Count = 0 Then
        ActivePresentation.Slides.Add 1, ppLayoutTitle
        ActivePresentation.Slides(1).Shapes(1).TextFrame.TextRange.Text = PictureFolder
    End If
   
    'Get the files in the folder
    CurrentFile = Dir(PictureFolder)
   
    While CurrentFile <> ""
   
    'Check that the file extension is allowed
    If IsStringInArray(GetFileExtension(CurrentFile), AllowedExtensions) Then
   
        'Make the full file name
        CurrentFileFullName = PictureFolder & CurrentFile
   
        'Add a new slide to the presentation
        Set CurrentSlide = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
       
        'Add the picture to the presentation
        With CurrentSlide.Shapes.AddPicture(CurrentFileFullName, msoFalse, msoTrue, 0, 0)
       
            'Check if the picture is landscape or portrait
           
            If .Width > .Height Then
                'Landscape
                .Width = ActivePresentation.PageSetup.SlideWidth
                .Left = 0
                .Top = (ActivePresentation.PageSetup.SlideHeight - .Height) / 2
           
            Else
                'Portrait
                .Height = ActivePresentation.PageSetup.SlideHeight
                .Left = (ActivePresentation.PageSetup.SlideWidth - .Width) / 2
                .Top = 0
            End If
           
        End With
       
    End If
           
    'Clear the current file
    CurrentFile = Dir
   
    Wend
End Sub
Public Function GetFileExtension(TheFilePath As String) As String
    'Separates the file extension from the file name and returns it.
    Dim FileParts() As String
    FileParts = Split(TheFilePath, ".")
    GetFileExtension = FileParts(UBound(FileParts))
End Function
Public Function IsStringInArray(TheString As String, TheArray() As Variant) As Boolean
    'Determines if the passed string is in the passed array.
    Dim ArrIdx As Integer
    For ArrIdx = LBound(TheArray) To UBound(TheArray)
        If TheString Like TheArray(ArrIdx) Then IsStringInArray = True
    Next ArrIdx
End Function

Unmark this post as useful.

Tags: ,
Posted in Microsoft Office | No Comments »

VBA: Create PowerPoint Slide for Each Row in Excel Workbook

Wednesday, June 8th, 2011

This may seem like a really weird thing to want to do. Imagine this though: You want a presentation to show off the names of a lot of students on a constant loop at a kiosk, and you don’t want to have to retype the names. VBA to the rescue.

This little snippet of code will do the following:

  1. Open a given Excel Document
  2. For Each used row in column A of sheet 1, create a copy the first slide in the presentation.
  3. Change the text of the first text box to the content of that cell

Easy. Here it is:

Sub CreateSlides()
'Open the Excel workbook. Change the filename here.
Dim OWB As New Excel.Workbook
Set OWB = Excel.Application.Workbooks.Open("C:\list.xlsx")
'Grab the first Worksheet in the Workbook
Dim WS As Excel.Worksheet
Set WS = OWB.Worksheets(1)
'Loop through each used row in Column A
For i = 1 To WS.Range("A65536").End(xlUp).Row
    'Copy the first slide and paste at the end of the presentation
    ActivePresentation.Slides(1).Copy
    ActivePresentation.Slides.Paste (ActivePresentation.Slides.Count + 1)
   
    'Change the text of the first text box on the slide.
    ActivePresentation.Slides(ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = WS.Cells(i, 1).Value
Next
End Sub

Paste this into a new module inside your PowerPoint presentation. You will need to add in a reference to Microsoft Excel Objects (Tools -> References). Change the name and location of the Excel file that you want to use.

If you set up the first slide exactly as you want it before running the macro, then the same formats and layout will be copied too. Alternatively use Slide Masters to set up all the slides after they have been created.

4 people found this post useful.
Unmark this post as useful.

Tags: ,
Posted in Office 2010 | 2 Comments »