Excel VB Code

[Ranjit kurian]

Hi

I have created a excel vb code to copy the pivots from excel to powerpoint
slide.

The problem iam facing is, unable to create a Textbox in the same active
powerpoint slide.

Could you please help me to write an excel vb code in excel, so that i can
add a text box to the active window powerpoint slide.

Below is the code i tried in excel macro,

while running its asking for an object.

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim slidecount As Long
Dim ans
Dim answer As String
Dim RangetoPaste As Range
Dim PPShape As Shape

ActiveWindow.Selection.SlideRange.Shapes.AddTextboxmsoTextOrientationHorizontal, 50, 50, 400, 24).Select
ActiveWindow.Selection.ShapeRange.TextFrame.Wordwrap

 

[Ranjit kurian]

Hi Steve,

Below is my excel macro code which open the powerpoint application of
previous week then delete the existing pictures and copy the new pictures
from excel sheet, till here its working fine for me , but after doing all
these things i need my excel macro to add text box to ppt slide and type a
text given by me.

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim slidecount As Long
Dim ans
Dim answer As String
Dim RangetoPaste As Range
Dim PPShape As Shape

'Open ppt file
Set PPApp = CreateObject("PowerPoint.Application")
PPApp.Visible = True
Set PPPres = PPApp.Presentations.Open("C:\Ranjith
Report\AR\Top5\Macro\Business Direct- Business Review.ppt",
ReadOnly:=msoFalse)

Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.View.GotoSlide 1
PPApp.ActiveWindow.ViewType = ppViewSlide

PPApp.ActiveWindow.Selection.sliderange.Shapes.SelectAll
PPApp.ActiveWindow.Selection.ShapeRange.Delete

slidecount = PPPres.slides.Count
Set PPSlide =
PPPres.slides(PPApp.ActiveWindow.Selection.sliderange.SlideIndex)
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
PPSlide.Shapes.Paste.Select

PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignmiddle, True

PPApp.ActiveWindow.Selection.ShapeRange.IncrementLeft -28.5
PPApp.ActiveWindow.Selection.ShapeRange.IncrementTop -148.62
PPApp.ActiveWindow.Selection.ShapeRange.ScaleWidth 0.96, msoFalse,
msoScaleFromTopLeft
PPApp.ActiveWindow.Selection.ShapeRange.ScaleWidth 0.97, msoFalse,
msoScaleFromBottomRight
PPApp.ActiveWindow.Selection.ShapeRange.ScaleHeight 1.46, msoFalse,
msoScaleFromTopLeft

'OtherPart

Windows("Regional Graphs Presentation.xls").Activate
Sheets("Billing-Not Paying Top 5").Select
Range("B4:J10").Select
Selection.EntireColumn.Hidden = True
Range("A4").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Set PPApp = GetObject(, "Powerpoint.Application")
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.View.GotoSlide 1
PPApp.ActiveWindow.ViewType = ppViewSlide

slidecount = PPPres.slides.Count
Set PPSlide =
PPPres.slides(PPApp.ActiveWindow.Selection.sliderange.SlideIndex)
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
PPSlide.Shapes.Paste.Select

PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignmiddle, True

PPApp.ActiveWindow.Selection.ShapeRange.IncrementLeft 56.75
PPApp.ActiveWindow.Selection.ShapeRange.IncrementTop 124.12
PPApp.ActiveWindow.Selection.ShapeRange.ScaleWidth 1.18, msoFalse,
msoScaleFromTopLeft
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
'PPApp.ActiveWindow.Selection.ShapeRange.ScaleWidth 1.06, msoFalse,
msoScaleFromBottomRight
PPApp.ActiveWindow.Selection.ShapeRange.ScaleHeight 1.39, msoFalse,
msoScaleFromTopLeft

 

[Ranjit kurian]

Hi Steve,

when i only copied add textbox code from your macro its not working, same as
the below manner i copied it, actually i want the macro to create a new
textbox, please help me...

Dim myRange As Range
Dim currShapeRange As PowerPoint.ShapeRange
Dim currShape As PowerPoint.Shape
Dim lngSlideHeight As Long
Dim lngSlideWidth As Long

' Add text box with text to Slide 1
Set currShape = PPPres.slides(1).Shapes _
..AddTextbox(msoTextOrientationHorizontal, 20, 20, 500, 500)
With currShape
With .TextFrame.textrange
..Text = "This is just an experiment"
With .ParagraphFormat
..Alignment = ppAlignLeft
..Bullet = msoFalse
End With
With .Font
..Bold = msoTrue
..Name = "Tahoma"
..Size = 24
End With
End With
'' Shrink text box to text it now contains
'width = .TextFrame.textrange.BoundWidth
'height = .TextFrame.textrange.BoundHeight
End With

 

[Ranjit kurian]

Hi Steve,

Thanks a lot, your advise helped me....