working with excel to make a powerpoint of a few ranges that i need to send out each week. i usually do this manually and would like to get this process automated. i have it to the point now that it will create the powerpoint and paste the ranges i need. the powerpoint is just the way i need it.
the problem is when i try to save the powerpoint, i get an error. i cant get anything to work to get this saved. anybody have any ideas?
the problem is when i try to save the powerpoint, i get an error. i cant get anything to work to get this saved. anybody have any ideas?
Code:
Sub wpp()
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 fileNameString As String
Dim D As Integer
Dim N As Date
Dim iCol As Long, iRow As Long, iRow2 As Long
Dim userResponce As Range
Dim wTitle As String
ThisWorkbook.Sheets("weekly").Select
'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
'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
'nmonday = DateAdd("ww", 1, pdat - (Weekday(pdat, vbMonday) + 1))
D = Weekday(Now)
N = Date + (9 - D)
'N = Date + 54
st = N 'Format(N, "d")
sp = st + 6
mo = Format(N, "mmmm")
yr = Year(N)
nextmonday = Format(N, "d-mmm-yy")
'MsgBox Format(st, "mmmm")
If Format(st, "mmmm") = Format(sp, "mmmm") Then
wTitle = "Weekly Schedule" & vbCr & Format(st, "d") & " - " & Format(sp, "d") & " " & mo & " " & yr
Else
wTitle = "Weekly Schedule" & vbCr & Format(st, "d mmm yy") & " - " & Format(sp + 6, "d mmm yy")
End If
mySlide.Shapes.Title.TextFrame.TextRange.Text = wTitle
'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) = N Then Exit For
Next iCol
ul = Cells(3, iCol).Address(rowabsolute:=False, columnabsolute:=False) ' set upper left of range
lr = Cells(3, iCol).Offset(10, 6).Address(rowabsolute:=False, columnabsolute:=False) ' set lower right of range
Set rng = ThisWorkbook.ActiveSheet.Range(ul & ":" & lr)
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
With myShapeRange
.LockAspectRatio = 0 'msoFalse
'.ScaleHeight(45, msoFalse, msoScaleFromTopLeft)
'.ScaleHeight 45, msoFalse, msoScaleFromTopLeft
.Left = 128.5
.Top = 120
.Height = 416
.Width = 583
End With
ThisWorkbook.Sheets("schedule").Select
For iRow = 3 To 90000
If Cells(iRow, 1) = N Then Exit For
Next iRow
For iRow2 = 3 To 90000
If Cells(iRow2, 1) = N + 7 Then Exit For
Next iRow2
ul2 = Cells(iRow, 1).Offset(-1, 0).Address(rowabsolute:=False, columnabsolute:=False) ' set upper left of range
lr2 = Cells(iRow2, 12).Offset(-3, 0).Address(rowabsolute:=False, columnabsolute:=False) ' set lower right of range
Set rng = ThisWorkbook.ActiveSheet.Range(ul2 & ":" & lr2)
rng.Copy
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(2, ppLayoutCustom)
mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
With myShapeRange
.LockAspectRatio = 0 'msoFalse
.Left = 0
.Top = 0
.Height = 539
.Width = 722
End With
'Clear The Clipboard
Application.CutCopyMode = False
'MsgBox "Edit PowerPoint?"
'------------------------------------------- NONE OF THE SAVING BELOW WORKS, AS YOU CAN SEE IVE TRIED SEVERAL THINGS
'FileN = "EMAILED WEEKLY " & Format(st, "d") & " - " & Format(sp, "d") & " " & mo & " " & yr
fileN = "EMAILED WEEKLY " & wTitle
'myPresentation.SaveAs Filename:="[URL="file://\\SharedDrive\PowerPoints\"]\\SharedDrive\PowerPoints\[/URL]" & FileN & ".pptx"
fileNameString = "[URL="file://\\SharedDrive\PowerPoints\"]\\SharedDrive\PowerPoints\[/URL]" & fileN ' & ".pptx"
'With myPresentation ' ActivePresentation
' .SaveAs Filename:="\\SharedDrive\PowerPoints\" & FileN & ".pptx", _
' FileFormat:=ppSaveAsOpenXMLPicturePresentation 'ppSaveAsOpenXMLPresentation
'End With
myPresentation.SaveCopyAs fileNameString, ppSaveAsOpenXMLPresentationMacroEnabled ', ppSaveAsOpenXMLPresentation
'ppApp.Quit
End Sub
