Option Compare Database
Option Explicit
''***********************************************''
' Name:
' Date: Created Date
' Author: Gilbert Medel
' Current Version: 3.1.0
' Called by:
''***********************************************''
' Notes:
''***********************************************''
' Global Variables
Public ppt_app As Object
Public ppt_Presentation As Object
Public ppt_Presentation_Name As Variant
Public ppt_Slide As Object
Public ppt_Shape As Object
Public Date_Time As Date
''***********************************************''
' Private Variables
Private Parent_Reference As Object
Private Data_Recset As Object
Private Self_Reference As Object
Private Const Object_Type As String = "Export_To_PPT" 'Identifies Class object Type
Private Notes_ As Variant
Private Obj_FileSystem As Object
''***********************************************''
' Public properties
Public Property Get Name() As String
Name = Object_Type
End Property
Public Property Get Application() As Object
Set Application = Parent_Reference.Application
End Property
Public Property Get Self_Ref() As Object
Set Self_Ref = Self_Reference
End Property
Public Property Set Self_Ref(Reference_Object As Object)
Set Self_Reference = Reference_Object
End Property
Public Property Get Parent() As Object
Set Parent = Parent_Reference
End Property
Public Property Set Parent(Reference_Object As Object)
Set Parent_Reference = Reference_Object
End Property
''***********************************************''
' Public Functions that return values
Public Function Export_Planning_Slides(Parent_Ref As Object) As Boolean
Dim IPR_Object As Object
'Prepare Data For Export
'Determine if Template is Available
Export_Planning_Slides = False
Date_Time = TID_G.Factory.TID_Current_Date(TID_File_Name_by_Year)
Splash 1, "Export Starting", 0
Set Parent_Reference = Parent_Ref.Module.Parent
If Parent_Reference Is Nothing Then
Splash 6, "Export Error", 1
Else
'Create PowerPoint If Possible
PowerPoint_Available "power point template"
'Use child class to fill out Slide Data
Set IPR_Object = TID_G.Factory.Create_Export_Object("Export_IPR_Class")
IPR_Object.Export_Slides Self_Reference
End If
'Completed release objects
Splash 6, "Clearing Export Variables"
Zeroize
End Function
''***********************************************''
' Public Sub Routines
''***********************************************''
' Private Functions
''***********************************************''
' Private Subs Routines
Private Function PowerPoint_Available(Office_Description As Variant) As Object
'Get the recordset row with attachment field
'Sets The Available Power Point to transfer data to file based on template or New Blank
Splash 2, "Creating PowerPoint"
Set Data_Recset = Parent_Reference.Application.DBEngine.Workspaces(0).Databases(0).OpenRecordset("SELECT * FROM TID_Office_Files WHERE (Office_Description = " & Chr(39) & Office_Description & Chr(39) & ")", dbOpenSnapshot)
If Data_Recset.RecordCount = 1 Then
'Open template and set reference to it
Splash 3, "Using PowerPoint template"
Save_With_Template
Else
'Open Without Template
Splash 3, "could not use PowerPoint template"
Save_Without_Template
End If
Add_Distro_D
Splash 6, "Finished PowerPoint Export"
Data_Recset.Close
Set Data_Recset = Nothing
End Function
Public Function Save_With_Template() As Long
Dim Complex_Recset As Object
Dim File_From_Table As Object
If Data_Recset.Fields("Network_PKEY") = 1003 Then
ppt_Presentation_Name = Format(TID_G.TID_Now, "YYYYmmdd") & "_IPR_Export.ppt"
Splash 2, "Checking If File Exists"
Check_Export_Status False
'Get the recordset for the Attachments field
Set Complex_Recset = Data_Recset.Fields("Office_File").Value
'Save all attachments in the field
Splash 3, "Saving File"
Set File_From_Table = Complex_Recset.Fields("FileData")
File_From_Table.SaveToFile (Parent.Application.CurrentProject.Path & "\" & ppt_Presentation_Name)
Splash 3, "File Saved"
Set ppt_app = TID_G.Factory.Create_Office_Object("PowerPoint.Application")
ppt_app.Presentations.Open FileName:=(Parent.Application.CurrentProject.Path & "\" & ppt_Presentation_Name)
Splash 3, "Opening Export PPT"
Set ppt_Presentation = ppt_app.Presentations(ppt_Presentation_Name)
ppt_Presentation.windows.Item(1).viewType = 9 'ppViewNormal
End If
Set File_From_Table = Nothing
Set Complex_Recset = Nothing
End Function
Public Function Save_Without_Template() As Long
Dim FileDialog_SaveAs As Object
ppt_Presentation_Name = Format(TID_G.TID_Now, "YYYYmmdd") & "_IPR_Export.ppt"
TID_SplashScreenControl.StatusMessage 2, "Checking If File Exists", 0, Date_Time
Check_Export_Status False
TID_SplashScreenControl.StatusMessage 3, "Saving File", 0, Date_Time
Set ppt_app = TID_G.Factory.Create_Office_Object("PowerPoint.Application")
Set FileDialog_SaveAs = ppt_app.FileDialog(msoFileDialogSaveAs)
ppt_app.Presentations.Add True
Set ppt_Presentation = ppt_app.Presentations(1)
With FileDialog_SaveAs
.Title = "Please Select Where to Save File"
.InitialFileName = Parent.Application.CurrentProject.Path & "\" & Left(ppt_Presentation_Name, Len(ppt_Presentation_Name) - 4)
.Show
If .SelectedItems.Count = 1 Then
Save_Without_Template = True
.Execute
TID_SplashScreenControl.StatusMessage 3, "File Saved", 0, Date_Time
End If
End With
Set FileDialog_SaveAs = Nothing
End Function
Private Sub Check_Export_Status(Recursion As Boolean)
'Runs_Recursively until File Name does not match
Dim File_Test As Object
Set File_Test = TID_G.Factory.Create_SYNC_Object("SYNC_Connection_Class")
If File_Test.Check_Export_Exists(Self_Reference, ppt_Presentation_Name) Then
If Recursion Then
ppt_Presentation_Name = Left(ppt_Presentation_Name, Len(ppt_Presentation_Name) - 4) + "1" + ".ppt"
Check_Export_Status True
Else
Select Case MsgBox("File Exists do you want to delete and Replace?", vbYesNo, "Export IPR")
Case vbYes
'Delete Existing File
Set File_Test = Nothing
Set File_Test = TID_G.Factory.Create_Office_Object("Scripting.FileSystemObject")
File_Test.DeleteFile Parent.Application.CurrentProject.Path & "\" & ppt_Presentation_Name
Case Else
ppt_Presentation_Name = Left(ppt_Presentation_Name, Len(ppt_Presentation_Name) - 4) + "1" + ".ppt"
Check_Export_Status True
End Select
End If
End If
End Sub
Private Sub Add_Distro_D()
Dim ppt_Shape As Object
'Selects the first slide and applys slide layout
If ppt_Presentation.Slides.Count >= 1 Then
Set ppt_Slide = ppt_Presentation.Slides(1)
ppt_Slide.customLayout = ppt_Presentation.SlideMaster.CustomLayouts(2)
Else
Set ppt_Slide = ppt_Presentation.Slides.AddSlide(1, ppt_Presentation.SlideMaster.CustomLayouts(2))
End If
Set ppt_Shape = ppt_Presentation.SlideMaster.Shapes.AddTextBox(Orientation:=msoTextOrientationHorizontal, Left:=0, Top:=503.625, Width:=654, Height:=29.08126)
ppt_Shape.TextEffect.Text = DistributionStatementD
ppt_Shape.TextEffect.FontSize = 8
ppt_Shape.TextEffect.FontName = "Arial"
End Sub
Public Sub Zeroize()
On Error GoTo Err_Zeroize:
Date_Time = 0
ppt_Presentation_Name = Null
Set ppt_app = Nothing
Set ppt_Presentation = Nothing
Set ppt_Slide = Nothing
Set ppt_Shape = Nothing
Set Obj_FileSystem = Nothing
Set Parent_Reference = Nothing
Set Data_Recset = Nothing
Set Self_Reference = Nothing
Exit Sub
Err_Zeroize:
MsgBox "unable to Zeroize", vbCritical, "PR Data Zeroize"
TID_G.Log_Err Object_Type, "Zeroize", Self_Reference, "Unable To Zeroize"
End Sub
Private Sub Class_Initialize()
Zeroize
End Sub
Private Sub Class_Terminate()
Zeroize
End Sub
''***********************************************''
'End Code
