Sabtu, 12 Januari 2013

Membuat rumus penilaian dinamis


Membuat rumus penilaian dinamis

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.
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
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.
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
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 :
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 :)

Tidak ada komentar:

Poskan Komentar