....
ElseIf Me.frmORppt = "ppt" Then
' Open up an instance of Powerpoint.
Set ppObj = New PowerPoint.Application
Set ppPres = ppObj.Presentations.ADD
' Setup the set of slides and populate them with data from the
' set of records.
I = 1
rs.MoveFirst
Dim MyProvState As String
MyProvState = rs![ProvinceStateDescription]
'************************************************************************************************************************************************************************
'Fill tblAllPersonsByPhotoForPptNotes from qryAllPersonsByPhotoForPptNotes_App to add the persons names to the PowerPoint Notes
'************************************************************************************************************************************************************************
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryAllPersonsByPhotoForPptNotes_Del"
DoCmd.OpenQuery "qryAllPersonsByPhotoForPptNotes_App"
DoCmd.SetWarnings True
Set rs5 = db.OpenRecordset("tblAllPersonsByPhotoForPptNotes", dbOpenDynaset)
'************************************************************************************************************************************************************************
With ppPres
While Not rs.EOF
FilePathAndName = "D:\Photos\DataMiningResult\Slide" & rs![Photo_Date] & "_" & Trim(Str(I)) & ".jpg"
If MyProvState = "Unknown" Then
MyProvState = ""
End If
With .Slides.ADD(rs.AbsolutePosition + 1, ppLayoutTitle)
.Shapes(1).DELETE
.Shapes.AddPicture _
FileName:=FilePathAndName, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=-1, Height:=-1
.SlideShowTransition.EntryEffect = ppEffectFade
'************************************************************************************************************************************************************************
' Add the persons names to the variable MyNames
'************************************************************************************************************************************************************************
Dim MyPhoto_ID As Integer
Dim MyNames As Variant
MyNames = ""
rs5.MoveFirst
MyPhoto_ID = rs![Photo_ID]
While Not rs5.EOF
Select Case MyPhoto_ID
Case rs5![Photo_ID]
MyNames = MyNames & "Last Name: " & rs5![Person_LastName] & _
" First Name: " & rs5![Person_FirstName] & _
" " & rs5![Person_Comment] & vbCrLf
End Select
rs5.MoveNext
Wend
'************************************************************************************************************************************************************************
'Add relevant text to PowerPoint Notes
'************************************************************************************************************************************************************************
ppObj.ActivePresentation.Slides(I).NotesPage.Shapes(2).TextFrame.TextRange.Text = "Photo ID: " & rs![Photo_ID] & vbCrLf & _
"Date Photo: " & rs![Photo_Date] & vbCrLf & _
"Commentaire Photo: " & rs![Photo_Comment] & vbCrLf & _
"Pays: " & rs![Country] & vbCrLf & _
"Ville: " & rs![City] & vbCrLf & _
"Rue ou Lieu: " & rs![Location_Street] & vbCrLf & _
"Province ou Etat: " & MyProvState & vbCrLf & _
"Code Postal: " & rs![Location_Postal_Code] & vbCrLf & _
"Commentaire Lieu: " & rs![Location_Comment] & vbCrLf & _
MyNames
'************************************************************************************************************************************************************************
I = I + 1
End With
rs.MoveNext
Wend
rs.Close
rs5.Close
db.Close
MyMonth = Str(Month(Now()))
If Len(Trim(MyMonth)) < 2 Then MyMonth = Trim("0" & Trim(MyMonth))
MyDay = Str(Day(Now()))
If Len(Trim(MyDay)) < 2 Then MyDay = Trim("0" & Trim(MyDay))
MyHour = Str(Hour(Now()))
If Len(Trim(MyHour)) < 2 Then MyHour = Trim("0" & Trim(MyHour))
MyMinute = Str(Minute(Now()))
If Len(Trim(MyMinute)) < 2 Then MyMinute = Trim("0" & Trim(MyMinute))
MySecond = Str(Second(Now()))
If Len(Trim(MySecond)) < 2 Then MySecond = Trim("0" & Trim(MySecond))
MyDate = Trim(Year(Now()) & Trim(MyMonth) & Trim(MyDay) & " " & Trim(MyHour) & Trim(MyMinute) & Trim(MySecond))
MyExtension = ".ppt"
MyFileName = "D:\Photos\DataMiningResult\AllMyPhotos" & MyDate
.SaveAs MyFileName, ppSaveAsPresentation
End With
Me.MyFileName = MyFileName
Beep
MsgBox "Done"
End If
Exit_CalcDataMiningResult:
Exit Sub
Err_CalcDataMiningResult:
MsgBox Err.Description
Resume Exit_CalcDataMiningResult
End Sub