Attribute VB_Name = "ModuleSMIL"
Public textURL As String
Public textTimeCorrection As String
Public optionAudio As Boolean
Public textAudio As String
Public textAudioMime As String
Public textHeading As String
Public textSubHeading As String
Public textVideo As String
Public textVideoMime As String
' Macro created 2005-01-01 by Pierre A. I. Wijkman, http://dsv.su.se/~pierre/
Sub SaveAsSMIL()
Attribute SaveAsSMIL.VB_Description = "2005-01-01 by Pierre A. I. Wijkman, http://dsv.su.se/~pierre/"
UserFormSettings.Show
Path = Application.ActivePresentation.Path
NameWithExt = Application.ActivePresentation.Name
place = InStr(LCase(NameWithExt), ".ppt")
NameWithoutExt = Mid(NameWithExt, 1, place - 1)
SmilDir = Path & "\" & NameWithoutExt & "_smil"
Application.ActivePresentation.SaveAs SmilDir, ppSaveAsJPG
If optionAudio Then ' Audio SMIL generation
' Make smil-file
Set fs = CreateObject("Scripting.FileSystemObject")
SmilFileName = "smil_audio.smil"
Set A = fs.CreateTextFile(SmilDir & "\" & SmilFileName, True)
A.WriteLine ("")
A.WriteLine ("")
A.WriteLine ("")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
For Each s In ActivePresentation.Slides
n = n + 1
t = Round(s.SlideShowTransition.AdvanceTime, 0)
If t = 0 Then t = 1
If n = 1 Then t = t + textTimeCorrection
tt = tt + t
A.WriteLine (" ")
Next
A.WriteLine (" ")
A.WriteLine (" ")
listAudioFiles = Split(textAudio, " ")
listAudioMimes = Split(textAudioMime, " ")
For counter = 0 To UBound(listAudioFiles)
A.WriteLine (" ")
Next counter
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine ("")
A.Close
Else ' Video SMIL generation
' Make smil-file
Set fs = CreateObject("Scripting.FileSystemObject")
SmilFileName = "smil_video.smil"
Set A = fs.CreateTextFile(SmilDir & "\" & SmilFileName, True)
A.WriteLine ("")
A.WriteLine ("")
A.WriteLine ("")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
For Each s In ActivePresentation.Slides
n = n + 1
t = Round(s.SlideShowTransition.AdvanceTime, 0)
If t = 0 Then t = 1
If n = 1 Then t = t + textTimeCorrection
tTot1 = tTot1 + t
A.WriteLine (" ")
Next
A.WriteLine (" ")
A.WriteLine (" ")
listVideoFiles = Split(textVideo, " ")
listVideoMimes = Split(textVideoMime, " ")
For counter = 0 To UBound(listVideoFiles)
A.WriteLine (" ")
Next counter
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine (" ")
A.WriteLine ("")
A.Close
' Make navigation-file
Set fs = CreateObject("Scripting.FileSystemObject")
Set A = fs.CreateTextFile(SmilDir & "\navigation.rt", True)
A.WriteLine ("")
A.WriteLine ("")
tTot2 = 0
For Each s In ActivePresentation.Slides
m = m + 1
Title = "not ok"
t = Round(s.SlideShowTransition.AdvanceTime, 0)
If t = 0 Then t = 1
If m = 1 Then t = t + textTimeCorrection
If ActivePresentation.Slides(m).Shapes.HasTitle Then
If ActivePresentation.Slides(m).Shapes.Title.HasTextFrame Then
If ActivePresentation.Slides(m).Shapes.Title.TextFrame.HasText Then
Title = "ok"
A.WriteLine (" >")
textNavigation = m & ". " & ActivePresentation.Slides(m).Shapes.Title.TextFrame.TextRange.Text
A.WriteLine ("" & textNavigation & " ")
End If
End If
End If
If Title = "not ok" Then
A.WriteLine (" >")
textNavigation = m & ". " & "<NO TITLE>"
A.WriteLine ("" & textNavigation & " ")
End If
tTot2 = tTot2 + t
Next
A.WriteLine ("")
A.WriteLine ("")
A.Close
' Make title-file
Set fs = CreateObject("Scripting.FileSystemObject")
Set A = fs.CreateTextFile(SmilDir & "\title.rt", True)
A.WriteLine ("")
A.WriteLine ("")
A.WriteLine (textHeading & " ")
A.WriteLine ("")
A.WriteLine ("")
A.WriteLine (textSubHeading)
A.WriteLine ("")
A.WriteLine ("")
A.Close
End If
' Make the RAM-file
place = InStrRev(LCase(textURL), "/")
PathInternet = Mid(textURL, 1, place)
FileRAM = Mid(textURL, place + 1)
Set fs = CreateObject("Scripting.FileSystemObject")
Set A = fs.CreateTextFile(SmilDir & "\" & FileRAM, True)
A.WriteLine (PathInternet & SmilFileName)
A.Close
' Display message
MsgBox ("Saving completed! Copy audio/video files to " & SmilDir & " and then FTP all files in this folder to " & PathInternet & ".")
End Sub
'CommandBarComboBox
'Dim ProcID As Integer
'ProcID = Shell("C:\Documents and Settings\Pierre A. I. Wijkman\Desktop\Media\Recording\hdogg251\Harddisk.exe", AppWinStyle = vbMinimizedNoFocus)