Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Powerpoint adding text to the left column

Status
Not open for further replies.
RodP

RodP

Programmer
Jan 9, 2001
109
GB
Hi Everyone,

Please could someone help me. I have a routine which creates a new slide, then imports a picture into that slide. I'd like to add the file name of the image to the text column which is on the left hand side. I'm not sure what this column is called and so apologies.

Many thanks in advance

RodP

Here's the code:

Code: 
Sub ImportImages()

Dim strTemp As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape

Dim sPictureWidth As Single
Dim sPictureHeight As Single
Dim sSlideWidth As Single
Dim sSlideHeight As Single
Dim sScaleFactor As Single


strFileSpec = InputBox("Please enter the path of the images / video files to import.  Make sure you add a '\' at the end!")
'needs to be eg. L:\Group\Research & Insight\Ads\Files sync'd to advert PC\Latest\

If strFileSpec = "" Then Exit Sub

strTemp = Dir(strFileSpec)

Do While strTemp <> ""

With ActivePresentation.Slides
    .Add .Count + 1, ppLayoutBlank
    ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Count
End With

strTempExt = LCase(Right(strTemp, 3))


If strTempExt = "mpg" Or strTempExt = "peg" Or strTempExt = "avi" Or strTempExt = "mp2" Then
    Set oPic = ActiveWindow.Selection.SlideRange.Shapes.AddMediaObject(FileName:=strFileSpec + strTemp, Left:=0, Top:=0, Width:=-1, Height:=-1)
Else
        If strTempExt = "jpg" Or strTempExt = "gif" Or strTempExt = "bmp" Then
            Set oPic = ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strFileSpec + strTemp, LinkToFile:=msoTrue, SaveWithDocument:=msoFalse, Left:=0, Top:=0, Width:=-1, Height:=-1)
        Else
            MsgBox "File: " & strTemp & " not imported." & Chr(10) & "Click Continue to carry on importing others."
            GoTo nxt
        End If
End If

    
'Reset it to its "real" 100% size
oPic.ScaleHeight 1, msoTrue
oPic.ScaleWidth 1, msoTrue
'End With

' Get slide width and height
sSlideWidth = ActivePresentation.PageSetup.SlideWidth
sSlideHeight = ActivePresentation.PageSetup.SlideHeight
'MsgBox sSlideWidth & " " & sSlideHeight

' Get current picture width and height
sPictureWidth = oPic.Width
sPictureHeight = oPic.Height
'MsgBox sPictureWidth & " " & sPictureHeight

'will the picture width or picture length reach the edge of the paper first?

If sPictureWidth / sSlideWidth > sPictureHeight / sSlideHeight Then sScaleFactor = sSlideWidth / sPictureWidth
If sPictureWidth / sSlideWidth < sPictureHeight / sSlideHeight Then sScaleFactor = sSlideHeight / sPictureHeight
If sPictureWidth / sSlideWidth = sPictureHeight / sSlideHeight Then sScaleFactor = sSlideHeight / sPictureHeight

' Resize picture
oPic.ScaleHeight CSng(sScaleFactor), msoTrue
oPic.ScaleWidth CSng(sScaleFactor), msoTrue


''old microsoft method - didn't work very well!

'' Get scale factor that will fit picture to slide
'    If sPictureWidth > sPictureHeight Then
'        sScaleFactor = sSlideWidth / sPictureWidth
'    Else
'        sScaleFactor = sSlideHeight / sPictureHeight
'    End If
'
'    ' Make picture a little smaller than slide
'    sScaleFactor = sScaleFactor - 0.15
'
'    ' Resize picture
'    oPic.ScaleHeight CSng(sScaleFactor), msoTrue
'    oPic.ScaleWidth CSng(sScaleFactor), msoTrue
'
    
    
    ' Move the picture to the center of the slide,
    ' and select it

    With ActivePresentation.PageSetup
        oPic.Left = (.SlideWidth \ 2) - (oPic.Width \ 2)
        oPic.Top = (.SlideHeight \ 2) - (oPic.Height \ 2)
        'oPic.Select
    End With


nxt:
' Get the next file that meets the spec and go round again
strTemp = Dir

Loop

End Sub
 
Sort by date Sort by votes
Hi Everyone,

Just wanting to see if anyone can help me resolve this issue. I'd like to import a number of images and add a title to each new slide in the notes column which is normally to the left of the slide. I've tried recording a macro and have hit a problem where it seems that the notes are actually one complete text string. The macro below shows that for the first slide inserted the start position is '2' (because there is a space and a character return in slide 1 I presume). The word 'Cadbury' is then added in. Another slide is added but when the word 'crunchy' is added the start position is 10. I was hoping to use the following routine (ImportABunch) to import numerous pics and video clips and at the same time add a comment (the filename).

Hope someone can help.

Many thanks inadvance

Rodp

Code: 
Sub Macro4()
'
' Macro recorded 14/05/2007 by Authorised User
'

    ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add(Index:=2, Layout:=ppLayoutBlank).SlideIndex
    ActiveWindow.Selection.SlideRange.Shapes.AddMediaObject(FileName:="C:\data\Adverts\Files for Monday morning meeting\Cadbury Digestives 'Happy Day'.mpg", Left:=228#, Top:=162#).Select
    ActiveWindow.Selection.Unselect
    ActivePresentation.Slides.Range.Select
    ActiveWindow.Selection.TextRange.Characters(Start:=2, Length:=0).Select
    With ActiveWindow.Selection.TextRange
        .Text = "Cadbury"
    End With
    ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add(Index:=3, Layout:=ppLayoutBlank).SlideIndex
    ActiveWindow.Selection.SlideRange.Shapes.AddMediaObject(FileName:="C:\data\Adverts\Files for Monday morning meeting\Crunchy nuttter ad.mpg", Left:=228#, Top:=162#).Select
    ActiveWindow.Selection.Unselect
    ActivePresentation.Slides.Range.Select
    ActiveWindow.Selection.TextRange.Characters(Start:=10, Length:=0).Select
    With ActiveWindow.Selection.TextRange
        .Text = "Crunchy"
    End With
    ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add(Index:=4, Layout:=ppLayoutBlank).SlideIndex
End Sub

This is the ImportABunch macro - works pretty well!

Code: 
Sub ImportABunch()

Dim strTemp As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Object


Dim sPictureWidth As Single
Dim sPictureHeight As Single
Dim sSlideWidth As Single
Dim sSlideHeight As Single
Dim sScaleFactor As Single
Dim new_slide_required As Boolean

strFileSpec = InputBox("Please enter the path of the images / video files to import.  Make sure you add a '\' at the end!")
'needs to be eg. L:\Group\Research & Insight\Ads\Files sync'd to advert PC\Latest\
'strFileSpec = "C:\PFS Pictures\beach party *.PNG"
' Ex. on a PC:  "C:\My Pictures\Flowers\*.PNG"

If strFileSpec = "" Then Exit Sub

importpic = MsgBox("If you plan to move the location of this ppt and it's linked files then you'll need to embed the pictures.  Do you want to embed them?", vbYesNoCancel)
If importpic = vbCancel Then Exit Sub


With ActivePresentation.Slides
    .Add .Count + 1, ppLayoutBlank
    ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Count
End With
new_slide_required = False

strTemp = Dir(strFileSpec)

Do While strTemp <> ""

If new_slide_required = True Then
    With ActivePresentation.Slides
    .Add .Count + 1, ppLayoutBlank
    ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Count
    End With
    new_slide_required = False
End If

strTempExt = LCase(Right(strTemp, 3))

MsgBox strTemp

If strTempExt = "mpg" Or strTempExt = "peg" Or strTempExt = "avi" Or strTempExt = "mp2" Or strTempExt = "wmv" Then
    Set oPic = ActiveWindow.Selection.SlideRange.Shapes.AddMediaObject(FileName:=strFileSpec + strTemp, Left:=0, Top:=0, Width:=-1, Height:=-1)
    oPic.Select
    ActiveWindow.Selection.ShapeRange.AnimationSettings.Animate = msoTrue
    ActiveWindow.Selection.ShapeRange.AnimationSettings.AdvanceMode = ppAdvanceOnTime
    ActiveWindow.Selection.ShapeRange.AnimationSettings.AdvanceTime = 0
    ActiveWindow.Selection.ShapeRange.AnimationSettings.PlaySettings.PlayOnEntry = msoTrue
    ActiveWindow.Selection.ShapeRange.AnimationSettings.PlaySettings.PauseAnimation = msoFalse
    'ActiveWindow.Selection.ShapeRange.AnimationSettings.PlaySettings.RewindMovie = msoTrue
    new_slide_required = True
Else
        If strTempExt = "jpg" Or strTempExt = "gif" Or strTempExt = "bmp" Then
            If importpic = vbYes Then Set oPic = ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strFileSpec + strTemp, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
            If importpic = vbNo Then Set oPic = ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strFileSpec + strTemp, LinkToFile:=msoTrue, SaveWithDocument:=msoFalse, Left:=0, Top:=0, Width:=-1, Height:=-1)
            new_slide_required = True
        Else
            MsgBox "File: " & strTemp & " not imported." & Chr(10) & "Click OK to continue importing."
            new_slide_required = False
            GoTo nxt
        End If
End If

    
'Reset it to its "real" 100% size
oPic.ScaleHeight 1, msoTrue
oPic.ScaleWidth 1, msoTrue
'End With

' Get slide width and height
sSlideWidth = ActivePresentation.PageSetup.SlideWidth
sSlideHeight = ActivePresentation.PageSetup.SlideHeight
'MsgBox sSlideWidth & " " & sSlideHeight

' Get current picture width and height
sPictureWidth = oPic.Width
sPictureHeight = oPic.Height
'MsgBox sPictureWidth & " " & sPictureHeight

'will the picture width or picture length reach the edge of the paper first?

If sPictureWidth / sSlideWidth > sPictureHeight / sSlideHeight Then sScaleFactor = sSlideWidth / sPictureWidth
If sPictureWidth / sSlideWidth < sPictureHeight / sSlideHeight Then sScaleFactor = sSlideHeight / sPictureHeight
If sPictureWidth / sSlideWidth = sPictureHeight / sSlideHeight Then sScaleFactor = sSlideHeight / sPictureHeight

' Resize picture
oPic.ScaleHeight CSng(sScaleFactor - 0.01), msoTrue
oPic.ScaleWidth CSng(sScaleFactor - 0.01), msoTrue


''old microsoft method - didn't work very well!

'' Get scale factor that will fit picture to slide
'    If sPictureWidth > sPictureHeight Then
'        sScaleFactor = sSlideWidth / sPictureWidth
'    Else
'        sScaleFactor = sSlideHeight / sPictureHeight
'    End If
'
'    ' Make picture a little smaller than slide
'    sScaleFactor = sScaleFactor - 0.15
'
'    ' Resize picture
'    oPic.ScaleHeight CSng(sScaleFactor), msoTrue
'    oPic.ScaleWidth CSng(sScaleFactor), msoTrue
'
    
    
    ' Move the picture to the center of the slide,
    ' and select it

    With ActivePresentation.PageSetup
        oPic.Left = (.SlideWidth \ 2) - (oPic.Width \ 2)
        oPic.Top = (.SlideHeight \ 2) - (oPic.Height \ 2)
        'oPic.Select
    End With
    
    'add comment to notes column  <<<Currently doesn't work!>>>
    'ActiveWindow.Selection.TextRange.Text = strTemp
    'ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Count
    

nxt:
' Get the next file that meets the spec and go round again
strTemp = Dir

Loop

End Sub
 
Upvote 0 Downvote
Hi Misterstick,

Sorry bit long winded! I'd like to add a comment into the notes section for each new slide (the left hand pane), based on the filename of the picture or video clip I import onto that specific slide (variable = strTemp).

Many thanks

RodP
 
Upvote 0 Downvote
Have you tried this ?
'add comment to notes column
ActivePresentation.Slides.Range.Select
ActiveWindow.Selection.TextRange.Text = strTemp

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Upvote 0 Downvote
Hi PHV,

Yes I've tried this, it always overwrites what ever is in the first slide comment as it assumes the start number is 0 because it's ommitted.

It sounds like I need to track the number of characters used after each note is inserted for each new slide, and then include a character return (Chr(13) i think). But there must be a simpler way I'm thinking.

Any ideas anyone?

Thanks

RodP
 
Upvote 0 Downvote
GDDAPOS powerpoint, i knew there was a reason i haven't been near it.
the notes pane doesn't have a Text property.
by default it seems to have two contained rectangle objects, and you want to add text to the second of them.
of course, if you've changed the template all bets are off.
try this:
Code: 
Sub SetNotes(sldTemp As Slide, strNewNote As String)
sldTemp.NotesPage.Shapes(2).TextFrame.TextRange.Text = strNewNote
End Sub

'this will set the notes text for all slides to "BOING!"
Sub TestMacro1()
Dim sldTemp As Slide
For Each sldTemp In ActivePresentation.Slides
  SetNotes sldTemp, "BOING!"
Next
End Sub

'this will set the text for slide "Slide1" to "BOING!"
Sub TestMacro2()
Dim sldTemp As Slide
Set sldTemp = ActivePresentation.Slides("Slide1")
SetNotes sldTemp, "BOING!"
End Sub

good luck,


mr s. <;)

 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

Andrzejek
  • Locked
  • Question
Outlook Template replace text 2
Replies
13
Views
2K
Andrzejek
Andrzejek
IcarusHallsorts
  • Locked
  • Question
I have a column of data in Column A
Replies
3
Views
424
Andrzejek
Andrzejek
linuxguyEastCoast
  • Locked
  • Question
export text from non-public docx, pptx, pdf
Replies
0
Views
457
linuxguyEastCoast
linuxguyEastCoast
feipezi
  • Locked
  • Question
How to make a recorded Excel macro (convert a text file to a Workbook) more efficient?
Replies
11
Views
652
SkipVought
S
remeng
  • Locked
  • Question
run PowerPoint macro on open
Replies
0
Views
195
remeng
remeng

Part and Inventory Search

Sponsor

Back
Top