Membuat rumus penilaian dinamis

Membuat rumus penilaian dinamis

September 2, 2010 Admin Leave a comment Go to comments

Setahun yang lalu, sewaktu saya masih aktif mengembangkan aplikasi sekolah di beberapa kabupaten di Riau, masalah yang sering saya hadapi adalah tidak adanya standarisasi rumus dalam menentukan nilai akhir siswa (rapor akhir), tetapi untung saja variabel nilainya masih sama (rata2 tugas, rata2 ulangan, uts dan uas).
Pada awalnya saya hanya menyediakan input prosentasi untuk masing-masing nilai tersebut, dan tentu saja cara ini tidak memberikan solusi yang terbaik mengingat masing-masing guru terkadang mempunyai rumus penilaian yang berbeda.
Jadi alternatif solusi lain yang saya tawarkan adalah dengan memberikan keleluasaan untuk menginputkan sendiri rumus dan untuk melakukan ini kita harus mendefinisikan konstanta untuk mewakili nilai-nilai diatas sebagai berikut :

Contoh untuk mendapatkan nilai akhir dengan rumus :
Nilai Akhir = ((Rata2 tugas + Rata2 ulangan + UTS) / 3 x 0.6) + (UAS x 0.4)
Maka rumus yang harus diinputkan adalah sebagai berikut :

Gimana sampe disini konsepnya sudah jelas bukan, klo iya kita bahas kodenya satu per satu dan untuk menyederhanakan program, nilai dari rata2x tugas, rata2x ulangan, uts dan uas langsung diinputkan via textbox.
Pertama kita desain dulu tampilannya seperti berikut :

kemudian tambahkan fungsi berikut untuk memvalidasi inputan nilai hanya boleh angka.

view source

print?

01	Private Function validAngka(KeyAscii As Integer) As Integer

02	Dim strValid As String

03

04	On Error GoTo errHandle

05

06	strValid = "0123456789."

07

08	If InStr(strValid, Chr(KeyAscii)) = 0 And Not (KeyAscii = vbKeyBack) Then

09	validAngka = 0

10

Else

11	validAngka = KeyAscii

12

End If

13

14	Exit Function

15	errHandle:

16	validAngka = 0

17	End Function

kemudian tinggal panggil dimasing-masing event keypress inputan nilai

view source

print?

01	Private Sub txtRata2Tugas_KeyPress(KeyAscii As Integer)

02	KeyAscii = validAngka(KeyAscii)

03

End Sub

04

05	Private Sub txtRata2Ulangan_KeyPress(KeyAscii As Integer)

06	KeyAscii = validAngka(KeyAscii)

07

End Sub

08

09	Private Sub txtUAS_KeyPress(KeyAscii As Integer)

10	KeyAscii = validAngka(KeyAscii)

11

End Sub

12

13	Private Sub txtUTS_KeyPress(KeyAscii As Integer)

14	KeyAscii = validAngka(KeyAscii)

15

End Sub

selain memvalidasi inputan nilai kita juga harus memvalidasi inputan rumus penilaian, berikut fungsinya.

view source

print?

01	Private Function validKarakterRumus(KeyAscii As Integer) As Integer

02	Dim strValid As String

03

04	On Error GoTo errHandle

05

06	strValid = "0123456789aArRtTuUsS()<>+*/-. "

07

08	If InStr(strValid, Chr(KeyAscii)) = 0 And Not (KeyAscii = vbKeyBack) Then

09	validKarakterRumus = 0

10

Else

11	validKarakterRumus = KeyAscii

12

End If

13

14	Exit Function

15	errHandle:

16	validKarakterRumus = 0

17	End Function

sama seperti sebelumnya tinggal panggil di event keypress inputan rumus

view source

print?

1	Private Sub txtRumus_KeyPress(KeyAscii As Integer)

2	KeyAscii = Asc(UCase(Chr(KeyAscii))) 'otomatis huruf besar

3	KeyAscii = validKarakterRumus(KeyAscii)

4

End Sub

terakhir untuk tombol Proses akan melakukan pengecekan terhadap rumus yang diinputkan jika oke akan langsung menampilkan hasil nya :

view source

print?

001	Private Function isValidConst(ByVal value As String) As Boolean

002	Dim i           As Integer

003	Dim strNotValid As String

004

005	On Error GoTo errHandle

006

007	strNotValid = "aArRtTuUsS" 'karakter konstanta RT, RU, UTS dan UAS

008

009	isValidConst = True

010	For i = 1 To Len(value)

011	If InStr(1, strNotValid, Mid(value, i, 1)) > 0 Then

012	isValidConst = False

013

Exit For

014

End If

015

Next

016

017	Exit Function

018	errHandle:

019	isValidConst = True

020	End Function

021

022	Private Function isValidRumusPenilaian(ByVal rumus As String) As Boolean

023	Dim script              As Object

024	Dim result              As Long

025

026	Dim strParsing1         As String

027	Dim strParsing2         As String

028	Dim strFinalParsing     As String

029

030	On Error GoTo errHandle

031

032	strParsing1 = Replace(rumus, " ", "") ' menghapus spasi

033

034	strParsing2 = Replace(strParsing1, "<RT>", 0)

035	strParsing2 = Replace(strParsing2, "<RU>", 0)

036	strParsing2 = Replace(strParsing2, "<UTS>", 0)

037	strParsing2 = Replace(strParsing2, "<UAS>", 0)

038

039	strFinalParsing = Replace(strParsing2, "<", "")

040

041	strFinalParsing = Replace(strFinalParsing, ">", "")

042	If Not (Len(strFinalParsing) > 0) Then strFinalParsing = "0"

043

044	'cek klo ada rumus yg tidak sesuai dg konstanta yg sudah didefinisikan, ex : <RT> ditulis <TR>

045	If Not isValidConst(strFinalParsing) Then

046	isValidRumusPenilaian = False

047

048

Else

049	Set script = CreateObject("ScriptControl")

050	script.Language = "VBScript"

051	result = script.Eval(strFinalParsing)

052	Set script = Nothing

053

054	isValidRumusPenilaian = True

055

End If

056

057	Exit Function

058

059	errHandle:

060	isValidRumusPenilaian = False

061	End Function

062

063	Private Function execFormula(ByVal rumus As String) As Single

064	Dim script  As Object

065

066	On Error GoTo errHandle

067

068	Set script = CreateObject("ScriptControl")

069	script.Language = "VBScript"

070	execFormula = script.Eval(rumus)

071	Set script = Nothing

072

073	Exit Function

074	errHandle:

075	execFormula = 0

076	End Function

077

078	Private Function getNilaiAkhirByRumus(ByVal rumus As String, ByVal nilaiRT As Single, ByVal nilaiRU As Single, _

079	ByVal nilaiUTS As Single, ByVal nilaiUAS As Single) As Single

080

081	Dim strParsing1         As String

082	Dim strParsing2         As String

083	Dim strFinalParsing     As String

084

085	On Error GoTo errHandle

086

087	strParsing1 = Replace(rumus, " ", "") ' menghapus spasi

088	strParsing2 = Replace(strParsing1, "<RT>", nilaiRT) ' mengganti const <RT> ke nilai nilaiRT

089	strParsing2 = Replace(strParsing2, "<RU>", nilaiRU)  ' mengganti const <RU> ke nilai nilaiRU

090	strParsing2 = Replace(strParsing2, "<UTS>", nilaiUTS)  ' mengganti const <UTS> ke nilaiUTS

091	strParsing2 = Replace(strParsing2, "<UAS>", nilaiUAS)  ' mengganti const <UAS> ke nilaiUAS

092

093	strFinalParsing = Replace(strParsing2, "<", "")

094	strFinalParsing = Replace(strFinalParsing, ">", "")

095

096	If Not (Len(strFinalParsing) > 0) Then strFinalParsing = "0"

097

098	getNilaiAkhirByRumus = FormatNumber(execFormula(strFinalParsing), 0)

099

100	Exit Function

101

102	errHandle:

103	getNilaiAkhirByRumus = 0

104	End Function

105

106	Private Sub cmdProses_Click()

107	If isValidRumusPenilaian(txtRumus.Text) Then

108	txtNilaiAkhir.Text = getNilaiAkhirByRumus(txtRumus.Text, Val(txtRata2Tugas.Text), Val(txtRata2Ulangan.Text), Val(txtUTS.Text), Val(txtUAS.Text))

109

110

Else

111	MsgBox "Rumus yang Anda inputkan tidak valid", vbExclamation, "Peringatan"

112	txtRumus.SetFocus

113

End If

114

End Sub

Selamat MENCOBA