Consulting

Results 1 to 8 of 8

Thread: VBA to create, print and save as jpg test results

  1. #1
    VBAX Regular
    Joined
    May 2013
    Posts
    6
    Location

    VBA to create, print and save as jpg test results

    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?

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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.
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    VBAX Regular
    Joined
    May 2013
    Posts
    6
    Location
    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???

  4. #4
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    I suspect the macro doesn't stop when you start printing and gets to the delete part too early
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  5. #5
    VBAX Regular
    Joined
    May 2013
    Posts
    6
    Location
    I have taken out the save certificate macros and the whole thing works fine.
    Is there anything obviously wrong with the save section

    [vba]
    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
    [/vba]

    Thanks

  6. #6
    VBAX Master
    Joined
    Feb 2007
    Posts
    2,093
    Location
    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!
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  7. #7
    VBAX Regular
    Joined
    May 2013
    Posts
    6
    Location
    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.

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

  8. #8
    VBAX Newbie
    Joined
    Jul 2013
    Posts
    1
    Location
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •