Save and Resize pictures

[Gigant]

Hello to all active programmers of this page,

i recently started to write some small programms with VBA. Now i want to build a powerpoint script that grabs pictures out of a folder and puts each picture on a single powerpoint slide. The Main code is working now. There are two problems i have to solve now:

1. I want to change the image size while maintaining the same aspect ratio. I found the parameters to change the distance to the top and the left site of the slide, but i am not able to define distances to the right and bottom site. The image should be as big as possible while keeping the aspect ratio and not stick out of the sides of the slide.


2. I want to save the whole presentation as a PDF file in the end. I am trying two get solutions wich I was not able to archieve yet :
1. A Popup windwow (save as) to select the path and the file name. The user should only be able to save the file in the PDF format.

2. The file is saved automaticly to a set path. The name of the file should be something like today's date or a ascending number.



I really hope you guys can halp me with my problems and i would be very greatful for any help.

Thanks in advance.




Public Function GetAllFilesArray()


Dim i As Integer
Dim arrFilesInFolder As Variant


arrFilesInFolder = GetAllFilesInDirectory("C:\Users\XXX\Desktop\test")
For i = LBound(arrFilesInFolder) To UBound(arrFilesInFolder)
Call AddSlideAndImage(arrFilesInFolder(i))
Next




End Function






Public Function GetAllFilesInDirectory(ByVal strDirectory As String) As Variant
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim arrOutput() As Variant
Dim i As Integer






'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strDirectory)
ReDim arrOutput(0)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files

'print file path
arrOutput(i - 1) = objFile.Path
ReDim Preserve arrOutput(UBound(arrOutput) + 1)
i = i + 1
Next objFile
ReDim Preserve arrOutput(UBound(arrOutput) - 1)
GetAllFilesInDirectory = arrOutput
End Function


Public Function AddSlideAndImage(ByVal strFile As String)
Dim objPresentaion As Presentation
Dim objSlide As Slide






Set objPresentaion = ActivePresentation


Set objSlide = objPresentaion.Slides.Add(1, PpSlideLayout.ppLayoutBlank)




Call objSlide.Shapes.AddPicture(strFile, msoTrue, msoTrue, 20, 20, -1, -1)





End Function


Sub SaveAsButton()
Dim dlgSaveAs As FileDialog
Dim strMyFile As String

Set dlgSaveAs = Application.FileDialog(Type:=msoFileDialogSaveAs)
With dlgSaveAs
.AllowMultiSelect = False
.InitialFileName = "C:\Users\"
.FilterIndex = 4
If .Show = -1 Then
strMyFile = .SelectedItems(1)
ActivePresentation.SaveAs (strMyFile)
MsgBox "Datei wurde erfolgreich gespeichert."
'-- save your file to strMyFile here
Else
MsgBox "Die Datei wurde nicht gespeichert."
'-- The user pressed Cancel.
End If
End With
Set dlgSaveAs = Nothing
End Sub

[John Wilson]

See if this gets you going:


Sub StartHere() Dim i As Integer
Dim arrFilesInFolder As Variant
arrFilesInFolder = GetAllFilesInDirectory("C:\Users\Optiplex\Desktop\Pics\")
For i = LBound(arrFilesInFolder) To UBound(arrFilesInFolder)
Call AddSlideAndImage(arrFilesInFolder(i))
Next
End Sub


Public Function GetAllFilesInDirectory(ByVal strDirectory As String) As Variant
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim arrOutput() As Variant
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strDirectory)
ReDim arrOutput(0)
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file path
arrOutput(i - 1) = objFile.Path
ReDim Preserve arrOutput(UBound(arrOutput) + 1)
i = i + 1
Next objFile
ReDim Preserve arrOutput(UBound(arrOutput) - 1)
GetAllFilesInDirectory = arrOutput
End Function




Public Function AddSlideAndImage(ByVal strFile As String)
Dim objPres As Presentation
Dim objSlide As Slide
Dim objPic As Shape
Dim SW As Long
Dim SH As Long
Set objPres = ActivePresentation
SH = objPres.PageSetup.SlideHeight
SW = objPres.PageSetup.SlideWidth
Set objSlide = objPres.Slides.Add(1, PpSlideLayout.ppLayoutBlank)
Set objPic = objSlide.Shapes.AddPicture(strFile, msoTrue, msoTrue, 20, 20, -1, -1)
With objPic
.LockAspectRatio = True
.Width = SW
If .Height > SH - 20 Then
.Height = SH - 20
.Left = (SW - .Width) / 2
End If
End With
End Function




Sub SaveAsButton()
Dim dlgSaveAs As FileDialog
Dim strMyFile As String


Set dlgSaveAs = Application.FileDialog(Type:=msoFileDialogSaveAs)
With dlgSaveAs
.AllowMultiSelect = False
.InitialFileName = "C:\Users\"
.FilterIndex = 4
If .Show = -1 Then
strMyFile = .SelectedItems(1)
End If
If strMyFile = "" Then
MsgBox "Datei wurde erfolgreich gespeichert."
'-- save your file to strMyFile here
'-- The user pressed Cancel.
End If
End With
Call ActivePresentation.SaveAs(strMyFile, ppSaveAsPDF)
Set dlgSaveAs = Nothing
End Sub

[Gigant]

Thank you so much John for your fast help.
I tested everything, added a few things and the whole programm is working perfectly fine now.