How do I make the text of Shape1 appear on Shape2 when I click Sha

  • Thread starter Thread starter Preschool Mike
  • Start date Start date
P

Preschool Mike

I'm trying to create a quiz (game) for my class where when presented with a
word "cat" they must click on the appropriate letters to spell the word.
What I'd like to happen is when they click on the letter "c" that letter will
appear in shape1 and when they click on "a" that will appear in shape2 and so
on. At the same time I want to account for misspelled (incorrect letter
clicks) - so if instead of "c" they click on "b" the "b" would appear. Is
this possible, if so how can I accomplish this task. Or is there a better
way of doing this? I know how to do it using the InputBox procedure, but
they're only preschoolers and they've not quit mastered typing. Any help
would be appreciated.

Thanks,

Mike
 
Up until the very end, I wasn't sure if you were using VBA or not. But
now that I know you are, this is very possible. You can do several
possible things. If you want the letters in one big text box, you can
highlight each letter and set an action setting to run a macro. Even
easier would be to put each letter in it's own shape. Then you could set
the Action Setting for that shape to run your macro. The beautiful thing
about this is that you can do it with one macro so all the boxes/buttons
run the same macro. Here is some air code that I haven't tested, but it
should give you the idea:

Dim count As Long 'This keeps track of how many clicks

Sub ClickMe(oShp As Shape)
Dim myLetter As String

myLetter = oShp.TextFrame.TextRange.Text
count = count + 1
If count = 1 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("FirstBox") _
.TextFrame.TextRange.Text = my Letter
Else If count = 2 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("SecondBox") _
.TextFrame.TextRange.Text = my Letter
Else If count = 3 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("ThirdBox") _
.TextFrame.TextRange.Text = my Letter
'Do something here to indicate you are done with all the clicks
EndIf
End Sub
 
Sorry I wasn't more clear. I do appreciate the help and need it once more.
I having some problems and not quit sure why. I've only been working with
VBA for a few months so I'm a novice at best.

What seems to be happening is the WrongAnswer procedure runs no matter if
the answer is correct or incorrect. I think it's because it's not picking up
the last letter I click on while running the quiz, at least it doesn't appear
on the printable page. Here's how I'd like this to work - on the slide the
word "cat" appears in a Shape1. The child then has to click on "c" "a" "t"
which displays in Shape2 and then you proceed to the next question/problem.
That all seems to work, but when I get to the printable page it displays
"ca_" no "t" and tell me I got the question wrong. Here's my code and some
explanations why I did coeded things the way I did.

Dim userName As String
Dim numCorrect As Integer
Dim numIncorrect As Integer
Dim rightUser As String
Dim qAnswered1 As Boolean
Dim answer1 As String
Dim qAnswered2 As Boolean
Dim answer2 As String
Dim qAnswered3 As Boolean
Dim answer3 As String
Dim numQuestions As Long
Dim printableSlideNum As Long
Dim homeButton As Shape
Dim quitButton As Shape
Dim MyRewardButton As Shape
Dim printButton As Shape
Dim TestName As String
Dim count As Long

Sub Question1(oShp As Shape)
Dim myLetter As String
Dim answer


answer =
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox1").TextFrame.TextRange.Text 'TextBox1 is where their answer will be displayed
myLetter = oShp.TextFrame.TextRange.Text
count = count + 1
If count = 1 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox1") _
..TextFrame.TextRange.Characters(1).Text = myLetter 'Choose
to use (.Characters) and put the answer in one shape because I thought
ElseIf count = 2 Then 'it
would be easier to code to determine if the answer was correct or incorrect
and the printable page
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox1") _
..TextFrame.TextRange.Characters(2).Text = myLetter
ElseIf count = 3 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox1") _
..TextFrame.TextRange.Characters(3).Text = myLetter
If q1Answered = False Then
answer1 = answer
End If
If answer =
ActivePresentation.SlideShowWindow.View.Slide.Shapes("DisplayBox1").TextFrame.TextRange.Text Then 'DisplayBox1 shows the word they must spell
RightAnswer1
Else
WrongAnswer1
End If
CleanCount 'If I don't add this it stops counting after 3 and I can't
proceed with the next question - can't enter any more letters
End If
End Sub
Sub RightAnswer1()
If q1Answered = False Then
numCorrect = numCorrect + 1
End If
q1Answered = True

End Sub
Sub WrongAnswer1()
If q1Answered = False Then
numIncorrect = numIncorrect + 1
End If
q1Answered = True
ActivePresentation.SlideShowWindow.View.Next
End Sub

Sub Question2(oShp As Shape)
Dim myLetter As String
Dim answer

answer =
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox2").TextFrame.TextRange.Text
myLetter = oShp.TextFrame.TextRange.Text
count = count + 1
If count = 1 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox2") _
..TextFrame.TextRange.Characters(1).Text = myLetter
ElseIf count = 2 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox2") _
..TextFrame.TextRange.Characters(2).Text = myLetter
ElseIf count = 3 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox2") _
..TextFrame.TextRange.Characters(3).Text = myLetter
If q2Answered = False Then
answer2 = answer
End If
If answer =
ActivePresentation.SlideShowWindow.View.Slide.Shapes("DisplayBox2").TextFrame.TextRange.Text Then
RightAnswer2
Else
WrongAnswer2
End If
CleanCount 'If I don't add this it stops counting after 3 and I can't
proceed with the next question - can't enter any more letters
End If
End Sub
Sub RightAnswer2()
If q2Answered = False Then
numCorrect = numCorrect + 1
End If
q2Answered = True
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub WrongAnswer2()
If q2Answered = False Then
numIncorrect = numIncorrect + 1
End If
q2Answered = True
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Question3(oShp As Shape)
Dim myLetter As String
Dim answer

answer =
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox3").TextFrame.TextRange.Text
myLetter = oShp.TextFrame.TextRange.Text
count = count + 1
If count = 1 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox3") _
..TextFrame.TextRange.Characters(1).Text = myLetter
ElseIf count = 2 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox3") _
..TextFrame.TextRange.Characters(2).Text = myLetter
ElseIf count = 3 Then
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox3") _
..TextFrame.TextRange.Characters(3).Text = myLetter
If q3Answered = False Then
answer3 = answer
End If
If answer =
ActivePresentation.SlideShowWindow.View.Slide.Shapes("DisplayBox3").TextFrame.TextRange.Text Then
RightAnswer3
Else
WrongAnswer3
End If
CleanCount 'If I don't add this it stops counting after 3 and I can't
proceed with the next question - can't enter any more letters
End If
End Sub
Sub RightAnswer3()
If q3Answered = False Then
numCorrect = numCorrect + 1
End If
q3Answered = True
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub WrongAnswer3()
If q3Answered = False Then
numIncorrect = numIncorrect + 1
End If
q3Answered = True
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub CleanCount()
count = 0 'Added this for the reset button on each slide so if they click on
the wrong letter they can start over also because of above explanation
End Sub
Sub Reset() 'Added this for the reset button on each slide so if they click
on the wrong letter they can start over
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox1").TextFrame.TextRange.Text = ""
CleanCount
End Sub
Sub Reset2() 'Added this for the reset button on each slide so if they click
on the wrong letter they can start over
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox2").TextFrame.TextRange.Text = ""
CleanCount
End Sub
Sub Reset3() 'Added this for the reset button on each slide so if they click
on the wrong letter they can start over
ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox3").TextFrame.TextRange.Text = ""
CleanCount
End Sub
Sub GetStarted()
Initialize
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub selectUser(nameButton As Shape)
userName = nameButton.TextFrame.TextRange.Text
rightUser = MsgBox("Are you " & userName & "? ", vbYesNo)
If rightUser = vbYes Then
GetStarted
Else
MsgBox ("Sign in again")
End If
End Sub
Sub YourName()
userName = InputBox(prompt:="Type your name") 'Optional sign in by
typing in student name
Initialize
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub CleanTextBoxes() 'Clears all answer boxes at start up
ActivePresentation.Slides(2).Shapes("TextBox1").TextFrame.TextRange.Text = ""
ActivePresentation.Slides(3).Shapes("TextBox2").TextFrame.TextRange.Text = ""
ActivePresentation.Slides(4).Shapes("TextBox3").TextFrame.TextRange.Text = ""
End Sub
Sub Initialize()
Dim i As Long
CleanTextBoxes
TestName =
ActivePresentation.Slides(1).Shapes("TestNameBox").TextFrame.TextRange.Text
numCorrect = 0
numIncorrect = 0
count = 0
q1Answered = False
q2Answered = False
q3Answered = False
printableSlideNum = ActivePresentation.Slides.count + 1

End Sub


Sub SetObjectName()
Dim objectName As String

If ActiveWindow.Selection.Type = ppSelectionShapes _
Or ActiveWindow.Selection.Type = ppSelectionText Then
If ActiveWindow.Selection.ShapeRange.count = 1 Then
objectName = InputBox(prompt:="Type a name for the object")
objectName = Trim(objectName)
If objectName = "" Then
MsgBox ("You did not type anything. " & _
"the name will remain " & _
ActiveWindow.Selection.ShapeRange.Name)
Else
ActiveWindow.Selection.ShapeRange.Name = objectName
End If
Else
MsgBox _
("You can not name more than one shape at a time. " _
& "Select only one shape and try again.")
End If
Else
MsgBox ("No shapes are selected.")
End If
End Sub

Sub SetSlideName()
Dim slideName As String

slideName = InputBox(prompt:="Type a name for the slide")
slideName = Trim(slideName)
If slideName = "" Then
MsgBox ("you did not type anything. " & _
"The name will remain " & _
ActiveWindow.View.Slide.Name)
Else
ActiveWindow.View.Slide.Name = slideName
End If
End Sub

Sub GetSlideName()
MsgBox ActiveWindow.View.Slide.Name
End Sub
Sub GetObjectName()
If ActiveWindow.Selection.Type = ppSelectionShapes _
Or ActiveWindow.Selection.Type = ppSelectionText Then
If ActiveWindow.Selection.ShapeRange.count = 1 Then
MsgBox (ActiveWindow.Selection.ShapeRange.Name)
Else
MsgBox ("You have selected more than one shape.")
End If
Else
MsgBox ("No shapes are selected.")
End If
End Sub
Sub PrintablePage()
Dim printableSlide As Slide

Set printableSlide = _
ActivePresentation.Slides.Add(Index:=printableSlideNum, _
Layout:=ppLayoutText)
printableSlide.Shapes(1).TextFrame.TextRange.Text = _
"Results for " & userName & Chr$(13) & TestName
printableSlide.Shapes(1).TextFrame.TextRange.Font.Size = 32

printableSlide.Shapes(2).TextFrame.TextRange.Text = _
"Your Answers" & Chr$(13) & _
"Question 1: " & answer1 & Chr$(13) & _
"Question 2: " & answer2 & Chr$(13) & _
"Question 3: " & answer3 & Chr$(13)


printableSlide.Shapes(2).TextFrame.TextRange.Text = _
printableSlide.Shapes(2).TextFrame.TextRange.Text & _
"You got " & numCorrect & " out of " & _
numCorrect + numIncorrect & " correct " & "." & Chr$(13)
printableSlide.Shapes(2).TextFrame.TextRange.Font.Size = 9

Set homeButton = _
ActivePresentation.Slides(printableSlideNum).Shapes.AddShape _
(msoShapeActionButtonCustom, 0, 490, 125, 45)
homeButton.Fill.ForeColor.RGB = vbBlack
homeButton.TextFrame.TextRange.Characters(1, 11).Font.Color.RGB = vbWhite
homeButton.TextFrame.TextRange.Text = "Start Again"
homeButton.ActionSettings(ppMouseClick).Action = ppActionRunMacro
homeButton.ActionSettings(ppMouseClick).Run = "StartAgain"

Set printButton = _
ActivePresentation.Slides(printableSlideNum).Shapes.AddShape _
(msoShapeActionButtonCustom, 200, 490, 125, 45)
printButton.Fill.ForeColor.RGB = vbBlack
printButton.TextFrame.TextRange.Characters(1, 11).Font.Color.RGB = vbWhite
printButton.TextFrame.TextRange.Text = "Print Results"
printButton.ActionSettings(ppMouseClick).Action = ppActionRunMacro
printButton.ActionSettings(ppMouseClick).Run = "PrintResults"
ActivePresentation.SlideShowWindow.View.Next
ActivePresentation.Saved = True

Set MyRewardButton = _
ActivePresentation.Slides(printableSlideNum).Shapes.AddShape _
(msoShapeActionButtonCustom, 400, 490, 125, 45)
MyRewardButton.Fill.ForeColor.RGB = vbBlack 'displays ribbon at end to
tell how well they did
MyRewardButton.TextFrame.TextRange.Characters(1, 11).Font.Color.RGB =
vbWhite
MyRewardButton.TextFrame.TextRange.Text = "My Reward"
MyRewardButton.ActionSettings(ppMouseClick).Action = ppActionRunMacro
MyRewardButton.ActionSettings(ppMouseClick).Run = "MyReward"

Set quitButton = _
ActivePresentation.Slides(printableSlideNum).Shapes.AddShape _
(msoShapeActionButtonCustom, 590, 490, 125, 45)
quitButton.Fill.ForeColor.RGB = vbBlack
quitButton.TextFrame.TextRange.Characters(1, 4).Font.Color.RGB = vbWhite
quitButton.TextFrame.TextRange.Text = "Quit"
quitButton.ActionSettings(ppMouseClick).Action = ppActionRunMacro
quitButton.ActionSettings(ppMouseClick).Run = "Quit"
End Sub

Sub Quit()
ActivePresentation.Close
End Sub
Sub PrintResults()
homeButton.Visible = False
printButton.Visible = False
MyRewardButton.Visible = False
quitButton.Visible = False
ActivePresentation.PrintOptions.OutputType = ppPrintOutputSlides
ActivePresentation.PrintOut From:=printableSlideNum, To:=printableSlideNum
homeButton.Visible = True
printButton.Visible = True
MyRewardButton.Visible = True
quitButton.Visible = True
End Sub

Sub StartAgain()
ActivePresentation.SlideShowWindow.View.GotoSlide (1)
ActivePresentation.Slides(printableSlideNum).Delete
ActivePresentation.Saved = True
End Sub
Sub Doing1() 'For the ribbon
Dim myReward1 As Shape
Set myReward1 = _
ActivePresentation.SlideShowWindow.View.Slide.Shapes. _
AddShape(Type:=msoShapeCurvedUpRibbon, Left:=400, Top:=175, Width:=300,
Height:=200)
myReward1.Fill.ForeColor.RGB = vbBlue
myReward1.TextFrame.TextRange.Text = "Excellent"
End Sub

Sub Doing2() 'For the ribbon
Dim myReward2 As Shape
Set myReward2 = _
ActivePresentation.SlideShowWindow.View.Slide.Shapes. _
AddShape(Type:=msoShapeCurvedUpRibbon, Left:=400, Top:=175, Width:=300,
Height:=200)
myReward2.Fill.ForeColor.RGB = vbRed
myReward2.TextFrame.TextRange.Text = "Awesome"
End Sub

Sub Doing3() 'For the ribbon
Dim myReward3 As Shape
Set myReward3 = _
ActivePresentation.SlideShowWindow.View.Slide.Shapes. _
AddShape(Type:=msoShapeCurvedUpRibbon, Left:=400, Top:=175, Width:=300,
Height:=200)
myReward3.Fill.ForeColor.RGB = vbYellow
myReward3.TextFrame.TextRange.Text = "Good Job"
myReward3.TextFrame.TextRange.Characters(1, 8).Font.Color.RGB = vbBlack
End Sub
Sub Doing4()
Dim myReward4 As Shape
Set myReward4 = _
ActivePresentation.SlideShowWindow.View.Slide.Shapes. _
AddShape(Type:=msoShapeCurvedUpRibbon, Left:=400, Top:=175, Width:=300,
Height:=200)
myReward4.Fill.ForeColor.RGB = vbWhite
myReward4.TextFrame.TextRange.Text = "Nice Try"
myReward4.TextFrame.TextRange.Characters(1, 8).Font.Color.RGB = vbBlack
End Sub
Sub MyReward() 'For the ribbon
If numCorrect >= 0.95 * (numCorrect + numIncorrect) Then
Doing1
ElseIf numCorrect >= 0.85 * (numCorrect + numIncorrect) Then
Doing2
ElseIf numCorrect >= 0.75 * (numCorrect + numIncorrect) Then
Doing3
Else
Doing4
End If
End Sub
 
This is going to be really tough for me to debug without the
presentation, but here is something odd that I see and possibly a better
way to do it. When you put a character in the text box with something
like:

ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox2") _
..TextFrame.TextRange.Characters(3).Text = myLetter

This seems very odd to me. You are trying to change character 3 of a
text box that doesn't have 3 characters. This could cause all kinds of
weird behavior. I would add text by doing something like this:

With ActivePresentation.SlideShowWindow.View.Slide.Shapes("TextBox2") _
.TextFrame.TextRange
.Text = .Text & myLetter
End With

This will append the letter onto the text box, rather than trying to
muck with characters that are not yet part of the text box.

So, this is what I would start with and then see if you are still
getting the error. I suspect that it will fix something, but I'm not
sure if it will fix the problem you are having.

--David
 
Thanks, I'll try this. Any suggestions on where I can learn more about using
VBA with powerpoint and other office producet (e.g., word and excel). I've
read your book and keep it by my side, but like to learn more.

Mike
 
Steve Rindsberg said:
Mike
wrote:

Here's a good starting point

Where can I learn more about VBA programming in PowerPoint?
http://www.pptfaq.com/FAQ00032.htm

And while you're there, you might want to browse through this section:

PROGRAMMING POWERPOINT
http://www.pptfaq.com/index.html#name_PROGRAMMING_POWERPOINT
Click to expand...

I concur with Steve. I was going to make the same suggestions.
Unfortunately, once you get beyond my book, there is not much for VBA
and PowerPoint except in bits and pieces (such as a few FAQ entries and
Shyam's Web site). However, for VBA in other Office applications, there
are many books that do a nice job of explaining VBA. The difficulty is
that PowerPoint (with Normal/Edit View and Slide Show View) behaves much
differently than other applications so the books usually don't do a good
job of making that distinction.

--David
 
Back
Top