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:
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