VBA to create, print and save as jpg test results

[tives]

I am using the code below and have a problem

Sub PrintResultsSummary()
Dim CurrentIncorrect As String
ActivePresentation.SlideShowWindow.View.GotoSlide (37) 'set to last slide number +1
CurrentIncorrect = ActivePresentation.Slides(37).Shapes(2).TextFrame.TextRange.Text 'set to last slide + 1
ActivePresentation.Slides(37).Shapes(2).TextFrame.TextRange = CurrentIncorrect & vbNewLine & _
"Number of Correct Answers = " & numberCorrect & vbNewLine & _
"Number of Incorrect Answers =" & numberWrong 'set to last slide + 1
ActivePresentation.SlideShowWindow.View.GotoSlide (37) 'set to last slide number +1
With ActivePresentation
With .PrintOptions
.OutputType = ppPrintOutputSlides
.RangeType = ppPrintSlideRange
With .Ranges
.ClearAll
.Add 37, 37 'set to last slide number +1
End With
End With
.PrintOut
End With
Call DeleterResultSummary

End Sub
Sub DeleterResultSummary()
Dim osld As Slide
Dim oShp As Shape
For Each osld In ActivePresentation.Slides
For Each oShp In osld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.TextRange.Find("Results Summary") Is Nothing Then
'didn't find it
Else
'found it
osld.Delete
Call Certificate
Exit Sub
End If
End If
Next oShp
Next osld
ActivePresentation.SlideShowWindow.View.GotoSlide (36) 'set to last slide
Call Certificate
End Sub
Sub Certificate()
Dim TestScore As Integer
Dim PassMark As Integer
TestScore = Int((numberCorrect / (numberCorrect + numberWrong)) * 100)
PassMark = 80
If TestScore >= PassMark Then
Call PassCertificate
Else
Call FailCertificate
End If
End Sub
Sub PassCertificate()

Dim Pre As Presentation
Dim Sld As Slide

Set Pre = ActivePresentation
Set Sld = Pre.Slides.Add(Index:=Pre.Slides.Count + 1, Layout:=ppLayoutCustom)
Sld.Shapes(1).TextFrame.TextRange = "This certificate is presented to"
Sld.Shapes(2).TextFrame.TextRange = UserName
Sld.Shapes(6).TextFrame.TextRange = "who has obtained the following score"
Sld.Shapes(7).TextFrame.TextRange = Int((numberCorrect / (numberCorrect + numberWrong)) * 100) & "%" & vbNewLine
Sld.Shapes(8).TextFrame.TextRange = "PAA Storstar Sample Batching Theory Test" 'SET to name for this test
Sld.Shapes(9).TextFrame.TextRange = "on"
Sld.Shapes(3).TextFrame.TextRange = Date
Sld.Shapes(3).TextFrame.TextRange.Text = Format(Date, "dd mmmm yyyy")
Sld.Shapes(10).TextFrame.TextRange = "The pass mark for this test is 80%" 'SET to pass mark for this test
Sld.Shapes(4).TextFrame.TextRange = TrainersName & vbNewLine & _
"Trainer"
Sld.Shapes(5).TextFrame.TextRange.Text = "Lt.Ahmed Zayed" & vbNewLine & _
"DNA Analysis Branch Manager"
Call SavePassCertificate
End Sub

Sub SavePassCertificate()
Dim osld As Slide
Dim oToday As String
Set osld = ActivePresentation.SlideShowWindow.View.Slide
oToday = osld.Shapes(3).TextFrame.TextRange.Text
osld.Export "C:\Everything\Complete Training Package\Tests\Certificates\" & UserName & oToday & ".jpg", FilterName:="JPG"

Call PrintCertificate

End Sub
Sub FailCertificate()

Dim Pre As Presentation
Dim Sld As Slide
Dim Number As Integer

Number = 1000 * Rnd
Set Pre = ActivePresentation
Set Sld = Pre.Slides.Add(Index:=Pre.Slides.Count + 1, Layout:=ppLayoutText)
Sld.Shapes(1).TextFrame.TextRange = "PAA Storstar Sample Batching Theory Test"
Sld.Shapes(2).TextFrame.TextRange = vbNewLine & _
vbNewLine & _
"Unfortunately you have not been succesfull on this attempt " & UserName & "." & vbNewLine & _
vbNewLine & _
"You scored " & Int((numberCorrect / (numberCorrect + numberWrong)) * 100) & "%." & vbNewLine & _
vbNewLine & _
"The pass mark for this test is 80%." & vbNewLine & _
vbNewLine & _
"Please pass this page and the results summary to your trainer, " & TrainersName & "."
ActivePresentation.SlideShowWindow.View.GotoSlide (37)
Call SaveFailCertificate
End Sub

Sub SaveFailCertificate()
Dim osld As Slide
Set osld = ActivePresentation.SlideShowWindow.View.Slide
osld.Export "C:\Everything\Complete Training Package\Tests\Certificates\" & UserName & "Fail" & Number & ".jpg", FilterName:="JPG"

Call PrintCertificate

End Sub
Sub PrintCertificate()
ActivePresentation.SlideShowWindow.View.GotoSlide (37) 'SET to last slide number +1
With ActivePresentation
With .PrintOptions
.OutputType = ppPrintOutputSlides
.RangeType = ppPrintSlideRange
With .Ranges
.ClearAll
.Add 37, 37 'set to last slide number +1
End With
End With
.PrintOut
End With
Call Deleter
End Sub


Sub Deleter()
Dim osld As Slide
Dim oShp As Shape
Dim CurrentSlide As Integer
For Each osld In ActivePresentation.Slides
For Each oShp In osld.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.TextRange.Find("The pass mark for this test") Is Nothing Then
'didn't find it
Else
'found it
osld.Delete
Exit Sub
End If
End If
Next oShp
Next osld
End Sub



A results summary (already created) is printed, then deleted. The mark obtained is then calculated, and either a pass of fail certificate is generated. The certificate is then saved as a jpg and then printed. The certificate is then deleted.

Well that is what is supposed to happen...

The certificate is created fine but then it stops....

When I go in to VBA and manually run the save certificate macro that runs fine to. When I run from the Sub Certificate directly it works fine but the whole lot wont run together??

Any ideas?

[John Wilson]

Not sure it makes sense to ADD the results slide to the presentation and then delete it.

Why not create one slide presentations for the blank pass and fail certificates, open the relevant one and fill in the details. print and save as and then close without saving over the original blank.

[tives]

Thanks John, that does seem more sensible.

I temporarily fixed the problem by forcing a pause in the macros before the certificate is exported and printed. It seems I was asking my laptop to do too much at once.

Unfortunately in a second test the process still falls over even with the stop. Is my code really labour intensive for the processor to run???

[John Wilson]

I suspect the macro doesn't stop when you start printing and gets to the delete part too early

[tives]

I have taken out the save certificate macros and the whole thing works fine.
Is there anything obviously wrong with the save section


Sub SavePassCertificate()
Dim osld As Slide
Dim oToday As String
Set osld = ActivePresentation.SlideShowWindow.View.Slide
oToday = osld.Shapes(3).TextFrame.TextRange.Text
osld.Export "C:\Everything\Complete Training Package\Tests\Certificates\" & UserName & oToday & ".jpg", FilterName:="JPG"
Call PrintCertificate

End Sub

Sub SaveFailCertificate()
Dim osld As Slide
Dim Number As Integer

Number = 1000 * Rnd
Set osld = ActivePresentation.SlideShowWindow.View.Slide
osld.Export "C:\Everything\Complete Training Package\Tests\Certificates\" & UserName & "Fail" & Number & ".jpg", FilterName:="JPG"

Call PrintCertificate

End Sub


Thanks

[John Wilson]

My guess would be that the text in Shapes(3) contains illegal characters for saving. Instead of Date I would try:

Format(Date, "dd_mm_yy")

I would still create a blank certificate and open that!

[tives]

nice idea but for once I tackled that problem already. It is a date in shape 3 but it has been formatted (as below) Think the new certificate is the way to go. :type :coffee:


Sld.Shapes(3).TextFrame.TextRange = Date
Sld.Shapes(3).TextFrame.TextRange.Text = Format(Date, "dd mmmm yyyy")

[kaiyara]

Need some help.
I have few macros in addin created by me. But i would like to know if its possible to open a window at the right side populated with My macro buttons. Similar to What we have in Word for applying styles. Any suggestions or help will help me to learn.