can somebody have a look at this code im using and tell me why the lockaspectratio will not shut off? I have commented out the width because the aspect ratio still remains on and each time I change height and width it will set its height and width to the ratio of the second line. I cant figure out why it wont work. anybody? thanks.
Code:
Sub wpp()
'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'NOTE: Must have PowerPoint Object Library Active in Order to Run _
(VBE > Tools > References > Microsoft PowerPoint 12.0 Object Library)
'SOURCE: [URL="http://www.TheSpreadsheetGuru.com"]www.TheSpreadsheetGuru.com[/URL]
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim D As Integer
Dim N As Date
Dim iCol As Long
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("a3:c13")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Application.ActivePresentation.PageSetup.SlideWidth = 600
'myPresentation.PageSetup.SlideWidth = 15.4 * 72
'myPresentation.PageSetup.SlideHeight = 7.5 * 72
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
Const themePath As String = "C:\Program Files\Microsoft Office\Document Themes 14\Apex.thmx"
mySlide.ApplyTheme "C:\Program Files\Microsoft Office\Document Themes 14\Apex.thmx"
'Find next Monday
'nextMonday = DateAdd("ww", 1, pdat - (Weekday(pdat, vbMonday) + 1))
D = Weekday(Now)
N = Date + (9 - D)
st = Format(N, "d")
sp = st + 6
mo = Format(N, "mmmm")
yr = Year(N)
NextMonday = N
mySlide.Shapes.Title.TextFrame.TextRange.Text = "Weekly Schedule" & vbCr & st & " - " & sp & " " & mo & " " & yr
'mySlide.
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShapeRange.Left = 8
myShapeRange.Top = 120
myShapeRange.Height = 416
'myShapeRange.Width = 120
For iCol = 3 To 90000
If Cells(3, iCol) = Date Then Exit For
Next iCol
ul = Cells(3, iCol).Address(rowabsolute:=False, columnabsolute:=False)
lr = Cells(3, iCol).Offset(10, 6).Address(rowabsolute:=False, columnabsolute:=False)
Set rng = ThisWorkbook.ActiveSheet.Range(ul & ":" & lr)
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
'myShapeRange.Select
'myShapeRange.LockAspectRatio = msoFalse
With myShapeRange
'.LockAspectRatio = msoFalse
'.ScaleHeight(45, msoFalse, msoScaleFromTopLeft)
.ScaleHeight 45, msoFalse, msoScaleFromTopLeft
.Left = 126
.Top = 120
.Height = 416 '<<<<<<<<<<<<<<<< here is where it sets the height, but the next line will reset this height
'.Width = 1320
End With
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
