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.

Private Function validAngka(KeyAscii As Integer) As Integer
    Dim strValid As String

    On Error GoTo errHandle

    strValid = "0123456789."

    If InStr(strValid, Chr(KeyAscii)) = 0 And Not (KeyAscii = vbKeyBack) Then
        validAngka = 0
    Else
        validAngka = KeyAscii
    End If

    Exit Function
errHandle:
    validAngka = 0
End Function

kemudian tinggal panggil dimasing-masing event keypress inputan nilai

Private Sub txtRata2Tugas_KeyPress(KeyAscii As Integer)
    KeyAscii = validAngka(KeyAscii)
End Sub

Private Sub txtRata2Ulangan_KeyPress(KeyAscii As Integer)
    KeyAscii = validAngka(KeyAscii)
End Sub

Private Sub txtUAS_KeyPress(KeyAscii As Integer)
    KeyAscii = validAngka(KeyAscii)
End Sub

Private Sub txtUTS_KeyPress(KeyAscii As Integer)
    KeyAscii = validAngka(KeyAscii)
End Sub

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

Private Function validKarakterRumus(KeyAscii As Integer) As Integer
    Dim strValid As String

    On Error GoTo errHandle

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

    If InStr(strValid, Chr(KeyAscii)) = 0 And Not (KeyAscii = vbKeyBack) Then
        validKarakterRumus = 0
    Else
        validKarakterRumus = KeyAscii
    End If

    Exit Function
errHandle:
    validKarakterRumus = 0
End Function

sama seperti sebelumnya tinggal panggil di event keypress inputan rumus

Private Sub txtRumus_KeyPress(KeyAscii As Integer)
    KeyAscii = Asc(UCase(Chr(KeyAscii))) 'otomatis huruf besar
    KeyAscii = validKarakterRumus(KeyAscii)
End Sub

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

Private Function isValidConst(ByVal value As String) As Boolean
    Dim i           As Integer
    Dim strNotValid As String

    On Error GoTo errHandle

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

    isValidConst = True
    For i = 1 To Len(value)
        If InStr(1, strNotValid, Mid(value, i, 1)) > 0 Then
            isValidConst = False
            Exit For
        End If
    Next

    Exit Function
errHandle:
    isValidConst = True
End Function

Private Function isValidRumusPenilaian(ByVal rumus As String) As Boolean
    Dim script              As Object
    Dim result              As Long

    Dim strParsing1         As String
    Dim strParsing2         As String
    Dim strFinalParsing     As String

    On Error GoTo errHandle

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

    strParsing2 = Replace(strParsing1, "<RT>", 0)
    strParsing2 = Replace(strParsing2, "<RU>", 0)
    strParsing2 = Replace(strParsing2, "<UTS>", 0)
    strParsing2 = Replace(strParsing2, "<UAS>", 0)

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

    strFinalParsing = Replace(strFinalParsing, ">", "")
    If Not (Len(strFinalParsing) > 0) Then strFinalParsing = "0"

    'cek klo ada rumus yg tidak sesuai dg konstanta yg sudah didefinisikan, ex : <RT> ditulis <TR>
    If Not isValidConst(strFinalParsing) Then
        isValidRumusPenilaian = False

    Else
        Set script = CreateObject("ScriptControl")
        script.Language = "VBScript"
        result = script.Eval(strFinalParsing)
        Set script = Nothing

        isValidRumusPenilaian = True
    End If

    Exit Function

errHandle:
    isValidRumusPenilaian = False
End Function

Private Function execFormula(ByVal rumus As String) As Single
    Dim script  As Object

    On Error GoTo errHandle

    Set script = CreateObject("ScriptControl")
    script.Language = "VBScript"
    execFormula = script.Eval(rumus)
    Set script = Nothing

    Exit Function
errHandle:
    execFormula = 0
End Function

Private Function getNilaiAkhirByRumus(ByVal rumus As String, ByVal nilaiRT As Single, ByVal nilaiRU As Single, _
                                      ByVal nilaiUTS As Single, ByVal nilaiUAS As Single) As Single

    Dim strParsing1         As String
    Dim strParsing2         As String
    Dim strFinalParsing     As String

    On Error GoTo errHandle

    strParsing1 = Replace(rumus, " ", "") ' menghapus spasi
    strParsing2 = Replace(strParsing1, "<RT>", nilaiRT) ' mengganti const <RT> ke nilai nilaiRT
    strParsing2 = Replace(strParsing2, "<RU>", nilaiRU)  ' mengganti const <RU> ke nilai nilaiRU
    strParsing2 = Replace(strParsing2, "<UTS>", nilaiUTS)  ' mengganti const <UTS> ke nilaiUTS
    strParsing2 = Replace(strParsing2, "<UAS>", nilaiUAS)  ' mengganti const <UAS> ke nilaiUAS

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

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

    getNilaiAkhirByRumus = FormatNumber(execFormula(strFinalParsing), 0)

    Exit Function

errHandle:
    getNilaiAkhirByRumus = 0
End Function

Private Sub cmdProses_Click()
    If isValidRumusPenilaian(txtRumus.Text) Then
        txtNilaiAkhir.Text = getNilaiAkhirByRumus(txtRumus.Text, Val(txtRata2Tugas.Text), Val(txtRata2Ulangan.Text), Val(txtUTS.Text), Val(txtUAS.Text))

    Else
        MsgBox "Rumus yang Anda inputkan tidak valid", vbExclamation, "Peringatan"
        txtRumus.SetFocus
    End If
End Sub

Selamat MENCOBA