Related
I have searched for months to find an answer to my problem and think I'm close, but not sure how to rectify it. All my VBA knowledge comes from Google, Stack Overflow, & various forums so please excuse the state of my code.
Overall goal:
I have a PPT template file containing 1 template slide that has several charts full of "dummy" data, formatted exactly how I need it. I also have an Excel master file containing data on a particular sheet (also contains the VBA). I need to duplicate the template slide for numNames data rows, then on each slide populate the charts (and other items) with the real data contained in each row.
The issues:
Very low reliability of this code at scale. This code works well with numNames < ~15. If I have more rows of data/slides to populate, the code fails.
Sometimes graphs will "disappear" after populating with data leading to errors in later subs. This can happen to any of the circular graphs on any slide. I added .Refresh and .DoEvents to fix this, to no avail. Missing Graph
PPT sucks up a ton of available memory if I populate the charts too quickly which I think contributes to some of my headaches (hence the Application.Wait). I am using a work laptop running 64 bit Excel/PPT with approx 4GB RAM available at most times. Peak PPT memory usage ~1.3GB while inside loop. Not sure what is going on here.
I have tried Application.ScreenUpdating = false and it helps a bit, but the issues above still occur.
I believe all of my problems stem from how I'm populating these graphs with the real data, but so far I have not found any better solutions. I am looking for any advice on how to populate these graphs in a better/quicker way, or generally clean up this code so that it runs more smoothly. Thanks.
If you want to skip the setup portion of this sub, just ctrl+F '$
*some code here is not my own, not taking credit for any code I did not personally write
Option Explicit
'Excel
Public ProjectName As String
Public NewCtrlFileExists As String
Public wb As Workbook
Public ctrl As Worksheet
Public xData As Worksheet
Public iHeaders As Integer
Public numNames As Integer
Public FirstRow As Integer
Public LastRow As Integer
Public LastCol As Integer
'Powerpoint
Public myPres As PowerPoint.Presentation
'Error handling
Public errArea As String
Public g_objFSO As Scripting.FileSystemObject
Public g_scrText As Scripting.TextStream
Public Msg, Style, Response
Sub CreateDashboards()
'1. Add PPT refs to Excel: Tools > References > Microsoft PowerPoint
'2. Add error logging: Tools > References > Microsoft Scripting Runtime
iHeaders = 0
numNames = 0
FirstRow = 0
LastRow = 0
LastCol = 0
On Error GoTo Failure
Startup:
errArea = "Startup"
Set wb = Excel.Application.ActiveWorkbook
Sheet1.Activate 'Control sheet
Set ctrl = wb.ActiveSheet
'File names
ProjectName = ctrl.Range("ProjectName") 'project name
Dim PptTemplateName As String
PptTemplateName = ctrl.Range("PptTemplateName") 'template name
'Get data
Sheet2.Activate 'Data
Set xData = wb.ActiveSheet
iHeaders = 2
FirstRow = iHeaders + 1
LastRow = xData.UsedRange.Rows.Count
LastCol = xData.UsedRange.Columns.Count
numNames = LastRow - iHeaders
Initialize:
errArea = "Initialize"
ctrl.Range("PptReportName") = ProjectName 'PptReportName: default is project name, but also user-defined if desired
'Round and clean data
Call CleanData
'get E chart data
Dim rngEcols As Range
Set rngEcols = xData.Range("1:1")
Dim iEcount As Integer, lEstartCol As Integer, lEendCol As Integer
iEcount = Excel.Application.CountIf(rngEcols, "E")
lEstartCol = WorksheetFunction.Match("E", rngEcols, 0)
lEendCol = lEstartCol + iEcount - 1
'get max value for all E chart data
Dim dEmaxvalue As Single 'decimal
Dim dEAxisMax As Single 'decimal
dEmaxvalue = Application.Max(xData.Range(Cells(iHeaders + 1, lEstartCol), Cells(LastRow, lEendCol)))
'define the axis max as dEmaxvalue rounded up to nearest 10%, then add 5%
dEAxisMax = Application.RoundUp(dEmaxvalue, 1) + 0.05
'get attribute label positions
Dim lEstart, lEend
Set lEstart = xData.Cells((FirstRow - 1), lEstartCol)
Set lEend = xData.Cells((FirstRow - 1), lEendCol)
'get PPT
Set myPres = GetOpenOrClosedPPT(wb.Path & "\" & PptTemplateName & ".pptx")
myPres.Windows(1).Activate
'transpose attribute labels into PPT E chart
With myPres.Slides(1).Shapes("E").Chart
.ChartData.Workbook.Sheets(1).Range("A2:" & Cells(iEcount + 1, 1).Address & "") _
= Excel.Application.Transpose(xData.Range("" & lEstart.Address & ":" & lEend.Address & ""))
Dim rngEdata As Range 'get E data range
Set rngEdata = Range("A1:" & Cells(iEcount + 1, 2).Address & "")
Dim sEchartsource As String
sEchartsource = "='Sheet1'!" & rngEdata.Address & "" 'set chart data source to E data range
.SetSourceData Source:=sEchartsource
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue).MaximumScale = dEAxisMax
End With
Execute:
errArea = "Execute"
'create slide for each row of data
Dim i As Long
For i = 1 To numNames - 1 'template slide already exists
myPres.Slides(1).Duplicate
Next i
'populate slides with data
Dim lDataRow As Integer, lSldNum As Integer
lSldNum = 1
lDataRow = lSldNum + iHeaders 'account for headers
Dim Slide As Slide
Dim y As Integer
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$$$$$$ Begin populate chart data $$$$$$$$$$$$$$$$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
For Each Slide In myPres.Slides
errArea = "Slide " & lSldNum
myPres.Slides(lSldNum).Select
With myPres.Slides(lSldNum)
With .Shapes("B").Chart
.ChartData.Workbook.Sheets(1).Range("B2").Value = xData.Cells(lDataRow, 5) * 100
.Refresh
.ChartData.Workbook.Close
End With
With .Shapes("C").Chart
.ChartData.Workbook.Sheets(1).Range("B2").Value = xData.Cells(lDataRow, 6) * 100
.Refresh
.ChartData.Workbook.Close
End With
With .Shapes("E").Chart
For y = 1 To iEcount
.ChartData.Workbook.Sheets(1).Cells(1 + y, 2) = xData.Cells(lDataRow, (lEstartCol - 1) + y)
Next y
.Refresh
.ChartData.Workbook.Close
End With
With .Shapes("G").Chart
.ChartData.Workbook.Sheets(1).Range("B2").Value = xData.Cells(lDataRow, 11) * 100
.Refresh
.ChartData.Workbook.Close
End With
With .Shapes("K").Chart
.ChartData.Workbook.Sheets(1).Range("B2").Value = xData.Cells(lDataRow, 13) * 100
.Refresh
.ChartData.Workbook.Close
End With
End With
'increment slide & row indices
lSldNum = lSldNum + 1
lDataRow = lDataRow + 1
Application.Wait (Now + TimeValue("0:00:02"))
DoEvents
Next Slide
myPres.Slides(1).Select 'return to starting position
GoTo Success
Success:
'Write to log file
Call LogFile_Write(wb.Path, "LoadDashboards", "SUCCESS", numNames & " names' data loaded")
myPres.SaveAs Filename:=wb.Path & "\" & ProjectName & ".pptx"
'Notify user
AppActivate Application.Caption
MsgBox "Data loaded successfully.", vbSystemModal + vbInformation
Exit Sub
Failure:
'write to log file
Call LogFile_Write(wb.Path, "LoadDashboards", "ERROR", errArea & " - " & Err.Number & " - " & Err.Description)
'Notify user
AppActivate Application.Caption
MsgBox "An error occurred. Please try again.", vbSystemModal + vbCritical, "Error"
Exit Sub
End Sub
Public Function CleanData()
On Error GoTo Failure
Dim x As Integer 'Rows
Dim y As Integer 'Cols
For y = 3 To LastCol
Select Case y
'Round raw data to 2 decimal places
Case 5, 6, 7, 9, 11, 13 'E attributes data first, then E average
For x = FirstRow To LastRow
xData.Cells(x, y) = Application.WorksheetFunction.Round(xData.Cells(x, y), 2)
Next x
End Select
Next y
Exit Function
Failure:
'Write to log file
Call LogFile_Write(wb.Path, "CleanData", "ERROR", " - " & Err.Number & " - " & Err.Description)
'Notify user
AppActivate Application.Caption
MsgBox "An error occurred. Please try again.", vbSystemModal + vbCritical, "Error"
End Function
Public Function GetOpenOrClosedPPT(ByVal sTargetFullName As String) As Object
Dim funcPPTApp As Object
Dim p As PowerPoint.Presentation
On Error Resume Next
Set funcPPTApp = GetObject(, "PowerPoint.Application") 'Check if PPT is running
PPTisOpen:
If Not (funcPPTApp Is Nothing) Then 'If PPT is running
For Each p In funcPPTApp.Presentations 'For all open Presentations
If p.FullName = sTargetFullName Then 'If name matches target Presentation
Set GetOpenOrClosedPPT = p 'Set function result to Presentation
Exit Function
End If
Next p
GoTo PPTisNotOpen 'If PPT is running but file is not open
End If
PPTisNotOpen:
Set funcPPTApp = CreateObject("PowerPoint.Application")
funcPPTApp.Presentations.Open (sTargetFullName) 'Open target Presentation
Set GetOpenOrClosedPPT = funcPPTApp.Presentations(sTargetFullName) 'Set function result to Presentation
End Function
Public Function LogFile_Write( _
ByVal sPath As String _
, ByVal sProcedure As String _
, ByVal sType As String _
, ByVal sDescription As String)
Dim sFilePath As String
sFilePath = sPath & "\debug_log.txt" 'logfile path
Dim sText As String
On Error GoTo ErrorHandler
If (g_objFSO Is Nothing) Then
Set g_objFSO = New FileSystemObject 'Initialize var
End If
If (g_scrText Is Nothing) Then
If (g_objFSO.FileExists(sFilePath) = False) Then 'If logfile does not already exist, create one
Set g_scrText = g_objFSO.OpenTextFile(sFilePath, IOMode.ForWriting, True)
sText = "File created:" & Format(Date, "DD MMM YYYY") & vbCrLf
Else
Set g_scrText = g_objFSO.OpenTextFile(sFilePath, IOMode.ForAppending)
End If
End If
'Append new line to existing text
sText = sText & "- " & _
sProcedure & " " & _
sType & ": " & _
Format(Date, "DD MMM YYYY") & "-" & _
Time() & " || " & _
sDescription
g_scrText.WriteLine sText
g_scrText.Close
Set g_scrText = Nothing
Exit Function
ErrorHandler:
Set g_scrText = Nothing
Call MsgBox("Unable to write to log file", vbCritical, "LogFile_Write")
End Function
Try sleep command of windows. (sleep will pause the code for sometime)
To let charts sometime to refresh.
Type below line on top of the program:
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
In the code, after updating the charts and before closing the chart workbook,
Type:
sleep 5000
5000 is for 5 seconds, you can modify for your choice.
Regards,
Balu.
I have below macro that brings file from saved file from excel to PowerPoint what I need is to update the macro to bring one file per slide instead of bringing all into one slide
Sub CreatePagePerComment()
Dim PowerPointApp As Object
Dim myPPTX As Object
Dim mySlide As Object
Dim pptxNm As String
Dim pptNm As Range
Dim rSht As Worksheet
Dim oSht As Worksheet
Dim oPicture As Object
Set pptNm = ThisWorkbook.Sheets("Sheet1").[PPTX_File]
Sheets("Sheet1").[PPTX_File].Value = pptNm.Value
CONFIRM_PPTX_APP:
'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")
With pptNm.Validation
.Delete 'delete previous validation
End With
MsgBox "No PowerPoint file is open. Please open the PowerPoint file to where you " & _
"would like to export this table.", vbOKOnly + vbCritical, ThisWorkbook.Name
Exit Sub
End If
'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
GET_PPTX_FILENAME:
If pptNm.Value = "" Then
MsgBox "Please select the PowerPoint file name, from the drop down list, to where you want to export the Headcount Review summary table." & _
Chr(10) & Chr(10) & "This Macro has selected the cell that contains a list of all open PowerPoint files. " & Chr(10) & Chr(10) & _
"If your file is not listed, please confirm it is open, then select any other cell, then return to this cell for " & _
"a refreshed file name list.", vbOKOnly + vbCritical, "No PowerPoint File Selected"
pptNm.Select
Exit Sub
Else:
If InStr(1, pptNm.Value, "ppt") > 0 Then
pptxNm = pptNm.Value
ElseIf InStr(1, pptNm.Value, "pptx") > 0 Then
pptxNm = pptNm.Value & ".pptx"
ElseIf InStr(1, pptNm.Value, "pptm") > 0 Then
pptxNm = pptNm.Value & ".pptm"
End If
End If
pptxNm = "NN Commitment Cards.pptm"
Set myPPTX = PowerPointApp.Presentations(pptxNm)
PowerPointApp.Visible = True
PowerPointApp.Activate
'Adds second slide
'MsgBox SlideShowWindows(1).View.Slide.SlideIndex
Dim Nm_shp As Shape, sld_no As Integer
Dim pIndex As Integer, pName As String
sld_no = myPPTX.Slides.Count
pName = "Blue Transition"
pIndex = 3
ADD_NEW_SLIDE:
Dim SlideCnt As Integer
Set mySlide = myPPTX.Slides.Add(sld_no + 1, 12)
mySlide.Select
mySlide.CustomLayout = myPPTX.Designs("N_PPTX_Theme").SlideMaster.CustomLayouts(pIndex)
'mySlide.Shapes.AddOLEObject Left:=10, Top:=10, Width:=(7.5 * 72), Height:=(10 * 72),
' Filename:=[B1].Value & "\" & [A132].Value & ".pdf", displayasicon:=msoFalse, link:=msoTrue
For Each cel In [A3:A4]
If Cells(cel.Row, [A1].Column).Value <> "" Then
Set oPicture = mySlide.Shapes.AddPicture([B1].Value & "\" & cel.Value & ".png", _
msoFalse, msoTrue, Left:=10, Top:=10, Width:=(6 * 72), Height:=(7 * 72))
Set oSlide = myPPTX.Slides(1)
With oPicture
.Width = 7 * 72
.Height = 8 * 72
.PictureFormat.CropLeft = 0
.PictureFormat.CropTop = 0
.PictureFormat.CropRight = 0
.PictureFormat.CropBottom = oPicture.Height / 1.85
.Name = cel.Value
.Line.Weight = 0.5
.Line.Visible = msoTrue
.LockAspectRatio = msoTrue
.Left = 1.5 * 72
.Top = 1.5 * 72
With myPPTX.PageSetup
oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
End With
End With
End If
End Sub
What is the required tweak that I need to update in this macro to do so?
I am assuming the rest of your code is working and focusing only on your specific question. First, there is no reference to oSlide in your code, so I assume that's some typo. From my reading of your code, you add a new slide to the current slide and add a picture to it (or not since that section of code is commented out). Then, based on the content of [A3:A4], you want to add new slides, each with a new picture. I have discarded commented code and kept your code as unmodified as possible in providing this solution (change the required section fo your code):
'Adds second slide
'MsgBox SlideShowWindows(1).View.Slide.SlideIndex
Dim Nm_shp As Shape, sld_no As Integer
Dim pIndex As Integer, pName As String
sld_no = myPPTX.Slides.Count
pName = "Blue Transition"
pIndex = 3
ADD_NEW_SLIDE:
Dim SlideCnt As Integer
SlidCnt = 0
For Each cel In [A3:A4]
If Cells(cel.Row, [A1].Column).Value <> "" Then
SlideCnt = SlideCnt + 1
Set mySlide = myPPTX.Slides.Add(sld_no + SlideCnt, 12)
mySlide.CustomLayout = myPPTX.Designs("N_PPTX_Theme").SlideMaster.CustomLayouts(pIndex)
Set oPicture = mySlide.Shapes.AddPicture([B1].Value & "\" & cel.Value & ".png", _
msoFalse, msoTrue, Left:=10, Top:=10, Width:=(6 * 72), Height:=(7 * 72))
With oPicture
.Width = 7 * 72
.Height = 8 * 72
.PictureFormat.CropLeft = 0
.PictureFormat.CropTop = 0
.PictureFormat.CropRight = 0
.PictureFormat.CropBottom = oPicture.Height / 1.85
.Name = cel.Value
.Line.Weight = 0.5
.Line.Visible = msoTrue
.LockAspectRatio = msoTrue
.Left = 1.5 * 72
.Top = 1.5 * 72
With myPPTX.PageSetup
oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
End With
End With
End If
Next cel
I have a code for inserting an attached file to a certain column and resizing it so that it perfectly fills the cell. Only problem I have now is that the object is just a blank rectangle and hard to spot if there is even anything in the cell.
I've tried IconLabel:=Range("A" & ActiveCell.Row) so that it shows the ID # of the row but it seems to show it very stretched out and to the point where you can't see anything.
Sub Macro1()
Range("X" & ActiveCell.Row).Select
Dim vFile As Variant, Sh As Object
vFile = Application.GetOpenFilename("All Files,*.*", Title:="Find file to insert")
If vFile = False Then Exit Sub
Dim OleObj As OLEObject
Set OleObj = ActiveSheet.OLEObjects.Add(Filename:=vFile, Link:=False, DisplayAsIcon:=True, IconFileName:= _
"C:\WINDOWS\Installer\{90110409-6000-11D3-8CFE-0150048383C9}\xlicons.exe", _
IconIndex:=0, IconLabel:=Range("A" & ActiveCell.Row).Value)
OleObj.ShapeRange.LockAspectRatio = msoFalse
OleObj.Height = Range("X" & ActiveCell.Row).Height
OleObj.Width = Range("X" & ActiveCell.Row).Width
End Sub
This would make the cell red, because of the vbRed, furthermore, it would be about 4 times less than the standard cell:
With OleObj
.ShapeRange.LockAspectRatio = msoFalse
.Height = Range("X" & ActiveCell.Row).Height / 2
.Width = Range("X" & ActiveCell.Row).Width / 2
.Interior.Color = vbRed
End With
Thus, it would be different and visible. These are the other built-in colors, from the VBA library (Press F2):
Is there any way to align Center Header in Excel? I know there is no any built in solution but is there any VBA code that would work. I have been trying copying cells to header, setting center header with VBA but my Center Header is "Align Center" all the time.
I have even found very complex code to calculate length of sentences and add spaces to each row but it doesn't really work correctly.
I can also set rows to repeat on top and forget about header but what about footer then? How I can set Center Footer to align my two row text to align left?
I have tried:
With ActiveSheet.PageSetup
.LeftHeader = Range("a1").Value & " " & Range("b1").Value & " " & Range("a2").Value & " " & Range("b2").Value
End With
Also sending named range to header:
Option Explicit
Sub SetCenterHeader()
Dim txt As String
Dim myRow As Range
With Range("NorthHead") ' reference named range
For Each myRow In .Rows ' loop through referenced range rows
txt = txt & Join(Application.Transpose(Application.Transpose(myRow.Value)), " ") & vbLf ' update 'txt' with current row cells values joined and separated by a blank
Next
End With
ActiveSheet.PageSetup.CenterHeader = Left(txt, Len(txt) - 1) ' set CenterHeader with resulting 'txt' excluding last vblf character
ActiveWindow.SelectedSheets.PrintOut Copies:=1
End Sub
Result is always the same:
May try the following workaround and modify to your requirements
Sub test2()
Dim CenHd1 As String, CenHd2 As String, Fname As String
Dim Rng As Range
Dim Sht As Worksheet, MnSht As Worksheet
Dim Cht As ChartObject
Set Sht = ThisWorkbook.Worksheets(3)
Set MnSht = ThisWorkbook.Worksheets(1)
Set Rng = Sht.Range("F1:F2")
CenHd1 = "Excel"
CenHd2 = "I am already left Aligned"
Sht.Range("F1").Value = CenHd1
Sht.Range("F2").Value = CenHd2
Sht.Activate
ActiveWindow.DisplayGridlines = False
With Rng
.Columns.AutoFit 'added after taking trial snapshot to perfectly center and left align
.HorizontalAlignment = xlLeft
.Font.Name = "Bookman Old Style"
.Font.Size = 12
'May specify other visual effects
End With
Rng.CopyPicture xlScreen, xlPicture
Set Cht = Sht.ChartObjects.Add(0, 0, Rng.Width * 1.01, Rng.Height * 1.01)
Cht.Name = "TmpChart"
Sht.Shapes("TmpChart").Line.Visible = msoFalse
Cht.Chart.Paste
Fname = "C:\Users\user\Desktop\CentHead " & Format(Now, "dd-mm-yy hh-mm-ss") & ".jpg"
Cht.Chart.Export Filename:=Fname, Filtername:="JPG"
DoEvents
Cht.Delete
ActiveWindow.DisplayGridlines = True
MnSht.Activate
With MnSht.PageSetup.CenterHeaderPicture
.Filename = Fname
'.Height = 275.25
'.Width = 463.5
'.Brightness = 0.36
'.ColorType = msoPictureGrayscale
'.Contrast = 0.39
'.CropBottom = 0
'.CropLeft = 0
'.CropRight = 0
'.CropTop = 0
End With
'Enable the image to show up in the center header.
MnSht.PageSetup.CenterHeader = "&G"
'for Trial only
ActiveWindow.View = xlPageLayoutView
' Clear junk files
If Dir(Fname) <> "" Then Kill (Fname)
End Sub
Tried as follows
the code could also be modified as a function / procedure with parameters for repeated use with different Sheets, Workbooks etc. Hope it will help to serve the purpose.
How to add image to specific named placeholder using VBA in Powerpoint (from Excel)
I've been trying to figure this one out for a while.
I've copied all my code below. What I am try to do I add 3 images to a Powerpoint in a format that I was provided.
The problem I experience, is that, when an imge isn't found (I've told the system to resume), the next image appears in the previous Placeholder. Not in the one I want it to.
The PowerPoint is Open, and as you can see, I've even tried selecting the placeholder to see if that makes a difference.
If there isn't a work around for this. Can anyone suggest how to capture that an Image didn't populate, so I can populate with an image that says "Image not available" Just to keep everything in the right place?
Search below for : If oPPtShp.PlaceholderFormat.Type = ppPlaceholderPicture Then
to find the start of the IF where I load in the images.
Please help!
Sub AddPPT2010()
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files (x86)\Microsoft Office\Office14\MSPPT.OLB"
Const imgFileName = "PrintIcon"
Const GUIDRef = "{91493440-5A91-11CF-8700-00AA0060263B}"
Set PrntIcon = Application.CommandBars.FindControl(ID:=4)
On Error Resume Next 'Ignore Error If Reference Already Established
ThisWorkbook.VBProject.References.AddFromGuid GUIDRef, 2, 10
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files (x86)\Microsoft Office\Office14\MSPPT.OLB"
Call addPPT2000
Call CreateSlides
MsgBox "Powerpoint Presentation build complete.", vbOKOnly
End Sub
Sub addPPT2000()
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files (x86)\Microsoft Office\Office14\MSPPT.OLB"
Const imgFileName = "PrintIcon"
Const GUIDRef = "{91493440-5A91-11CF-8700-00AA0060263B}"
Set PrntIcon = Application.CommandBars.FindControl(ID:=4)
On Error Resume Next 'Ignore Error If Reference Already Established
ThisWorkbook.VBProject.References.AddFromGuid GUIDRef, 2, 7
On Error Resume Next
Application.VBE.ActiveVBProject.References.AddFromFile "C:\Program Files (x86)\Microsoft Office\Office14\MSPPT.OLB"
End Sub
Sub CreateSlides()
'Dim the Excel objects
Dim objWorkbook As New Excel.Workbook
Dim objWorksheet As Excel.Worksheet
'Dim the File Path String
Dim strFilePath As String
'Dim the PowerPoint objects
Dim PPT As Object
Dim pptSlide As PowerPoint.Slide
Dim pptLayout As PowerPoint.CustomLayout
Dim pptNewSlide As PowerPoint.Slide
Dim str As String
Dim Title As String
Dim oPPtShp As PowerPoint.Shape
Set PPT = GetObject(, "PowerPoint.Application")
PPT.Visible = True
'Get the layout of the first slide and set a CustomLayout object
Set pptLayout = PPT.ActivePresentation.Slides(1).CustomLayout
'Run the OpenFile function to get an Open File dialog box. It returns a String containing the file and path.
strFilePath = OpenFile()
'Open the Excel file
Set objWorkbook = Excel.Application.Workbooks.Open(strFilePath)
'Grab the first Worksheet in the Workbook
Set objWorksheet = objWorkbook.Worksheets(1)
'Loop through each used row in Column A
For i = 2 To objWorksheet.Range("A65536").End(xlUp).Row
Set PPT = GetObject(, "PowerPoint.Application")
Set pptNewSlide = PPT.ActivePresentation.Slides.AddSlide(PPT.ActivePresentation.Slides.Count + 1, pptLayout)
PPT.ActivePresentation.Slides(1).Shapes("picture 9").Copy
pptNewSlide.Shapes.Paste
'Get the number of columns in use on the current row
Dim LastCol As Long
Dim boldWords As String
'Find the words to bold
boldWords = "Release Date: ,Distributor: ,Director: ,Genre: ,Starring: "
LastCol = objWorksheet.Rows(i).End(xlToRight).Column
If LastCol = 16384 Then LastCol = 1 'For some reason if only column 1 has data it returns 16384, so correct it
'Build a string of all the columns on the row
str = ""
str = "Release Date: " & str & objWorksheet.Cells(i, 4).Value & Chr(13) & _
"Distributor: " & objWorksheet.Cells(i, 18).Value & Chr(13) & _
"Director: " & objWorksheet.Cells(i, 7).Value & Chr(13) & _
"Genre: " & objWorksheet.Cells(i, 16).Value & Chr(13) & _
"Starring: " & objWorksheet.Cells(i, 10).Value & Chr(13) & Chr(13) & _
objWorksheet.Cells(i, 6).Value
sfile = Cells(i, 13) & ".jpg"
Set PPT = GetObject(, "PowerPoint.Application")
'Write the string to the slide
pptNewSlide.Shapes(2).TextFrame.TextRange.Text = objWorksheet.Cells(i, 2).Value 'This enters the film Title
PPT.ActivePresentation.Slides(PPT.ActivePresentation.Slides.Count).Shapes(1).TextFrame.TextRange.Text = str
BoldSomeWords PPT.ActivePresentation.Slides(PPT.ActivePresentation.Slides.Count).Shapes(1), str, boldWords
'~~> Get hold of PPT instance
Set PPT = GetObject(, "Powerpoint.Application")
'~~> Reference the slide which contains picture placeholders
Set pptSlide = PPT.ActivePresentation.Slides(PPT.ActivePresentation.Slides.Count)
Imagenum = 1
For Each oPPtShp In pptSlide.Shapes.Placeholders
' Run the Error handler "ErrHandler" when an error occurs.
Const SpecialCharacters As String = "!,#,#,$,%,^,&,*,(,),{,[,],},:,."
Dim originalstring As String
Dim convertedstring As String
On Error Resume Next
'~~> Only need to work on Picture place holders
If oPPtShp.PlaceholderFormat.Type = ppPlaceholderPicture Then
With oPPtShp
oPPtShpName = oPPtShp.Name
pptSlide.Shapes(oPPtShpName).Select
If oPPtShp.Name = oPPtShpName And Imagenum = 1 Then paths = "C:\"
If oPPtShp.Name = oPPtShpName And Imagenum = 2 Then paths = "C:\"
If oPPtShp.Name = oPPtShpName And Imagenum = 3 Then paths = "C:\"
If oPPtShp.Name = oPPtShpName And Imagenum = 1 Or oPPtShp.Name = oPPtShpName And Imagenum = 2 Then originalstring = objWorkbook.Worksheets(1).Cells(i, 2).Value
convertedstring = "Test" 'originalstring
For Each char In Split(SpecialCharacters, ",")
convertedstring = Replace(convertedstring, char, " ")
Next
If oPPtShp.Name = oPPtShpName And Imagenum = 1 Then pptSlide.Shapes.AddPicture paths & convertedstring & ".jpg", msoFalse, msoTrue, _
.Left, .Top, .Width, .Height Else
If oPPtShp.Name = oPPtShpName And Imagenum = 2 Then pptSlide.Shapes.AddPicture paths & convertedstring & " - Copy" & ".jpg", msoFalse, msoTrue, _
.Left, .Top, .Width, .Height Else
If oPPtShp.Name = oPPtShpName And Imagenum = 3 Then pptSlide.Shapes.AddPicture paths & convertedstring & " - Copy (2)" & ".png", msoFalse, msoTrue, _
.Left, .Top, .Width, .Height
' If oPPtShp.Name = oPPtShpName And Imagenum = 3 Then pptSlide.Shapes.AddPicture paths & objWorkbook.Worksheets(1).Cells(i, 11).Value & " - Copy (2)" & ".png", msoFalse, msoTrue, _
.Left, .Top, .Width, .Height
DoEvents
End With
Imagenum = Imagenum + 1
End If
Next
On Error Resume Next
'Assign the Trailer to the Powerpoint View Trailer Image
Set oSh = pptSlide.Shapes("WatchTrailer")
With oSh.ActionSettings(ppMouseClick)
.Hyperlink.Address = objWorksheet.Cells(i, 8).Value
End With
Set oPPtSlide = Nothing
Set oPPt = Nothing
Next
End Sub
Function OpenFile()
'Dim the File Dialog object and string
Dim objFileDialog As FileDialog
Dim strFile As String
'Set the objFileDialog to an instance of the FileDialog object
Set objFileDialog = Application.FileDialog(msoFileDialogFilePicker)
'Set the Properties of the objFileDialog object
objFileDialog.AllowMultiSelect = False
objFileDialog.ButtonName = "Select"
objFileDialog.InitialView = msoFileDialogViewDetails
objFileDialog.Title = "Select Excel File"
objFileDialog.InitialFileName = "C:\"
objFileDialog.Filters.Clear
objFileDialog.Filters.Add "Excel", "*.xls; *.xlsx", 1
objFileDialog.FilterIndex = 1
'Show the FileDialog box
objFileDialog.Show
'Set strFile to the first record of the SelectedItems property of our FileDialog
strFile = objFileDialog.SelectedItems(1)
'Return the File Path string
OpenFile = strFile
End Function
Sub BoldSomeWords(shp As Object, str As String, boldWords As String)
Dim word As Variant
Dim iStart As Integer, iEnd As Integer
'Convert the list of words in to an iterable array, and
' iterate it.
For Each word In Split(boldWords, ",")
'Loop just in case there are duplicates
Do Until InStr(iEnd + 1, str, word) = 0
iStart = InStr(iStart + 1, str, word)
iEnd = iStart + Len(word)
shp.TextFrame.TextRange.Characters(iStart, Len(word)).Characters.Font.Bold = msoTrue
Loop
Next
End Sub
Different versions of PPT behave differently wrt placeholders. If you add an image, some will automatically drop the image into the first available empty content or picture placeholder, some will just drop the image onto the slide.
I'd be more inclined to record the position/size of each placeholder then delete them. THEN drop in the images and position/size them to match.
If you MUST use the placeholders for some reason (and I'm sure there are lots of good reasons), you might want to distribute a dummy "not available" image with your code and drop that in when the needed image isn't available.
Or ... perhaps better yet ... if the image isn't available and it's a content placeholder, put in some dummy text, something unique. Now the PH isn't empty any longer so when you drop in the next image, it won't go into that PH. Finally, at the end, look for any PH type shapes and if they contain your unique text, delete the text (leaving you with an empty PH again).
Something that might be worth a go (though as Steve says versions behave differently)
Add the picture to a temp blank slide and cut
Select the correct placehoder on the real slide
ActiveWindow.View.Paste