PDA

View Full Version : Sleeper: Dynamic PowerPoint Creating by Excel



Paleo
01-17-2005, 06:50 PM
Hi,

I am trying to create two PowerPoint slides from Excel VBA, but it is not working. I did create the slides and the titles, but I cant create the content. I am trying to put some data from excel in it. My code is this:


Sub MakePowerPoint()
Dim AppPPT As New PowerPoint.Application
Dim Pre As Presentation
Dim Sld As Slide
Set Pre = AppPPT.Presentations.Add
AppPPT.Visible = True
AppActivate "Microsoft Excel", False
cont1 = Application.Goto(Reference:="tblRS")
cont1 = Application.Goto(Reference:="tblUS")
AppActivate "Microsoft PowerPoint", False
Dim txtTexto1, txtTexto2
txtTexto1 = Array("Title 1", "Title 2")
txtTexto2 = Array(cont1, cont2)
Dim i As Integer
For i = 0 To UBound(txtTexto1)
Set Sld = Pre.Slides.Add(Index:=i + 1, Layout:=ppLayoutText)
With Sld
.Shapes(1).TextFrame.TextRange.text = txtTexto1(i)
.Shapes(2).TextFrame.TextRange.text = txtTexto2(i)
End With
Next
With AppPPT
.ActiveWindow.Selection.Unselect
.ActivePresentation.SaveAs Filename:="C:\Paleo\powerpoint.ppt"
End With
End Sub




:help :help :banghead:

Jacob Hilderbrand
01-17-2005, 07:00 PM
Can you attach the Excel workbook you are using so we can get a better idea of what you want to do?

I cut out some of your code to make it work for me.



Option Explicit

Sub MakePowerPoint()
Dim AppPPT As New PowerPoint.Application
Dim Pre As Presentation
Dim Sld As Slide
Dim i As Integer
Set Pre = AppPPT.Presentations.Add
AppPPT.Visible = True
For i = 1 To 2
Set Sld = Pre.Slides.Add(Index:=i, Layout:=ppLayoutText)
With Sld
.Shapes(1).TextFrame.TextRange.Text = "This is the title"
.Shapes(2).TextFrame.TextRange.Text = "This is the main body"
End With
Next
End Sub

Is tblRS a named range? Do you want the text from that range?

cont1 = Range("tblRS").Text

Paleo
01-17-2005, 07:26 PM
Hi Jacob,

"tblRS" and "tblUS" are tables. Many rows and many columns. Named areas.

Creating a Word Document I use this code that works just fine and I need to make this for PowerPoint.



Sub MakeWord()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim myVersao As String
myVersao = "1.0"
Dim wordApp As Object
Set wordApp = CreateObject("word.application")
With wordApp
.Documents.Add Template:="", NewTemplate:=False
.Visible = False
With .Selection
.TypeText text:="Test Report"
.Style = wordApp.ActiveDocument.Styles("Title 1")
.Font.Size = 14
.Font.Bold = wdToggle
.Font.Color = wdColorDarkBlue
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.TypeParagraph
.TypeText text:="Created at " + Format(Date, "Long Date")
.TypeParagraph
.TypeText text:="Complimentary Grades"
.Style = wordApp.ActiveDocument.Styles("Title 2")
.TypeParagraph
End With
With .ActiveDocument.Bookmarks
.Add Range:=wordApp.Selection.Range, _
Name:="Grades"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
With .Selection
.TypeParagraph
.TypeParagraph
.TypeText text:="Report prepared by Excel Macro version " + myVersao
.TypeParagraph
End With
End With
AppActivate "Microsoft Excel", False
Application.Goto Reference:="tblRS"
Selection.Copy
wordApp.Selection.Goto Name:="Grades"
wordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
Placement:=wdFloatOvertext, DisplayAsIcon:=False
wordApp.ActiveDocument.SaveAs Filename:="Grades " & Month(Date) _
& Year(Date) & ".doc", FileFormat:=wdFormatDocument, LockComments:=False, _
Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
wordApp.Application.Quit
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Jacob Hilderbrand
01-17-2005, 09:52 PM
Try this:



Option Explicit

Sub MakePowerPoint()
Dim AppPPT As New PowerPoint.Application
Dim Pre As Presentation
Dim Sld As Slide
Dim txtTexto1(1 To 2) As String
Dim txtTexto2(1 To 2) As Range
Dim i As Long
Dim cont1 As Range
Dim cont2 As Range
Set Pre = AppPPT.Presentations.Add
AppPPT.Visible = True
Set cont1 = Range("tblRS")
Set cont2 = Range("tblUS")
txtTexto1(1) = "Title 1"
txtTexto1(2) = "Title 2"
Set txtTexto2(1) = cont1
Set txtTexto2(2) = cont2
For i = 1 To 2
Set Sld = Pre.Slides.Add(Index:=i, Layout:=ppLayoutText)
With Sld
.Shapes(1).TextFrame.TextRange.Text = txtTexto1(i)
txtTexto2(i).Copy
.Shapes(2).TextFrame.TextRange.Paste
End With
Next
AppPPT.ActivePresentation.SaveAs Filename:="C:\Paleo\powerpoint.ppt"
End Sub

Paleo
01-18-2005, 03:46 PM
Hi Jacob,

well it generated the PowerPoint and it was great, but my tables have lost their alignments. How could I tell PowerPoint it should be shown as a table?

Paleo
01-19-2005, 07:33 PM
I have tried using this code:



ActiveWindow.Selection.SlideRange.Shapes.AddOLEObject _
(Left:=120, Top:=110, Width:=480, Height:=320, _
ClassName:="Excel.Sheet.8", Link:=msoFalse).Select
ActiveWindow.Selection.ShapeRange.OLEFormat.Activate
With ActiveWindow.Selection.ShapeRange
.Left = 119.625
.Top = 110.25
.Width = 480.75
.Height = 319.5
End With


But it didnt work. Any help?

Jacob Hilderbrand
01-20-2005, 07:25 PM
You can add a table like there. Then put the data in cell buy cell.


With Sld
.Shapes(1).TextFrame.TextRange.Text = txtTexto1(i)
txtTexto2(i).Copy
.Shapes(2).TextFrame.TextRange.Paste
.Shapes.AddTable 3, 2
End With

Paleo
01-20-2005, 08:34 PM
Hi Jacob,

ok, this code inserted a table with 3 rows and 2 columns, but its not what I need yet. I need to show the content from txtTexto2(i) in that table. This text is an excel sheet contaning 9 columns and 13 rows. Any suggestions?

Jacob Hilderbrand
01-20-2005, 08:42 PM
You can change the table to the number of rows/columns you want.

.Shapes.AddTable 13, 9

Paleo
01-20-2005, 08:48 PM
Hi Jacob,

sorry I misexpressed. Ok, I can creat the table to size I want but my problem is: I need to put the txtTexto2(i) content inside that table. How may I do that?

Jacob Hilderbrand
01-20-2005, 09:50 PM
You can try something like this to add the text to each cell in the table.


Sub MakePowerPoint()

Dim AppPPT As New PowerPoint.Application
Dim Pre As Presentation
Dim Sld As Slide
Dim txtTexto1(1 To 2) As String
Dim txtTexto2(1 To 2) As Range
Dim i As Long
Dim cont1 As Range
Dim cont2 As Range
Dim Table1 As PowerPoint.Shape
Dim j As Long
Dim TextCol As New Collection
Dim Counter As Long
Set Pre = AppPPT.Presentations.Add
AppPPT.Visible = True
Set cont1 = Range("tblRS")
'Set cont2 = Range("tblUS")
'txtTexto1(1) = "Title 1"
'txtTexto1(2) = "Title 2"
Set txtTexto2(1) = cont1
Set txtTexto2(2) = cont2
For i = 1 To 13 'Rows
For j = 1 To 9 'Columns
TextCol.Add Cells(i, j).Text
Next j
Next i
For i = 1 To 1
Set Sld = Pre.Slides.Add(Index:=i, Layout:=ppLayoutText)
With Sld
'.Shapes(1).TextFrame.TextRange.Text = txtTexto1(i)
'txtTexto2(i).Copy
'.Shapes(2).TextFrame.TextRange.Paste
Set Table1 = .Shapes.AddTable(13, 9)
With Table1
For j = 117 To 1 Step -1
Counter = Counter + 1
On Error Resume Next
.GroupItems(Index:=j).TextFrame.TextRange.Text = _
TextCol(Counter)
Next j
End With
End With
Next
'AppPPT.ActivePresentation.SaveAs Filename:="C:\Paleo\powerpoint.ppt"
End Sub