Using below code for saving MS Word images and converting into base64.
When exporting the image it adds some borders.
Original Image
after export
If singleline.Range.InlineShapes.Count > 0 Then
Dim shp1 As InlineShape
Dim mchart1 As Shape
Set shp1 = singleline.Range.InlineShapes(1)
shp1.Select
Selection.Copy
Set mchart1 = ActiveDocument.Shapes.AddChart(xl3DAreaStacked, , , shp1.Width, shp1.Height)
mchart1.Chart.ChartData.Workbook.Application.Quit
mchart1.Chart.Paste
mchart1.Chart.Export ("c:\here\" + CStr(i) + ".png")
mchart1.Chart.Delete
b64strng = ConvertFileToBase64("c:\here\" + CStr(i) + ".png")
Kill "c:\here\" + CStr(i) + ".png"
End If
Is there any fix or Alternative to export images?
I don't see any difference between your screenshots, possibly because of the dark browser background. Is the border visible after the Export command, or after the ConvertFileToBase64 function?
It appears you're trying to export a non-chart graphic by using a chart kludge. You'll get better results by enlisting PowerPoint to do the graphics export. Here's a sample macro that shows how to export Word graphics from PowerPoint. You can modify this to export a single Shape or ShapeRange (your graphic) instead of a complete slide.
Public Sub ExportMap()
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShapeRange As PowerPoint.ShapeRange
Dim Path$, File$
Dim oRange As Range
Application.ScreenUpdating = False
If ActiveDocument.ProtectionType = wdAllowOnlyFormFields Then
ActiveDocument.Unprotect
End If
myDate$ = Format(Date, "m-d-yyyy")
Set pptApp = CreateObject("PowerPoint.Application")
Path$ = ActiveDocument.Path & Application.PathSeparator
File$ = "WorldMap " & myDate$ & ".png"
Set pptPres = pptApp.Presentations.Add(msoFalse)
Set oRange = ActiveDocument.Bookmarks("WholeMap").Range
oRange.CopyAsPicture
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
On Error Resume Next
With pptPres.PageSetup
.SlideSize = 7
.SlideWidth = 1150
.SlideHeight = 590
End With
Set pptShapeRange = pptSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoFalse)
With pptShapeRange
.Top = .Top + 6
' .Left = .Left + 510
End With
pptSlide.Export Path$ & File$, "PNG"
pptApp.Quit
Set pptPres = Nothing
Set pptApp = Nothing
Set pptSlide = Nothing
If ActiveDocument.ProtectionType = wdNoProtection Then
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, noreset:=True
End If
Application.ScreenUpdating = True
MsgBox "All done! Check the folder containing this template for a file called '" & File$ & "'."
End Sub
Related
I have an existing piece of code (see below) for importing a batch of photos and creating a slide show. At present, the code is creating these slides on a blank background with a title only. How can I modify it so it will choose a specific slide layout from the Master slides? I know it has something to do with this line in the code:
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
I looked here and tried some ideas but I just keep getting bugs: Applying layout to a slide from specific Master
Here's the full program:
Sub ImportStuffFromTextFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
When you say you keep getting bugs, what do you mean?
Are you getting error messages? If so, what are the error numbers/descriptions? Where does the code break?
If not, and you're getting 'bugs', what should the final output look like and how does this differ from that?
I would say that one big unknown here is the text file input. According to your code, it seems as though it needs to have a series of filenames and corresponding picture descriptions on each line of the text file, separated by a tab. Critically, it must be a tab and not 2 spaces or 4 spaces or 10 spaces or a hyphen ... it must be a tab. Is that the structure of the text file you're using as input?
PowerPoint treats built-in layouts differently than custom ones. You can't call a custom layout by name. Instead, you have to loop through each custom layout to find the one that has the right name, then use it:
Sub AddSlideFromCustomLayout()
Dim oLayout As CustomLayout
Dim oSlide As Slide
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSlide = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
End Sub
Here's your listing with the code replacing the Set oSld line:
Sub ImportStuffFromTextFile()
Dim oLayout As CustomLayout
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSld = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
This is what I have for my macro so far (details on question below):
Sub saveWithLogo()
Dim fd As FileDialog
Dim directory As String
Dim vrtSelectedItem As Variant
Dim osld As Slide
Dim oPic As Shape
Dim osldGroup As Slide
Dim oshp As Shape
Dim logoPic As Shape
Dim i As Integer
Dim num_pics As Integer
Dim fso As New FileSystemObject
Dim fileName As String
Dim filePath As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd 'Get pictures from file dialog, add logo to each picture
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
numPics = .SelectedItems.Count
fileName = fso.GetBaseName(vrtSelectedItem)
filePath = fso.GetParentFolderName(vrtSelectedItem)
Set osld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
Set oPic = osld.Shapes.AddPicture(vrtSelectedItem, msoFalse, msoTrue, 50, 50)
logoWidth = 6.18 * 28.3
logoHeight = 1.4 * 28.3
Set logoPic = osld.Shapes.AddPicture("C:\Pictures\Logo\" & "logo.png", lsoFalse, msoTrue, 50, 50, logoWidth, logoHeight)
Next vrtSelectedItem
End If
End With
For i = 1 To numPics 'Groups pictures on slide
Set osldGroup = ActivePresentation.Slides(i)
ActivePresentation.Slides(i).Select
ActiveWindow.Selection.Unselect
For Each oshp In osldGroup.Shapes
If oshp.Type = msoPicture Then oshp.Select Replace:=False
Next oshp
With ActiveWindow.Selection.ShapeRange
If .Count > 1 Then .Group
End With
'ActivePresentation.Slides(i).Select
'Call ActiveWindow.Selection.SlideRange.Shapes.Export(filePath & fileName & "_with logo", ppShapeFormatJPG, 3072)
Next i
Set fd = Nothing
End Sub
From here I want to take the grouped photo from each slide and save it to the file location of the fd selected items and save each grouped photo as an amended version of the original selected item.
So if I have selected items: "photo1.jpg", "thisphoto.png" and "somedescriptivename.jpg" all from the same folder (say "C:\Documents\myproject\images\" I want it to save the new grouped photos to "C:\Documents\myproject\images\" as "photo1_with logo.jpg", "thisphoto_with logo.jpg", and "somedescriptivename_with logo.jpg".
Right now I can successfully get all the pictures onto slides and group them. I don't know how to get a unique string name for each vrtSelectedItem in .SelectedItems. I know I can change
Dim fileName As String
to
Dim fileName() As String
in order to save it that way but I don't know how to reference that in the for loop (fso.GetBaseName(vrtSelectedItem.Index)?). And I'm also getting the error "Compile error: Method or data member not found" when attempting to save the group.
It may solve the problem. It is not tried fully as Final Export method is throwing PowerPoint converter installation problem in my present system. But otherwise there is no error like "Compile error: Method or data member not found"
May simply try collection
Option Base 1
'
'
' then in Declaration
Dim FileName As New Collection
Dim FilePath As New Collection
Dim FinalName As String
'
'
'the in For Each vrtSelectedItem In .SelectedItems
FileName.Add fso.GetBaseName(vrtSelectedItem)
FilePath.Add fso.GetParentFolderName(vrtSelectedItem)
'
'
'
' then in For i = 1 To numPics after End With
FinalName = FilePath(i) & "\" & FileName(i) & "_with logo"
ActivePresentation.Slides(i).Select
'MsgBox FinalName
ActivePresentation.Slides(i).Export FinalName , ppShapeFormatJPG, 3072
Could not understand if you are placing earlier saved pictures in slides and placing logo on them? if it is that simple then may try simpler alternative with single loop
Sub saveWithLogo()
Dim fd As FileDialog
Dim directory As String
Dim vrtSelectedItem As Variant
Dim osld As Slide
Dim oPic As Shape
Dim osldGroup As Slide
Dim oshp As Shape
Dim logoPic As Shape
Dim i As Integer
Dim num_pics As Integer
Dim fso As New FileSystemObject
Dim FileName As String
Dim FilePath As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd 'Get pictures from file dialog, add logo to each picture
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
numPics = .SelectedItems.Count
FileName = fso.GetBaseName(vrtSelectedItem)
FilePath = fso.GetParentFolderName(vrtSelectedItem)
Set osld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
Set oPic = osld.Shapes.AddPicture(vrtSelectedItem, msoFalse, msoTrue, 50, 50)
osldno = ActivePresentation.Slides.Count
logoWidth = 6.18 * 28.3
logoHeight = 1.4 * 28.3
Set logoPic = osld.Shapes.AddPicture("C:\foxpro2\vtools\logo.bmp", lsoFalse, msoTrue, 50, 50, logoWidth, logoHeight)
osld.Select
ActiveWindow.Selection.Unselect
For Each oshp In osld.Shapes
If oshp.Type = msoPicture Then oshp.Select Replace:=False
Next oshp
With ActiveWindow.Selection.ShapeRange
If .Count > 1 Then .Group
End With
FinalName = FilePath & "\" & FileName & "_with logo"
'MsgBox FinalName
osld.Export FinalName & "_with logo", ppShapeFormatJPG ' , 3072
Next vrtSelectedItem
End If
End With
Set fd = Nothing
End Sub
For the curios or those with the same problem. Here's the final successful macro with what I learned from Ahmed's Answer.
I added image scaling since the output size was way smaller than the original.
Sub saveWithLogo()
Dim fd As FileDialog
Dim directory As String
Dim vrtSelectedItem As Variant
Dim osld As Slide
Dim oPic As Shape
Dim osldGroup As Slide
Dim oshp As Shape
Dim logoPic As Shape
Dim i As Integer
Dim num_pics As Integer
Dim fso As New FileSystemObject
Dim fileName As New Collection
Dim filePath As New Collection
Dim finalName As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd 'Get pictures from file dialog, add logo to each picture
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
numPics = .SelectedItems.Count
fileName.Add fso.GetBaseName(vrtSelectedItem)
filePath.Add fso.GetParentFolderName(vrtSelectedItem)
Set osld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
Set oPic = osld.Shapes.AddPicture(vrtSelectedItem, msoFalse, msoTrue, 50, 50)
With oPic
.LockAspectRatio = msoTrue
.ScaleWidth 1.875, msoTrue
End With
logoWidth = 6.18 * 28.3
logoHeight = 1.4 * 28.3
Set logoPic = osld.Shapes.AddPicture("C:\Pictures\Logo Images\" & "logo.png", lsoFalse, msoTrue, 100, 85, logoWidth, logoHeight)
With logoPic
.LockAspectRatio = msoTrue
.ScaleWidth 0.005 * oPic.Width, msoTrue
End With
Set oPic = Nothing
Set logoPic = Nothing
Next vrtSelectedItem
End If
End With
For i = 1 To numPics 'Groups pictures on slide
Set osldGroup = ActivePresentation.Slides(i)
ActivePresentation.Slides(i).Select
ActiveWindow.Selection.Unselect
For Each oshp In osldGroup.Shapes
If oshp.Type = msoPicture Then oshp.Select Replace:=False
Next oshp
With ActiveWindow.Selection.ShapeRange
If .Count > 1 Then
.Group
End If
End With
Next i
Dim ap As Presentation: Set ap = ActivePresentation
Dim sl As Slide
Dim shGroup As ShapeRange
For Each sl In ap.Slides
ActiveWindow.View.GotoSlide (sl.SlideIndex)
sl.Shapes.SelectAll
Set shGroup = ActiveWindow.Selection.ShapeRange
shGroup.Export filePath(sl.SlideIndex) & "\" & fileName(sl.SlideIndex) & "_with logo" & ".jpg", ppShapeFormatJPG, , , ppScaleXY
Next
Set fd = Nothing
Dim v As Long
For v = 1 To Application.ActivePresentation.Slides.Count
ActivePresentation.Slides.Range(1).Delete
Next v
End Sub
I have to write a script that parses the images from ppt and dumps into excel. To do this, I first export all the images in the slides to a folder and then call excel Application to import them into the worksheet. The following code, which I found online, with my modifications is as follows:
Sub ExtractImagesFromPres()
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim Ctr As Integer
Dim ObjExcel As Object
Dim wb As Object
Dim ws As Object
Set ObjExcel = CreateObject("Excel.Application")
Dim sPath As String
sPath = "C:\Users\Aravind_Sampathkumar\Documents\Expor"
Ctr = 0
Set wb = ObjExcel.Workbooks.Open("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
Set ws = wb.Sheets(1)
'Open oPres.Path & PathSep & "Book1.CSV" For Output As iFile
For Each oSldSource In ActivePresentation.Slides
For Each oShpSource In oSldSource.Shapes
If oShpSource.Type = msoPicture Then
' Hidden Export method
Call oShpSource.Export(sPath & "Img" & Format(Ctr, "0000") & ".JPG", ppShapeFormatJPG)
Ctr = Ctr + 1
End If
Next oShpSource
Next oSldSource
Folderpath = "C:\Users\Aravind_Sampathkumar\Documents\Expor"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 1
For Each fls In listfiles
strCompFilePath = Folderpath & "\" & Trim(fls.Name)
If strCompFilePath <> "" Then
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
counter = counter + 1
' ws.Range("C" & counter).Value = fls.Name
ws.Range("D" & counter).ColumnWidth = 25
ws.Range("D" & counter).RowHeight = 100
ws.Range("D" & counter).Activate
'Call insert(strCompFilePath, counter)
ws.Shapes.AddPicture strCompFilePath, True, True, 100,100,70,70
End If
End If
Next
'ws.Shapes.AddPicture ("C:\Users\Aravind_Sampathkumar\Documents")
'With .ShapeRange
' .LockAspectRatio = msoTrue
' .Width = 100
'.Height = 100
'End With
' .Left = ws.Cells(i, 20).Left
'.Top = ws.Cells(i, 20).Top
'.Placement = 1
'.PrintObject = True
'End With
End Sub
When I run it, the images get dumped into excel but all the images are overlapped on each other in the same cell. Is there any way I can modify it such that images go into consecutive rows? 1 image per row?
This puts them a row apart but you would need to size them appropriately. Note I changed your paths for test paths.
Option Explicit
Sub ExtractImagesFromPres()
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim Ctr As Integer
Dim ObjExcel As Object
Dim wb As Object
Dim ws As Object
Set ObjExcel = CreateObject("Excel.Application")
Dim sPath As String
sPath = "C:\Users\User\Desktop\TestFolder" '"C:\Users\Aravind_Sampathkumar\Documents\Expor"
Ctr = 0
Set wb = ObjExcel.Workbooks.Open("C:\Users\User\Desktop\TestFolder\Test.xlsx") '("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
ObjExcel.Visible = True
Set ws = wb.Sheets(1)
For Each oSldSource In ActivePresentation.Slides
For Each oShpSource In oSldSource.Shapes
If oShpSource.Type = msoPicture Then
Call oShpSource.Export(sPath & "\" & "Img" & Format(Ctr, "0000") & ".JPG", ppShapeFormatJPG)
Ctr = Ctr + 1
End If
Next oShpSource
Next oSldSource
Dim Folderpath As String
Dim fso As Object
Dim NoOfFiles As Long
Dim listfiles As Object
Dim counter As Long
Dim fls As Variant
Dim strCompFilePath As String
Folderpath = "C:\Users\User\Desktop\TestFolder" '"C:\Users\Aravind_Sampathkumar\Documents\Expor"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
counter = 1
For Each fls In listfiles
strCompFilePath = Folderpath & "\" & Trim(fls.Name)
If strCompFilePath <> vbNullString Then
If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
counter = counter + 1
' ws.Range("C" & counter).Value = fls.Name
ws.Range("D" & counter).ColumnWidth = 25
ws.Range("D" & counter).RowHeight = 100
ws.Range("D" & counter).Activate
'Call insert(strCompFilePath, counter)
With ws.Pictures.Insert(strCompFilePath)
.Left = ws.Cells(counter, "D").Left
.Top = ws.Cells(counter, "D").Top
End With
End If
End If
Next
End Sub
Have a look at the documentation for the AddPicture method:
https://msdn.microsoft.com/en-us/vba/excel-vba/articles/shapes-addpicture-method-excel
expression.AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
Rather than adding the picture at the active cell, it's location is controlled by the Left and Top arguments. You can use the Left and Top properties of the target cell as the arguments of the AddPicture method:
ws.Shapes.AddPicture strCompFilePath, True, True, ws.Range("D" & counter).Left, ws.Range("D" & counter).Top,70,70
Here's a version that uses copy/paste instead of export/import - it does include the line to change the row height if you want to crib just that.. :P
Sub ExtractImagesFromPres()
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim ObjExcel As Object
Dim wb As Object
Dim ws As Object
Set ObjExcel = CreateObject("Excel.Application")
Dim lOffset AS Long
Set wb = ObjExcel.Workbooks.Open("C:\Users\Aravind_Sampathkumar\Documents\Book1.xlsx")
Set ws = wb.Sheets(1)
'Open oPres.Path & PathSep & "Book1.CSV" For Output As iFile
lOffset = 5
For Each oSldSource In ActivePresentation.Slides
For Each oShpSource In oSldSource.Shapes
If oShpSource.Type = msoPicture Then
oShpSource.Copy
ws.Paste
With ws.Shapes(ws.Shapes.Count)
.Top = lOffset
.Left = 5
.Placement = 3 'xlFreeFloating
'This line sets the row height!
.TopLeftCell.EntireRow.RowHeight = 10 + .Height
lOffset = lOffset + .Height + 10
End With
End If
Next oShpSource
Next oSldSource
'Optional Tidy-Up code
'Set ws = Nothing
'wb.Save
'Set wb = Nothing
'ObjExcel.Quit
'Set ObjExcel = Nothing
End Sub
I'm 100% certain you can export the images from PPT directly to XLS, but I'm not really sure how to do that. However, since you are able to export those images from PPT into a folder, and you just need help importing the images from there, I thin the code below will do just what you want.
Sub InsertPics()
Dim fPath As String, fName As String
Dim r As Range, rng As Range
Application.ScreenUpdating = False
fPath = "C:\your_path_here\"
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
i = 1
For Each r In rng
fName = Dir(fPath)
Do While fName <> ""
If fName = r.Value Then
With ActiveSheet.Pictures.Insert(fPath & fName)
.ShapeRange.LockAspectRatio = msoTrue
Set px = .ShapeRange
If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width
With Cells(i, 2)
px.Top = .Top
px.Left = .Left
.RowHeight = px.Height
End With
End With
End If
fName = Dir
Loop
i = i + 1
Next r
Application.ScreenUpdating = True
End Sub
' Note: you need the file extension, such as ',jpg', or whatever you are using, so you can match on that.
Sub Insert()
Dim strFolder As String
Dim strFileName As String
Dim objPic As Picture
Dim rngCell As Range
strFolder = "C:\Users\Public\Pictures\Sample Pictures\" 'change the path accordingly
If Right(strFolder, 1) <> "\" Then
strFolder = strFolder & "\"
End If
Set rngCell = Range("E1") 'starting cell
strFileName = Dir(strFolder & "*.jpg", vbNormal) 'filter for .png files
Do While Len(strFileName) > 0
Set objPic = ActiveSheet.Pictures.Insert(strFolder & strFileName)
With objPic
.Left = rngCell.Left
.Top = rngCell.Top
.Height = rngCell.RowHeight
.Placement = xlMoveAndSize
End With
Set rngCell = rngCell.Offset(1, 0)
strFileName = Dir
Loop
End Sub
I have the following code, I attempted to modify it so it loops through a list in excel, opens each ppt file in the list and copies that to a new ppt file. But it is getting hung up and has an error during the loop.
Sub tmp()
'Set a VBE reference to Microsoft PowerPoint Object Library
On Error GoTo ErrorHandler
Dim PPApp As PowerPoint.Application
Dim i, j As Integer
Dim pres1, new_pres As PowerPoint.Presentation
Dim oslide, s, oSld As PowerPoint.Slide
Dim oShape, oSh, oshp As PowerPoint.Shape
Dim wb As Workbook
Dim list As Worksheet
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set new_pres = PPApp.Presentations.Add
Set wb = ThisWorkbook
Set list = wb.Worksheets("Powerpoint File List")
LastRow = list.Range("A" & Rows.Count).End(xlUp).Row
new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen
' this is not working
For i = 1 To 1 ' LastRow
filepath = list.Range("A" & i).Value
Set pres1 = PPApp.Presentations.Open(filepath)
For j = 1 To pres1.Slides.Count
pres1.Slides.shapes(j).Copy
new_pres.Slides.Paste
new_pres.Application.CommandBars.ExecuteMso "PasteSourceFormatting")
Next j
pres1.Close
Set pres1 = Nothing
Next I
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub
I got it to work, it was the PasteSourceFormatting that I needed when running from powerpoint that wasn't needed when converting to excel. This pulls every file from the list, opens, copies to a master powerpoint with formatting intact, and closes. in the end I have a new master powerpoint that has all of the presentations that are on the list
Sub tmp()
'Set a VBE reference to Microsoft PowerPoint Object Library
Application.CutCopyMode = False
On Error GoTo ErrorHandler
Dim PPApp As PowerPoint.Application
Dim i As Integer, j As Integer
Dim pres1 As PowerPoint.Presentation, new_pres As PowerPoint.Presentation
Dim oslide As PowerPoint.Slide, s As PowerPoint.Slide, oSld As PowerPoint.Slide
Dim oShape As PowerPoint.Shape, oSh As PowerPoint.Shape, oshp As PowerPoint.Shape
Dim PPShape As Object
Dim wb As Workbook
Dim list As Worksheet
Set PPApp = CreateObject("Powerpoint.Application")
PPApp.Visible = True
Set new_pres = PPApp.Presentations.Add
Set wb = ThisWorkbook
Set list = wb.Worksheets("Powerpoint File List")
LastRow = list.Range("A" & Rows.Count).End(xlUp).Row
new_pres.PageSetup.SlideSize = ppSlideSizeOnScreen
' this is not working
k = 1
For i = 1 To LastRow
filepath = list.Range("A" & i).Value
Set pres1 = PPApp.Presentations.Open(filepath)
For j = 1 To pres1.Slides.Count
pres1.Slides(j).Copy
new_pres.Slides.Paste
' new_pres.Slides.Paste
' new_pres.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")
k = k + 1
Next j
pres1.Close
Set pres1 = Nothing
Next i
For Each oSld In new_pres.Slides
oSld.HeadersFooters.Clear
oSld.HeadersFooters.SlideNumber.Visible = msoFalse
oSld.HeadersFooters.DateAndTime.Visible = msoFalse
Next oSld
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 700, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.InsertSlideNumber
End With
'ActivePresentation.PageSetup.FirstSlideNumber = 0
new_pres.Slides(1).DisplayMasterShapes = msoTrue
Set oshp = Nothing
response = MsgBox(prompt:="Is this For Official Use Only?", Buttons:=vbYesNo)
If response = vbYes Then
txt = "For Official Use Only"
' If statement to check if the yes button was selected.
Else
' The no button was selected.
MsgBox "Then it is assumed this is a Boeing Proprietary presentation"
txt = "Boeing Proprietary"
End If
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 300, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.Text = txt
End With
injdate = InputBox("Please enter the date for the Stand Up")
With new_pres.SlideMaster.Shapes
Set oshp = .AddTextbox(msoTextOrientationHorizontal, 10, 520, 100, 50)
oshp.TextFrame.TextRange.Font.Name = "Arial"
oshp.TextFrame.TextRange.Font.Size = 7
oshp.TextFrame.TextRange.Text = injdate
End With
Application.CutCopyMode = True
NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit
End Sub
I have a macro that basically is supposed to copy ranges from excel spreadsheets and then paste them into a powerpoint file. So one excel sheet per slide.
Here is my macro so far:
Option Explicit
Sub ExportToPPT()
Dim PPAPP As PowerPoint.Application
Dim PPRES As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim ppSRng As PowerPoint.ShapeRange
Dim XLAPP As Excel.Application
Dim XLwbk As Excel.Workbook
Dim xlWst As Excel.Worksheet
Dim XLRng As Excel.Range
Dim ppPathFile As String
Dim ppNewPathFile
Dim chartNum As Integer
Dim maxCharts As Integer
Debug.Print vbCrLf & " ---- EXPORT EXCEL RANGES POWERPOINT ----"
Debug.Print Now() & " - Exporting ranges to .ppt"
'CHANGE WHEN ADDING CHARTS - MUST ALSO ADD SLIDE to .PPT and change loop
Dim chartRng(1 To 9) As Excel.Range
Dim SlideNum As Integer
Dim SlideOffset As Integer
Set XLwbk = Excel.ActiveWorkbook
Set xlWst = XLwbk.Sheets("Test1")
'This accounts for the title slide and any others before the automatedpaste
SlideOffset = 1
Set chartRng(1) = XLwbk.Sheets("Test1").Range("A1:B15")
Set chartRng(2) = XLwbk.Sheets("Test2").Range("A1:E33")
Set chartRng(3) = XLwbk.Sheets("Test3").Range("A1:E33")
Set chartRng(4) = XLwbk.Sheets("Test4").Range("A1:E4")
Set chartRng(5) = XLwbk.Sheets("Test5").Range("A1:J14")
Set chartRng(6) = XLwbk.Sheets("Test6").Range("A1:I33")
Set chartRng(7) = XLwbk.Sheets("Test7").Range("A1:I11")
Set chartRng(8) = XLwbk.Sheets("Test8").Range("A1:I8")
' Create instance of PowerPoint
Set PPAPP = CreateObject("Powerpoint.Application")
PPAPP.Visible = True
' Open the presentation (Same folder as the Excel file)
ppPathFile = ActiveWorkbook.Path + "TestPPT.pptx"
Debug.Print ppPathFile
Set PPRES = PPAPP.Presentations.Open(ppPathFile)
PPAPP.ActiveWindow.ViewType = ppViewSlide
chartNum = 1
'Loop through all chart ranges
'CHANGE WHEN ADDING CHARTS
For chartNum = 1 To 9
SlideNum = chartNum + SlideOffset
Debug.Print "Chart number " & chartNum & " to slide number " & SlideNum
' Copy the range as a picture
chartRng(chartNum).CopyPicture Appearance:=xlScreen, Format:=xlPicture
'PowerPoint operations
Set PPSlide = PPAPP.ActivePresentation.AddSlide(1, _ **//New code**
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))
Debug.Print PPSlide.Name
PPSlide.Select
PPAPP.ActiveWindow.ViewType = ppViewSlide
'ppapp.ActivePresentation.Slides.
' Paste the range
'PPAPP.ActiveWindow.View.Slide (SlideNum)
PPAPP.ActiveWindow.View.Paste
'PPSlide.Shapes.Paste
'PPSlide.Shapes(0).Select
'PPSlide.Shapes.Paste.Select
' Align the pasted range
Set ppSRng = PPAPP.ActiveWindow.Selection.ShapeRange
With ppSRng
.LockAspectRatio = msoTrue
If (.Width / .Height) > 1.65 Then
.Width = 650
Else
.Height = 400
End If
End With
With ppSRng
'.Width = 650
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
.IncrementTop 1.5
End With
Next chartNum
PPAPP.ActivePresentation.Slides(1).Select
PPAPP.ActiveWindow.ViewType = ppViewNormal
PPAPP.Activate
ppNewPathFile = ActiveWorkbook.Path & "\Test\TestPPT.pptx" & Format(Now(), "yyyymmdd_hhmmss")
PPAPP.ActivePresentation.SaveAs ppNewPathFile, ppSaveAsDefault
Debug.Print Now() & " - Finished"
End Sub
When I run the Macro it opens PowerPoint but stops and I get the following Error:
And when I debug it stops at this line:
Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum)
Any help on how to fix this would be great guys.
The error points to a counting problem that you've introduced in your code. Apparently, during the first iteration, it attempts to choose the second slide of a one-slide presentation (the second slide does not exist) and throwing an error.
I would assume this occurs because of your SlideOffset variable. Consider first adding a slide using before running Set PPSlide = PPAPP.ActivePresentation.Slides(SlideNum). Something like this:
Set pptLayout = PPAPP.ActivePresentation.Slides(1).CustomLayout
Set pptSlide = PPAPP.ActivePresentation.Slides.AddSlide(2, pptLayout)
Try using this
Set PPSlide = PPAPP.ActivePresentation.AddSlide(1, _
PPAPP.ActivePresentation.SlideMaster.CustomLayouts.Item(2))