kjems
03-05-2017, 08:38 AM
Hello.
I have made four macros, that makes my teaching easier. But my college is on a Mac, where they wont work.
They manipulate timing of the slides and made a nice printeable teachers program (html file), when run on a PC. Any help on what lines, it is that is not Mac compatible and what to write insted He is on Office 2011 on the Mac and i´m on 2016 on the PC?
Here is the Macros:
Module 1:
Dim cPPTObject As New cEventClass
Dim TrapFlag As Boolean
Sub OpdaterTidNaarGemmer()
If TrapFlag = True Then
MsgBox "Relax, my friend, the EventHandler is already active.", vbInformation + vbOKOnly, "PowerPoint Event Handler Example"
Exit Sub
End If
Set cPPTObject.PPTEvent = Application
TrapFlag = True
End Sub
Sub ReleaseTrap()
If TrapFlag = True Then
Set cPPTObject.PPTEvent = Nothing
Set cPPTObject = Nothing
TrapFlag = False
End If
End Sub
Sub OpdaterTid()
Dim AllSlides As Slide
Dim FirstSlide As Slide
Dim CurrentMinutes As Integer
Dim TotalMinutes As Integer
Dim StartTime
StartTime = TimeValue("8:00 AM")
Dim CurrentTime As Date
Dim PasteTime As Date
Dim NextTime As Date
Dim NoteText As String
Dim RemoveTime As String
Set FirstSlide = ActivePresentation.Slides(1)
Set FirstNoteText = FirstSlide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange
'hvis der er en starttid
If InStr(FirstNoteText, "]") <> 0 Then
'Så træk den ud i StartTime
StartTime = Mid(FirstNoteText, InStr(FirstNoteText, "[") + 1, InStr(FirstNoteText, "]") - InStr(FirstNoteText, "[") - 1)
Else
'Eller skriv standard Starttid ind
FirstSlide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = "[" + Format(StartTime, "h:nn") + "] " + FirstNoteText
End If
'Første Slide er CurrentTime det samme som StartTime
CurrentTime = StartTime
PasteTime = StartTime
For Each AllSlides In ActivePresentation.Slides
NoteText = AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange
'Tjek om der er minutter findes
If InStr(NoteText, "))") <> 0 Then
'om de er forskellige fra 0
If Mid(NoteText, InStr(NoteText, "((") + 2, InStr(NoteText, "))") - InStr(NoteText, "((") - 2) <> 0 Then
'så sæt tiden der skal sættes ind til CurrentTime
PasteTime = CurrentTime
'ellers
End If
End If
'hvis der er en tid
If InStr(NoteText, "]") <> 0 Then
'Så erstat tiden med med CurrentTime
OwnTime = Mid(NoteText, InStr(NoteText, "[") + 1, InStr(NoteText, "]") - InStr(NoteText, "[") - 1)
AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = Replace(NoteText, OwnTime, Format(PasteTime, "h:nn"))
'Træk minutter ud af Parentes til CurrentMinute
If InStr(NoteText, "))") <> 0 Then
CurrentMinutes = Mid(NoteText, InStr(NoteText, "((") + 2, InStr(NoteText, "))") - InStr(NoteText, "((") - 2)
Else
CurrentMinutes = 0
'Og skriv 0 minutter ind
AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = Replace(NoteText, OwnTime + "]", OwnTime + "] ((0))")
End If
'Læg dem til CurrentTime
CurrentTime = DateAdd("n", CurrentMinutes, CurrentTime)
Else
'Eller skriv den nye tid ind
AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = "[" + Format(CurrentTime, "h:nn") + "] " + NoteText
End If
'Make the first line of Notes Bold
AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Lines(Start: =1, Length:=1).Font.Bold = True
Next AllSlides
End Sub
Sub Lav_learerprogram()
Dim path As String
path = GetSetting("FPPT", "Export", "Default Path")
If path <> "" Then
'Open path For Output As #n
SaveSetting "FPPT", "Export", "Default Path", path
End If
Dim sImagePath_old As String
Dim sImagePath As String
Dim sImageName As String
Dim sPrefix As String
Dim oSlide As Slide '* Slide Object
Dim lScaleWidth As Long '* Scale Width
Dim lScaleHeight As Long '* Scale Height
On Error GoTo Err_ImageSave
Dim FirstLine As String
Dim FirstLineEx As String
Dim NoteTextEx As String
Dim MinutesEx As String
Dim TimeEx As String
Dim StartHTML As String
Dim TempHTML As String
Dim EndHTML As String
StartHTML = "<html><head><style>" + vbNewLine + vbNewLine _
+ "" _
+ "" _
+ "" _
+ "" _
+ "" _
+ vbNewLine + vbNewLine + "</style></head><body>" + vbNewLine + vbNewLine
TempHTML = ""
EndHTML = "</body></html>"
With Application.FileDialog(msoFileDialogFolderPicker)
sImagePath_old = ActivePresentation.path
sPrefix = Split(ActivePresentation.Name, ".")(0)
'Lav en folder til billederne med samme navn som PP
sImagePath = sImagePath_old + "\" + sPrefix
If Len(Dir(sImagePath, vbDirectory)) = 0 Then
MkDir sImagePath
End If
For Each oSlide In ActivePresentation.Slides
'Gem det aktuelle slide som JPG
sImageName = sPrefix & "-" & oSlide.SlideIndex & ".jpg"
oSlide.Export sImagePath & "\" & sImageName, "JPG"
'Træk info fra NoteFeltet
FirstLine = oSlide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Lines(Start:=1, Length:=1)
FirstLineEx = Mid(FirstLine, InStr(FirstLine, "))") + 2, Len(FirstLine))
NoteTextEx = oSlide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Lines(Start:=2, Length:=10)
'Fjern evt. tid og minutter her
If InStr(FirstLine, ")") <> 0 Then
MinutesEx = Mid(FirstLine, InStr(FirstLine, "((") + 2, InStr(FirstLine, "))") - InStr(FirstLine, "((") - 2)
Else
MinutesEx = "0"
End If
If InStr(FirstLine, "]") <> 0 Then
TimeEx = Mid(FirstLine, InStr(FirstLine, "[") + 1, InStr(FirstLine, "]") - InStr(FirstLine, "[") - 1)
End If
If MinutesEx = 0 Then
MinutesExHTML = ""
Else
MinutesExHTML = MinutesEx
End If
'Lav linien til html filen
TempHTML = TempHTML + "<div id=container style='float:left;font-weight:normal;color:#000000;background-color:#F3F5DA;font-size:8px;" _
+ "text-align:left;font-family:trebuchet MS, sans-serif;line-height:1;border:1px solid;margin:5px;padding:7px;height:321px;width:200px;" _
+ "-moz-box-shadow: 7px 5px 5px #141414;-webkit-box-shadow: 7px 5px 5px #141414;box-shadow: 7px 5px 5px #141414;" _
+ "'><div><div class=MinuteClass style='float:right;border-radius: 4px;margin: 3px 2px 2px; padding: 4px;font: normal 12px/1 Verdana, Geneva, sans-serif;color:white;background-color:green;'>" _
+ MinutesExHTML + "</div><div class=TimeClass style='float:left;border-radius: 4px;margin: 3px 2px 2px; padding: 4px;font: normal 12px/1 Verdana, Geneva, sans-serif;color:white;background-color:orange;'>" + TimeEx + "</div>" + "<div class=HeadingClass style='float:left:font-weight:bold;margin: 3px 2px 2px; padding: 4px;font: normal 10px/1 Verdana, Geneva, sans-serif;'>" + FirstLineEx + "</div>" + "</div>" _
+ "<div style=><img style='width:200px;margin:0 0 4px 0' src=" + sPrefix + "/" + sImageName + "></div>" + vbNewLine _
+ vbNewLine + "<div style='padding:0px;margin:0px;font-size:9px;'>" + NoteTextEx + "</div></div>" + vbNewLine + vbNewLine
Next oSlide
'Gem HTML filen
HTMLEx = StartHTML + TempHTML + EndHTML
Dim TextFile As Integer
Dim FilePath As String
'What is the file path and name for the new text file?
FilePath = sImagePath_old + "\" + sPrefix + ".html"
'Determine the next file number available for use by the FileOpen function
TextFile = FreeFile
'Open the text file
Open FilePath For Output As TextFile
'Write some lines of text
Print #TextFile, HTMLEx
'Save & Close Text File
Close TextFile
End With
Err_ImageSave:
If Err <> 0 Then
MsgBox Err.Description
End If
End Sub
CEventClass:
Private Sub PPTEvent_PresentationBeforeSave(ByVal Pres As Presentation, Cancel As Boolean)
Application.Run "Module1.OpdaterTid"
End Sub
I have made four macros, that makes my teaching easier. But my college is on a Mac, where they wont work.
They manipulate timing of the slides and made a nice printeable teachers program (html file), when run on a PC. Any help on what lines, it is that is not Mac compatible and what to write insted He is on Office 2011 on the Mac and i´m on 2016 on the PC?
Here is the Macros:
Module 1:
Dim cPPTObject As New cEventClass
Dim TrapFlag As Boolean
Sub OpdaterTidNaarGemmer()
If TrapFlag = True Then
MsgBox "Relax, my friend, the EventHandler is already active.", vbInformation + vbOKOnly, "PowerPoint Event Handler Example"
Exit Sub
End If
Set cPPTObject.PPTEvent = Application
TrapFlag = True
End Sub
Sub ReleaseTrap()
If TrapFlag = True Then
Set cPPTObject.PPTEvent = Nothing
Set cPPTObject = Nothing
TrapFlag = False
End If
End Sub
Sub OpdaterTid()
Dim AllSlides As Slide
Dim FirstSlide As Slide
Dim CurrentMinutes As Integer
Dim TotalMinutes As Integer
Dim StartTime
StartTime = TimeValue("8:00 AM")
Dim CurrentTime As Date
Dim PasteTime As Date
Dim NextTime As Date
Dim NoteText As String
Dim RemoveTime As String
Set FirstSlide = ActivePresentation.Slides(1)
Set FirstNoteText = FirstSlide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange
'hvis der er en starttid
If InStr(FirstNoteText, "]") <> 0 Then
'Så træk den ud i StartTime
StartTime = Mid(FirstNoteText, InStr(FirstNoteText, "[") + 1, InStr(FirstNoteText, "]") - InStr(FirstNoteText, "[") - 1)
Else
'Eller skriv standard Starttid ind
FirstSlide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = "[" + Format(StartTime, "h:nn") + "] " + FirstNoteText
End If
'Første Slide er CurrentTime det samme som StartTime
CurrentTime = StartTime
PasteTime = StartTime
For Each AllSlides In ActivePresentation.Slides
NoteText = AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange
'Tjek om der er minutter findes
If InStr(NoteText, "))") <> 0 Then
'om de er forskellige fra 0
If Mid(NoteText, InStr(NoteText, "((") + 2, InStr(NoteText, "))") - InStr(NoteText, "((") - 2) <> 0 Then
'så sæt tiden der skal sættes ind til CurrentTime
PasteTime = CurrentTime
'ellers
End If
End If
'hvis der er en tid
If InStr(NoteText, "]") <> 0 Then
'Så erstat tiden med med CurrentTime
OwnTime = Mid(NoteText, InStr(NoteText, "[") + 1, InStr(NoteText, "]") - InStr(NoteText, "[") - 1)
AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = Replace(NoteText, OwnTime, Format(PasteTime, "h:nn"))
'Træk minutter ud af Parentes til CurrentMinute
If InStr(NoteText, "))") <> 0 Then
CurrentMinutes = Mid(NoteText, InStr(NoteText, "((") + 2, InStr(NoteText, "))") - InStr(NoteText, "((") - 2)
Else
CurrentMinutes = 0
'Og skriv 0 minutter ind
AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = Replace(NoteText, OwnTime + "]", OwnTime + "] ((0))")
End If
'Læg dem til CurrentTime
CurrentTime = DateAdd("n", CurrentMinutes, CurrentTime)
Else
'Eller skriv den nye tid ind
AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange = "[" + Format(CurrentTime, "h:nn") + "] " + NoteText
End If
'Make the first line of Notes Bold
AllSlides.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Lines(Start: =1, Length:=1).Font.Bold = True
Next AllSlides
End Sub
Sub Lav_learerprogram()
Dim path As String
path = GetSetting("FPPT", "Export", "Default Path")
If path <> "" Then
'Open path For Output As #n
SaveSetting "FPPT", "Export", "Default Path", path
End If
Dim sImagePath_old As String
Dim sImagePath As String
Dim sImageName As String
Dim sPrefix As String
Dim oSlide As Slide '* Slide Object
Dim lScaleWidth As Long '* Scale Width
Dim lScaleHeight As Long '* Scale Height
On Error GoTo Err_ImageSave
Dim FirstLine As String
Dim FirstLineEx As String
Dim NoteTextEx As String
Dim MinutesEx As String
Dim TimeEx As String
Dim StartHTML As String
Dim TempHTML As String
Dim EndHTML As String
StartHTML = "<html><head><style>" + vbNewLine + vbNewLine _
+ "" _
+ "" _
+ "" _
+ "" _
+ "" _
+ vbNewLine + vbNewLine + "</style></head><body>" + vbNewLine + vbNewLine
TempHTML = ""
EndHTML = "</body></html>"
With Application.FileDialog(msoFileDialogFolderPicker)
sImagePath_old = ActivePresentation.path
sPrefix = Split(ActivePresentation.Name, ".")(0)
'Lav en folder til billederne med samme navn som PP
sImagePath = sImagePath_old + "\" + sPrefix
If Len(Dir(sImagePath, vbDirectory)) = 0 Then
MkDir sImagePath
End If
For Each oSlide In ActivePresentation.Slides
'Gem det aktuelle slide som JPG
sImageName = sPrefix & "-" & oSlide.SlideIndex & ".jpg"
oSlide.Export sImagePath & "\" & sImageName, "JPG"
'Træk info fra NoteFeltet
FirstLine = oSlide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Lines(Start:=1, Length:=1)
FirstLineEx = Mid(FirstLine, InStr(FirstLine, "))") + 2, Len(FirstLine))
NoteTextEx = oSlide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Lines(Start:=2, Length:=10)
'Fjern evt. tid og minutter her
If InStr(FirstLine, ")") <> 0 Then
MinutesEx = Mid(FirstLine, InStr(FirstLine, "((") + 2, InStr(FirstLine, "))") - InStr(FirstLine, "((") - 2)
Else
MinutesEx = "0"
End If
If InStr(FirstLine, "]") <> 0 Then
TimeEx = Mid(FirstLine, InStr(FirstLine, "[") + 1, InStr(FirstLine, "]") - InStr(FirstLine, "[") - 1)
End If
If MinutesEx = 0 Then
MinutesExHTML = ""
Else
MinutesExHTML = MinutesEx
End If
'Lav linien til html filen
TempHTML = TempHTML + "<div id=container style='float:left;font-weight:normal;color:#000000;background-color:#F3F5DA;font-size:8px;" _
+ "text-align:left;font-family:trebuchet MS, sans-serif;line-height:1;border:1px solid;margin:5px;padding:7px;height:321px;width:200px;" _
+ "-moz-box-shadow: 7px 5px 5px #141414;-webkit-box-shadow: 7px 5px 5px #141414;box-shadow: 7px 5px 5px #141414;" _
+ "'><div><div class=MinuteClass style='float:right;border-radius: 4px;margin: 3px 2px 2px; padding: 4px;font: normal 12px/1 Verdana, Geneva, sans-serif;color:white;background-color:green;'>" _
+ MinutesExHTML + "</div><div class=TimeClass style='float:left;border-radius: 4px;margin: 3px 2px 2px; padding: 4px;font: normal 12px/1 Verdana, Geneva, sans-serif;color:white;background-color:orange;'>" + TimeEx + "</div>" + "<div class=HeadingClass style='float:left:font-weight:bold;margin: 3px 2px 2px; padding: 4px;font: normal 10px/1 Verdana, Geneva, sans-serif;'>" + FirstLineEx + "</div>" + "</div>" _
+ "<div style=><img style='width:200px;margin:0 0 4px 0' src=" + sPrefix + "/" + sImageName + "></div>" + vbNewLine _
+ vbNewLine + "<div style='padding:0px;margin:0px;font-size:9px;'>" + NoteTextEx + "</div></div>" + vbNewLine + vbNewLine
Next oSlide
'Gem HTML filen
HTMLEx = StartHTML + TempHTML + EndHTML
Dim TextFile As Integer
Dim FilePath As String
'What is the file path and name for the new text file?
FilePath = sImagePath_old + "\" + sPrefix + ".html"
'Determine the next file number available for use by the FileOpen function
TextFile = FreeFile
'Open the text file
Open FilePath For Output As TextFile
'Write some lines of text
Print #TextFile, HTMLEx
'Save & Close Text File
Close TextFile
End With
Err_ImageSave:
If Err <> 0 Then
MsgBox Err.Description
End If
End Sub
CEventClass:
Private Sub PPTEvent_PresentationBeforeSave(ByVal Pres As Presentation, Cancel As Boolean)
Application.Run "Module1.OpdaterTid"
End Sub