I just joined and hope to learn all I can here and contribute where I can.
I am having major issues with the last three sections of my VBA script.
The correct, incorrect, and percentage score values are not being displayed on slides 40 & 41.
On slide 42 I cannot get the textbox or the label to display the username, date and their overall percentage score.
Any help on slide 40 would be great and I can workout the rest.
**Sub shapeTextHappySmile()**strong text**
Sub ShapeTextSadSmile()
Sub CertificateBuld()**
Option Explicit
Dim UserName As String
Dim numberCorrect As Integer
Dim numberIncorrect As Integer
Dim numberPercentage As Integer
Dim numberTotal As Integer
Private Sub CertDate()
Dim Rdate As Variant
Rdate = Date
Rdate = Format((Date), "mmmm dd, yyyy")
End Sub
Sub Initialise()
numberCorrect = 12
numberIncorrect = 8
numberPercentage = 58
numberTotal = 20
numberTotal = (numberCorrect + numberIncorrect)
numberCorrect = (numberTotal - numberIncorrect)
numberIncorrect = (numberTotal - numberCorrect)
numberPercentage = Round(numberCorrect / numberTotal) * 100
End Sub
Sub TakeQuiz()
UserName = InputBox(Prompt:="Type Your Name! ")
MsgBox "Welcome To The Academic Online Tutorial Quiz " + UserName, vbApplicationModal, " Academic Online Tutorial Quiz"
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Correct()
numberCorrect = numberCorrect + 1
MsgBox ("Great well Done! That's the correct answer")
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Incorrect()
numberIncorrect = numberIncorrect + 1
MsgBox ("Sorry! That was the incorrect answer")
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub shapeTextHappySmile()
ActivePresentation.Slides(40).Shapes(Label1).TextFrame.TextRange.Text = 12
'numberCorrect
ActivePresentation.Slides(40).Shapes(Label2).TextFrame.TextRange.Text = numberPercentage & "%"
MsgBox "Great Job, Well done " + "," & "Please print a copy of your completion certificate"
MsgBox "After printing or saving a copy of your certificate, you can exit the presentation"
With SlideShowWindows(1).View
.GotoSlide 42
End With
End Sub
Sub ShapeTextSadSmile()
ActivePresentation.Slides(41).Shapes("AnsweredIncorrectly").TextFrame.TextRange.Text = numberIncorrect
ActivePresentation.Slides(41).Shapes("InCorrectPercentage").TextFrame.TextRange.Text = numberPercentage & " %"
MsgBox "Your score was below 70%, in order to pass the quiz and receive a certificate of completion you need to score 70% or more."
MsgBox "Please retake the quiz, and good luck"
With SlideShowWindows(1).View
.GotoSlide 1
End With
' I will add the option of redoing the entire presentation or just the quiz.
'see slide 19 action buttons
End Sub
Sub CertificateBuld()
MsgBox "Great Job, Well done " + "," & "Plese print a copy of your completion certificate"
MsgBox "After printing or saving a copy of your certificate, please exit the presentation"
If numberCorrect >= "14" Then
ActivePresentation.Slides(42).Shapes(" ABCDEFGHIJKLMN ").TextFrame.TextRange.Text = " ABCDEFGHIJKLMN "
ActivePresentation.Slides(42).Shapes("Rdate & Percentage").TextFrame.TextRange.Text = " ON " & Rdate & " WITH A SCORE OF " & numberPercentage & " %"
ActivePresentation.Slides(42).Shapes(UserName).TextFrame.TextRange.Text = UserName
'OR
If numberCorrect <= "14" Then
ActivePresentation.Slides(42).Shapes(8).TextFrame.TextRange.Text = ABCDEFGHIJKLMN "
ActivePresentation.Slides(42).Shapes(9).TextFrame.TextRange.Text = Rdate & " ON " & Rdate & " WITH A SCORE OF " & numberPercentage & " %"
ActivePresentation.Slides(42).Shapes(10).TextFrame.TextRange.Text = UserName
Else
ActivePresentation.SlideShowWindow.View.Save
ActivePresentation.SlideShowWindow.View.Exit
End If
End Sub
See comments inline:
Sub shapeTextHappySmile()
' This won't work:
'ActivePresentation.Slides(40).Shapes(Label1).TextFrame.TextRange.Text = 12
' Shapes have names that are strings, so you need to use .Shapes("Label1")
' Assuming this is an ActiveX label, you get at its properties a bit
' differently from regular PPT shapes, starting with:
' .Shapes("Label1").OLEFormat.Object
' And for a Label ActiveX control, the property you want is .Caption
' And finally, Text/Caption properties take a String value so you want to
' put the 12 in quotes or convert a numeric value to string using Cstr(x)
' Final version:
ActivePresentation.Slides(40).Shapes("Label1").OLEFormat.Object.Caption = "12"
'numberCorrect
' And make the same changes to this one:
ActivePresentation.Slides(40).Shapes(Label2).TextFrame.TextRange.Text = numberPercentage & "%"
' MsgBox "Great Job, Well done " + "," & "Please print a copy of your completion certificate"
' and I think you probably want to do this instead of the above:
MsgBox "Great Job, Well done" & ", " & "Please print a copy of your completion certificate"
MsgBox "After printing or saving a copy of your certificate, you can exit the presentation"
With SlideShowWindows(1).View
.GotoSlide 42
End With
End Sub
Related
Creating an access database for work. Users will use a split form with only the datasheet visible to review and manipulate numeric data. On the form I have built in quick filters that consist of of textboxes in which the values are either raised or lowered with arrow buttons that have on-click events. I currently have the text boxes linked to the recordsource query criteria.
With all of this stated, the problem that I am having is that I need the filter to act in the following manner:
If the value in the text box equals 0 I want to see all records. If the value is greater than 0, I want all records greater than or equal to the text box value to show. Finally, if the value in the text box is less than 0, I want to see all values less than or equal to 0.
I have considered trying to use multiple sql statements but I typically have about 3 of these quick filters on each form, and my project will eventually have about 20 forms. That is a lot of sql statements to potentially mess up.
What ideas do you guys have to solve this problem? I really need help.
If you only have 1 textbox on each form, then you may want to consider using the form's Filter property:
Private Sub txtFilter_AfterUpdate()
On Error GoTo E_Handle
If Not IsNull(Me!txtFilter) Then
If IsNumeric(Me!txtFilter) Then
Select Case Me!txtFilter
Case Is < 0
Me.Filter = "Price<=0"
Me.FilterOn = True
Case 0
Me.FilterOn = False
Case Is > 0
Me.Filter = "Price>=" & Me!txtFilter
Me.FilterOn = True
End Select
End If
End If
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "Form2!txtFilter_AfterUpdate", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
If need to have multiple filters, then consider moving the filter creation to a procedure by itself that handles all cases, and just call this procedure from each text box. You may have to think about the logic here of what happens if one text box is 0 (No filter), but another text box is 5 (display all values >= 5) and another text box is -3 (display all values <= 0):
Private Sub txtFilter2_AfterUpdate()
On Error GoTo E_Handle
Call sFilterForm2
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "Form2!txtFilter2_AfterUpdate", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Private Sub sFilterForm2()
On Error GoTo E_Handle
Dim strSQL As String
If Not IsNull(Me!txtFilter) Then
If IsNumeric(Me!txtFilter) Then
Select Case Me!txtFilter
Case Is < 0
strSQL = " AND Price<=0 "
Case 0
Case Is > 0
strSQL = strSQL & " AND Price>=" & Me!txtFilter
End Select
End If
End If
If Not IsNull(Me!txtFilter2) Then
If IsNumeric(Me!txtFilter2) Then
Select Case Me!txtFilter2
Case Is < 0
strSQL = " AND Price<=0 "
Case 0
Case Is > 0
strSQL = strSQL & " AND Price>=" & Me!txtFilter2
End Select
End If
End If
If Len(strSQL) > 0 Then
strSQL = Mid(strSQL, 5)
Me.Filter = strSQL
Me.FilterOn = True
Else
Me.FilterOn = False
End If
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "Form2!sFilterForm2", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards
Given a text box control CriteriaField1 and a corresponding field to filter Field1 in the record source I would use this:
Private Sub CriteriaField1_AfterUpdate()
Const FIELD_NAME As String = "Field1"
Dim value As Long
value = Nz(Me("Criteria" & FIELD_NAME).Value, 0)
Dim condition As String
condition = FIELD_NAME & IIf(value < 0, " <= 0", " >= " & value)
Me.FilterOn = value <> 0
End Sub
If you need to combine multiple fields to a filter condition, you would have to use and set form-global variables instead of local ones.
You could call a helper function which holds a set of arrays and builds and sets the filter dynamically:
Private Sub Filter0_AfterUpdate()
SetFilter
End Sub
Private Sub Filter1_AfterUpdate()
SetFilter
End Sub
Private Sub Filter2_AfterUpdate()
SetFilter
End Sub
Private Sub SetFilter()
Dim FieldNames() As Variant
Dim TextboxNames() As Variant
Dim Criteria() As String
Dim Index As Integer
Dim Value As Long
' Specify the field names to filter on.
FieldNames = Array("Quantity", "Stock", "Size")
' Specify the names of the textboxes to enter filter values.
TextboxNames() = Array("Filter0", "Filter1", "Filter2")
ReDim Criteria(LBound(TextboxNames) To UBound(TextboxNames))
For Index = LBound(Criteria) To UBound(Criteria)
Value = Val(Nz(Me(TextboxNames(Index)).Value))
If Value < 0 Then
Criteria(Index) = FieldNames(Index) & " <= 0"
ElseIf Value > 0 Then
Criteria(Index) = FieldNames(Index) & " >= " & CStr(Value)
Else
Criteria(Index) = "True"
End If
Next
' Assemble and apply the filter.
Me.Filter = Join(Criteria, " And ")
Me.FilterOn = True
Debug.Print Me.Filter
End Sub
I have a textbox set up in a GUI where the user can enter information. This string is then spit out in a textbox within a PPT slide. Depending on the number of lines used in the textbox within the PPT slide, I need to enter the next set of information so many new lines below the text from the textbox. Here is what I have so far:
This is the code that takes the text the user enters in the textbox within the GUI and places it in the textbox within the PPT slide:
Private Sub Location()
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'Make sure there is text in the call to action textbox. If not, display an error message.
If C2AText = "" Then
MsgBox "Woah there! You need to enter text in the location/call to action box."
'Otherwise, if text is inserted, place that text in the WarningData box found on the PPT slide.
Else
.TextRange = C2AText
.TextRange.Paragraphs.Font.Size = 21
.TextRange.Paragraphs.Font.Name = "Calibri"
.TextRange.Paragraphs.Font.Shadow.Visible = True
.TextRange.Paragraphs.Font.Bold = msoTrue
End If
End With
End Sub
This text determines whether or not anything is selected in the HailInfo drop down. If it is, I need to place this text so many lines below the C2AText that was inserted in the previous Sub:
Private Sub HailInfo()
Call Dictionary.HailInfo
ComboBoxList = Array(CStr(HailDropDown))
For Each Ky In ComboBoxList
'On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in HailDropDown, do nothing and exit this sub.
If HailDropDown = "" Then
Exit Sub
'If a hail option is selected, execute the following code.
ElseIf HailDropDown <> "" And C2AText.LineCount = 2 Then
.TextRange = .TextRange & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
ElseIf HailDropDown <> "" And C2AText.LineCount = 3 Then
.TextRange = .TextRange & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
End If
End With
Next
Set dict2 = Nothing
End Sub
Using the C2AText.LineCount within the HailInfo sub does not appear to do anything. It will not insert the hail text anywhere, so I am not sure what I am doing wrong. Any help would be greatly appreciated...thanks!!
You should try the following ...
Private Sub HailInfo()
Call Dictionary.HailInfo
ComboBoxList = Array(CStr(HailDropDown))
For Each Ky In ComboBoxList
'On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in HailDropDown, do nothing and exit this sub.
If HailDropDown = "" Then
Exit Sub
'If a hail option is selected, execute the following code.
Else
.TextRange.Text = .TextRange.Text & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
End If
End With
Next
Set dict2 = Nothing
End Sub
You were only referencing .TextRange, rather than .TextRange.Text.
Also, because you need to add the text at the end, you only need an Else condition, rather than two ElseIfs that both do the same thing! ;0)
More example code ... https://msdn.microsoft.com/en-us/library/office/ff822136.aspx
I have a PPT quiz that functions of macro actions. It counts the numberCorrect and the numberWrong and reports these scores to the user at the end of the quiz when they press the "see my results" box.
I would like these scores to be automatically reported to me when they select this box because I do not want the users taking the test numerous times prior to submitting their results.
Everyone will be using a G-mail account.
Here is my current visual basic module if that helps:
Dim UserName As String
Dim numberCorrect As Integer
Dim numberWrong As Integer
Sub YourName()
UserName = InputBox(Prompt:="Type Your Name!")
MsgBox " Good Luck " + UserName, vbApplicationModal, " IEE Recognition Training"
End Sub
Sub Correct()
MsgBox " Well Done! That's The Correct Answer " + UserName, vbApplicationModal, " IEE Recognition Training"
numberCorrect = numberCorrect + 1
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Wrong()
MsgBox " Sorry! That's The Wrong Answer " + UserName, vbApplicationModal, " IEE Recognition Training"
numberWrong = numberWrong + 1
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Start()
numberCorrect = 0
numberWrong = 0
YourName
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Results()
MsgBox ("You Got " & numberCorrect & " Correct Answers, " & numberWrong & " Wrong Answers, " & UserName), vbApplicationModal, " IEE Recognition Training"
End Sub
Any help is greatly appreciated !!! Thanks!
You could do this easily with the Outlook object model in VBA but are the users using that client to connect to GMail accounts or are they using a web client? If you don't use an Outlook object in your VBA code, you'd be looking at direct use of SMTP which is a much more complicated beast. Here is an Outlook snippet using late binding:
Set oOL = CreateObject("Outlook.Application")
Set oEmail = oOL.CreateItem(0) ' olMailItem = 0
With oEmail
.BodyFormat = 1 ' olFormatPlain = 1
.Subject = "Automatic results"
.Body = "You Got " & numberCorrect & " Correct Answers, " & numberWrong & " Wrong Answers, " & UserName
.To = "admin#mydomain.com"
.Send
End With
Set oOL = Nothing: Set oEmail = Nothing
I posted a rubbish question about this before and have gone away and done some work on it to re-ask. Basically I've made a ppt quiz that counts how many correct and incorrect answers a person has given. It then feeds this information back to the user at the end. However what I want to happen now is I want the results to be stored so that I can go back in and see how each user has performed in the quiz. Ideally I would like it to work over 6 networked computers storing all the quiz results in one place. But if need be I can just take a file from each of the 6 computers.
My code so far looks like this:
Dim username As String
Dim numberCorrect As Integer
Dim numberWrong As Integer
Sub YourName()
username = InputBox(prompt:="Type your Name")
MsgBox " Get Ready to begin " + username, vbApplicationModal, " Orange 1C Book 7"
End Sub
Sub correct()
numberCorrect = numberCorrect + 1
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub incorrect()
numberWrong = numberWrong + 1
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Start()
numberCorrect = 0
numberWrong = 0
YourName
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Results()
MsgBox "Well done " & username & " You got " & numberCorrect & " out of " & numberCorrect + numberWrong, vbApplicationModal, "Orange 1C Book 7"
End Sub'
Any help would be greatly appreciated. Not sure where to begin with the next step.
Here goes one option for you... But some explanation first. This code will create TXT file. Each time someone will reach Results macro it will add results to the file. So, one file will keep all the results until you don't delete them (or the file). Therefore I've added separation line and date/time information for you to easily find appropriate results.
Sub Save_Results_To_Txt()
'set file results location to activepresentation path
'or could be changed to any path string
Dim strWhere As String
strWhere = ActivePresentation.Path
'let's set name of the file separately
Dim strName As String
strName = "\results.txt"
Dim ff As Long
ff = FreeFile
Open strWhere & strName For Append As #ff
Write #ff, Now & vbTab & username
Write #ff, numberCorrect & vbTab & vbTab & numberWrong
Write #ff, String(30, "-")
Close #ff
End Sub
You need to add Save_Results_To_Txt to your Results sub, possibly before MsgBox line.
Your results.txt file will look like:
"2013-04-25 16:11:05 Tom"
"10 11"
"------------------------------"
"2013-04-25 16:11:23 Mark"
"11 10"
"------------------------------"
Need some help finishing up this program, everything works and runs like I want it but I need to display an inputbox that allows the user to enter in the date they want for their invoice stored in service_date and then this date will display in the listbox with all the other items that I have put in there. I know I need to use the AddDays function but I have no clue on how to do it, and researching online has just led me to 100 other things that aren't that.
So here is my code:
Dim Customer As String
Dim Phone As String
Dim Hours As Double
Dim Parts As Double
Dim due_date As String
Dim service_date As String
Private Sub cmdInputBox_Click()
Dim service_date = InputBox("Enter the date of service. (MM/DD?YYYY)")
MsgBox("That's your date, " & service_date.ToString)
Exit Sub
End Sub
Private Sub CustInfo_Click()
Customer = txtCustomer.Text
Phone = mtbPhone.Text
Double.TryParse(txtHours.Text, Hours)
Double.TryParse(txtParts.Text, Parts)
If Customer.Length < 0 Then
MessageBox.Show("Please enter customer information.")
End If
If Phone = "" Then
MessageBox.Show("Please enter phone number.")
End If
If Not Double.TryParse(txtHours.Text, Hours) Then
MessageBox.Show("Please enter labor hours.")
End If
If Not Double.TryParse(txtParts.Text, Parts) Then
MessageBox.Show("Please enter parts and supplies.")
End If
''Perform calculations
Dim Total_Cost As Double
Dim Labor_Cost As Double
Dim Parts_Cost As Double
Parts_Cost = (Parts * 0.5 * 2)
Labor_Cost = (Hours * 35)
Total_Cost = (Hours + Parts)
Customer = txtCustomer.Text
Phone = mtbPhone.Text
lstBill.Items.Clear()
lstBill.Items.Add("Customer: " & vbTab & Customer.ToUpper)
lstBill.Items.Add("Phone: " & vbTab & vbTab & Phone)
lstBill.Items.Add("Service Date: " & vbTab & due_date)
lstBill.Items.Add("Invoice Date: " & vbTab & service_date)
lstBill.Items.Add("Labor Cost: " & vbTab & FormatCurrency(Labor_Cost))
lstBill.Items.Add("Parts Cost: " & vbTab & FormatCurrency(Parts_Cost))
lstBill.Items.Add("Total Cost: " & vbTab & FormatCurrency(Total_Cost))
Exit Sub
End Sub
Private Sub btnBill_Click(sender As System.Object, e As System.EventArgs) Handles btnBill.Click
cmdInputBox_Click()
CustInfo_Click()
End Sub
Try this:
Dim strDate As String = InputBox("Enter date?", , "")
If strDate = "" Then Exit Sub
Dim dteDate As Date
Dim enUS As New System.Globalization.CultureInfo("en-US")
If Date.TryParseExact(strDate, "MM/dd/yyyy", enUS, Globalization.DateTimeStyles.AssumeLocal, dteDate) Then
MsgBox("Date is " & dteDate.ToString)
End If