V
vonclausowitz
Hi ALL,
I have a VB application from which I access powerpoint.
I create a new presentation, add 1 slide and input all pictures from a
given folder.
Add the point where I have to add the pictures the code stops.
Here's my code:
Private Sub PPT_Insert_Graphics()
Static ppApp As PowerPoint.Application
Static ppPres As PowerPoint.Presentation
Static ppSlide As PowerPoint.Slide
Const ppLayoutTitleOnly = 11
Dim nSlideWidth As Single
Dim nSlideHeight As Single
Dim iMyIndex As Integer
Dim iTotalInserts As Integer
Dim oPicture As Object
Dim vMessage, vTitle, vDefaultPath, vNewPath, vMyPath, vMyFile,
vMyNextFile
Dim vFileExt, vDefaultExt
If ppApp Is Nothing Then
' Start PowerPoint with a new presentation
Set ppApp = CreateObject("powerpoint.application")
ppApp.Visible = True
Set ppPres = ppApp.Presentations.Add
nSlideWidth = ppPres.PageSetup.SlideWidth
nSlideHeight = ppPres.PageSetup.SlideHeight
' Initialize counters
iMyIndex = 1 ' where to start inserting the slides
iTotalInserts = 0 'How many files inserted (gewhiz thing)
vNewPath = BrowseFolder("Waar staan de afbeeldingen?")
vNewPath = vNewPath & "\"
If vNewPath = "" Then End ' A way out if you change your mind
vMessage = "Extensie voor de afbeeldingen (* voor alle)."
vDefaultExt = "*"
vFileExt = InputBox(vMessage, vTitle, vDefaultExt)
vMyFile = Dir(vNewPath + "*." + vFileExt)
Do While vMyFile <> "" ' Start the Loop
vMyNextFile = vNewPath + vMyFile
ppPres.Slides.Add Index:=iMyIndex, Layout:=ppLayoutBlank
---> here things stop!!!!!!!!!!!!!!!!!!!!!!!!
Set oPicture = ppSlide.Shapes.AddPicture(FileName:=vMyNextFile, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=1,
Top:=1, Width:=1, Height:=1)
' Now scale the picture to full size, with "Relative to original
' picture size" set to true for both height and width.
oPicture.ScaleHeight 1, msoTrue
oPicture.ScaleWidth 1, msoTrue
oPicture.LockAspectRatio = msoTrue
' Move the picture to the center of the slide. Select it.
With ppPres.PageSetup
If oPicture.Height > oPicture.Width Then
oPicture.Height = nSlideHeight
Else
oPicture.Width = nSlideWidth
End If
oPicture.Left = (nSlideWidth \ 2) - (oPicture.Width \ 2)
oPicture.Top = (nSlideHeight \ 2) - (oPicture.Height \ 2)
oPicture.Select
End With
iMyIndex = iMyIndex + 1 'add one to the slide index
vMyFile = Dir() ' Get next entry
iTotalInserts = iTotalInserts + 1 ' add one to the nuber of files
inserted.
Loop
'ActiveWindow.View.GotoSlide Index:=1 'return to the first graphic
inserted.
'Set up message box.
If iMyIndex = 1 Then
MsgBox iTotalInserts & " Afbeelding ingevoegd", _
vbInformation, " Afbeeldingen Invoegen"
Else
MsgBox iTotalInserts & " Afbeeldingen ingevoegd", _
vbInformation, " Afbeeldingen Invoegen"
End If
ppApp.ActiveWindow.Selection.Unselect
Else
ppApp.Quit
Set ppChart = Nothing
Set ppSlide = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End If
End Sub
Regards
MArco
The Netherlands
I have a VB application from which I access powerpoint.
I create a new presentation, add 1 slide and input all pictures from a
given folder.
Add the point where I have to add the pictures the code stops.
Here's my code:
Private Sub PPT_Insert_Graphics()
Static ppApp As PowerPoint.Application
Static ppPres As PowerPoint.Presentation
Static ppSlide As PowerPoint.Slide
Const ppLayoutTitleOnly = 11
Dim nSlideWidth As Single
Dim nSlideHeight As Single
Dim iMyIndex As Integer
Dim iTotalInserts As Integer
Dim oPicture As Object
Dim vMessage, vTitle, vDefaultPath, vNewPath, vMyPath, vMyFile,
vMyNextFile
Dim vFileExt, vDefaultExt
If ppApp Is Nothing Then
' Start PowerPoint with a new presentation
Set ppApp = CreateObject("powerpoint.application")
ppApp.Visible = True
Set ppPres = ppApp.Presentations.Add
nSlideWidth = ppPres.PageSetup.SlideWidth
nSlideHeight = ppPres.PageSetup.SlideHeight
' Initialize counters
iMyIndex = 1 ' where to start inserting the slides
iTotalInserts = 0 'How many files inserted (gewhiz thing)
vNewPath = BrowseFolder("Waar staan de afbeeldingen?")
vNewPath = vNewPath & "\"
If vNewPath = "" Then End ' A way out if you change your mind
vMessage = "Extensie voor de afbeeldingen (* voor alle)."
vDefaultExt = "*"
vFileExt = InputBox(vMessage, vTitle, vDefaultExt)
vMyFile = Dir(vNewPath + "*." + vFileExt)
Do While vMyFile <> "" ' Start the Loop
vMyNextFile = vNewPath + vMyFile
ppPres.Slides.Add Index:=iMyIndex, Layout:=ppLayoutBlank
---> here things stop!!!!!!!!!!!!!!!!!!!!!!!!
Set oPicture = ppSlide.Shapes.AddPicture(FileName:=vMyNextFile, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=1,
Top:=1, Width:=1, Height:=1)
' Now scale the picture to full size, with "Relative to original
' picture size" set to true for both height and width.
oPicture.ScaleHeight 1, msoTrue
oPicture.ScaleWidth 1, msoTrue
oPicture.LockAspectRatio = msoTrue
' Move the picture to the center of the slide. Select it.
With ppPres.PageSetup
If oPicture.Height > oPicture.Width Then
oPicture.Height = nSlideHeight
Else
oPicture.Width = nSlideWidth
End If
oPicture.Left = (nSlideWidth \ 2) - (oPicture.Width \ 2)
oPicture.Top = (nSlideHeight \ 2) - (oPicture.Height \ 2)
oPicture.Select
End With
iMyIndex = iMyIndex + 1 'add one to the slide index
vMyFile = Dir() ' Get next entry
iTotalInserts = iTotalInserts + 1 ' add one to the nuber of files
inserted.
Loop
'ActiveWindow.View.GotoSlide Index:=1 'return to the first graphic
inserted.
'Set up message box.
If iMyIndex = 1 Then
MsgBox iTotalInserts & " Afbeelding ingevoegd", _
vbInformation, " Afbeeldingen Invoegen"
Else
MsgBox iTotalInserts & " Afbeeldingen ingevoegd", _
vbInformation, " Afbeeldingen Invoegen"
End If
ppApp.ActiveWindow.Selection.Unselect
Else
ppApp.Quit
Set ppChart = Nothing
Set ppSlide = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End If
End Sub
Regards
MArco
The Netherlands