Powerpoint macro for inserting images and text

Hello, I have found a very useful powerpoint macro online to auto insert images and text , creidt is given here, http://answers.yahoo.com/question/index?qid=20101102070307AAU3gDh, I have posted the part where the text is added, but I need to modify it to make it larger it only fits one short line of text now, I would like the ability to have up to 3 lines) and I need to add a white background to the text so it can show up against the images'-Thanks!!
'next 4 lines define TextBox(TB) position and dimensions in terms of those of slide
TBPosFromSlideLeftMargin = 0.1 'TB start at 10% of slide width from left to right
TBPosFromSlideTopMargin = 0.8 'TB start at 80% of slide height from top to bottom
TBpercentageOfSlideWidth = 0.8 'TB is 80% of the slide width
TBpercentageOfSlideHeight = 0.2 'TB is 20% of the slide height
Set oDes = oSld.Shapes.AddTextbox( msoTextOrientationHorizontal, _
ActivePresentation. PageSetup.SlideWidth * TBPosFromSlideLeftMargin, _
ActivePresentation. PageSetup.SlideHeight * TBPosFromSlideTopMargin, _
ActivePresentation. PageSetup.SlideWidth * TBpercentageOfSlideWidth, _
ActivePresentation. PageSetup.SlideHeight * TBpercentageOfSlideHeight)
With oDes
.TextFrame.TextRange.Text = picDesc(1)
End With 

Open in new window

cssoftwareAsked:
Who is Participating?
 
JSRWilsonCommented:
That's because I assumed you have three entries for text (one per line) in Excel.

I would NOT use the method for inserting pictures you use. It has never been necessary to specify the width and height and in any version after 2007 will distort the image. It happens to work in 2007 but it isn't correct.

Using MY code you just need to alter this bit:

With oTB
.TextFrame2.WordWrap = True
.TextFrame.TextRange.Text = picDesc(1)
.Fill.ForeColor.RGB = vbWhite
End With
0
 
JSRWilsonCommented:
Are you actually using Excel to store the text as in the original? If so what does the CSV look like?

Are you adding a picture too? The version of office will help too.

Assuming you need something like the original try

Sub ImportABunchWithTextFromFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim picDesc() As String
Dim oSld As Slide
Dim oPic As Shape
Dim oTB As Shape
Dim SW As Long
Dim SH As Long
Dim fs As Object
Dim f As Object
SW = ActivePresentation.PageSetup.SlideWidth
SH = ActivePresentation.PageSetup.SlideHeight
strPath = ActivePresentation.Path
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strPath & "\book1.txt", 1, 0)
Do While f.AtEndOfStream <> True
picDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
Set oPic = oSld.Shapes.AddPicture(FileName:=picDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0)
Set oTB = oSld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=SW * 0.1, _
Top:=SH * 0.8, _
Width:=SW * 0.8, _
Height:=SH * 0.2)

With oTB
.TextFrame.TextRange.Text = picDesc(1) & vbCrLf & picDesc(2) & vbCrLf & picDesc(3)
.Fill.ForeColor.RGB = vbWhite
End With
With oPic
.LockAspectRatio = msoTrue
If oPic.Width / oPic.Height > SW / SH Then
.Width = SW
.Top = (SH - oPic.Height) / 2
Else
.Height = SH
.Left = (SW - oPic.Width) / 2
End If
End With
Loop
End Sub
0
 
cssoftwareAuthor Commented:
Hi and thank you for you assistance! I tried the macro and got
 Runtime error 9 subscript out of range.
I even tried with very short text lines and also the only image that was placed before the error message image did not stretch to fill the slide, here is the macro I am currently running below. (I am actually just using a txt file with a tab stop between the image path and the text for book1.txt like this:
C:\insurance2\6.jpg      Lorum Ipsum

which worked fine, except the text is hard to read without a background, and sometimes I need it to wrap 2-3 lines, and also using powerpoint 2007 )

Sub ImportABunchWithTextFromFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As slide
Dim oPic As Shape
strPath = ActivePresentation.Path
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strPath & "\book1.txt", 1, 0)  'book1.txt need to be "Text(Tab delimited)(*.txt)" when saved in Excel

Do While f.AtEndOfStream <> True
picDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
Set oPic = oSld.Shapes.AddPicture(FileName:=picDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=0, _
Height:=0)
'next 4 lines define TextBox(TB) position and dimensions in terms of those of slide
TBPosFromSlideLeftMargin = 0.1 'TB start at 10% of slide width from left to right
TBPosFromSlideTopMargin = 0.8 'TB start at 80% of slide height from top to bottom
TBpercentageOfSlideWidth = 0.8 'TB is 80% of the slide width
TBpercentageOfSlideHeight = 0.2 'TB is 20% of the slide height
Set oDes = oSld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
ActivePresentation.PageSetup.SlideWidth * TBPosFromSlideLeftMargin, _
ActivePresentation.PageSetup.SlideHeight * TBPosFromSlideTopMargin, _
ActivePresentation.PageSetup.SlideWidth * TBpercentageOfSlideWidth, _
ActivePresentation.PageSetup.SlideHeight * TBpercentageOfSlideHeight)
With oDes
.TextFrame.TextRange.Text = picDesc(1)
End With

With oPic
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With

With oPic
Dim appssw, appssh
appssw = ActivePresentation.PageSetup.SlideWidth
appssh = ActivePresentation.PageSetup.SlideHeight
.LockAspectRatio = msoTrue
If oPic.Width / oPic.Height > appssw / appssh Then
.Width = appssw
.Top = (appssh - oPic.Height) / 2
Else
.Height = appssh
.Left = (appssw - oPic.Width) / 2
End If
End With
Set oPic = Nothing
Set oDes = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub

Open in new window

0
 
cssoftwareAuthor Commented:
Perfect!! Thank you so much and happy holidays!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.