UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> VBA Resizing An Object In Powerpoint, Office 2013    
 
   
dflak
post Apr 22 2015, 12:57 PM
Post#1


Utter Access VIP
Posts: 6,016
Joined: 22-June 04
From: North Carolina


I'm new to VBA in PowerPoint, I am basing my code on something I do similarly in Excel. This code works fine, it copies the objects to the pages and changes text, etc. as I want it to. The issue comes when I try to resize and reposition the object I just copied to a slide. The code doesn't seem to have any effect. I can use 72 or 72 million, the object all come out the same (wrong) size.

CODE
Sub MakePowerpoint()
Dim MyPath As String
Dim FileName As String

Dim objPPT As Object
Dim ppt As Object
Dim sld As Object
Dim shp As Object
Dim PPName As String
Dim shpIndex As Long
Dim CurSlide As Long

Dim sh As Excel.Worksheet
Dim ObjName As String
Dim ObjType As String
Dim PPSldNum As Long
Dim PPObjName As Long
Dim MyTop As Double
Dim MyLeft As Double
Dim MyHeight As Double
Dim MyWidth As Double
Dim cl As Range


MyPath = ThisWorkbook.Path
PPName = MyPath & "\" & Range("RptName")

FileCopy MyPath & "\PPT Template.pptx", PPName

' Open the PowerPoint Presentation
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
objPPT.presentations.Open PPName

Set ppt = objPPT.activepresentation
Set sld = ppt.slides(1)

' Replace the title on page 1
sld.Shapes("Slide 1 Title Dates").TextFrame.TextRange.Text = _
Replace(sld.Shapes("Slide 1 Title Dates").TextFrame.TextRange.Text, "<<DATE>>", Format(Now(), "mmmm dd yyyy"))
sld.Shapes("Slide 1 Title Dates").TextFrame.TextRange.Text = _
Replace(sld.Shapes("Slide 1 Title Dates").TextFrame.TextRange.Text, "<<WE>>", Range("Last_Sat"))
sld.Shapes("Slide 1 Title Dates").TextFrame.TextRange.Font.Size = 12

' Replace footer dates
CurSlide = 1 ' Looking for a way to skip the first slide only
For Each sld In ppt.slides
    If CurSlide > 1 Then
        sld.Shapes("Text Footer").TextFrame.TextRange.Text = "Week Ending: " & Range("Last_Sat")
    End If
    CurSlide = CurSlide + 1
Next

' Add objects
For Each cl In Range("Table_Objects[Excel Page]")
    Set sh = Sheets(cl.Value)           ' Excel Sheet
    ObjName = cl.Offset(0, 1).Value     ' Name of the thing to copy
    ObjType = cl.Offset(0, 2).Value     ' Type of the thing to copy
    PPSldNum = cl.Offset(0, 3).Value    ' PowerPoint slide number
    MyTop = cl.Offset(0, 5).Value       ' Top
    MyLeft = cl.Offset(0, 6).Value      ' Left
    MyHeight = cl.Offset(0, 7).Value    ' Height
    MyWidth = cl.Offset(0, 8).Value     ' Width
    
    Set sld = ppt.slides(PPSldNum)      ' Active Slide
    If ObjType = "Chart" Then
        sh.Shapes(ObjName).CopyPicture
    Else
        sh.Range(ObjName).CopyPicture
    End If
    sld.Shapes.Paste
    shpIndex = sh.Shapes.Count
    With sld.Shapes(shpIndex)
        .LockAspectRatio = msoFalse
        .Top = 72 * MyTop
        .Left = 72 * MyLeft
        .Height = 72 * MyHeight
        .Width = 72 * MyWidth
    End With
Next

End Sub
Go to the top of the page
 
dflak
post Apr 22 2015, 01:52 PM
Post#2


Utter Access VIP
Posts: 6,016
Joined: 22-June 04
From: North Carolina


Ack! Found it.

CODE
shpIndex = sh.Shapes.Count


sh is the "active" Excel sheet. sld is the "active" PowperPoint slide.

I changed it to
CODE
shpIndex = sld.Shapes.Count

and the world started to rotate in the right direction again.
Go to the top of the page
 


Custom Search
RSSSearch   Top   Lo-Fi    11th December 2017 - 09:38 PM