Solved

Powerpoint macro for inserting images and text

Posted on 2013-11-28
4
1,064 Views
Last Modified: 2013-11-29
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

0
Comment
Question by:cssoftware
  • 2
  • 2
4 Comments
 
LVL 23

Expert Comment

by:JSRWilson
Comment Utility
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
 

Author Comment

by:cssoftware
Comment Utility
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
 
LVL 23

Accepted Solution

by:
JSRWilson earned 500 total points
Comment Utility
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
 

Author Comment

by:cssoftware
Comment Utility
Perfect!! Thank you so much and happy holidays!
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

Microsoft goes to great lengths to ensure that the users don’t encounter issues while working with MS Outlook. But errors are inevitable and can occur when you least expect them. One of such errors which are encountered in Outlook is Error 0x800ccc1…
It’s a strangely common occurrence that when you send someone their login details for a system, they can’t get in. This article will help you understand why it happens, and what you can do about it.
This video teaches viewers how to create handouts from their slides and helps them decide how many slides to include per handout.
The viewer will learn how to edit animations within the presentation, incorporate sound, and set everything up with timing.

743 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now