Home > Visual Basic > Membuat form input hari libur

Membuat form input hari libur

August 26, 2010

Salah satu fitur menarik yang dimiliki aplikasi Smart Library School yaitu form untuk input hari libur, dengan adanya fitur ini memudahkan operator untuk mencatat data hari libur.

Nah pada postingan kali ini saya akan share source code untuk membuat form tersebut, adapun komponen yang digunakan cukup :

  1. MSFlexGrid untuk menampilkan tanggal
  2. CommandButton untuk navigasi/perpindahan bulan
  3. TextBox untuk untuk menampilkan bulan aktif
  4. ListBox untuk menampilkan keterangan hari libur

Oke untuk pertama kita akan memformat tampilkan MsFlexGrid, adapun sourcenya seperti berikut :

Dim arrHari(6)  As String

Private Sub initHari()
    arrHari(0) = "Minggu"
    arrHari(1) = "Senin"
    arrHari(2) = "Selasa"
    arrHari(3) = "Rabu"
    arrHari(4) = "Kamis"
    arrHari(5) = "Jum'at"
    arrHari(6) = "Sabtu"
End Sub

Private Sub initGrid()
    With gridKalender
        .Cols = 7
        .Rows = 7
        .FixedRows = 1
        .FixedCols = 0

        For x = 0 To .Cols - 1
            .Col = x
            .Row = 0

            .CellFontBold = True
            .FixedAlignment(x) = flexAlignCenterCenter

            .ColWidth(x) = 700
            .ColAlignment(x) = flexAlignCenterCenter
        Next x

        For x = 0 To .Cols - 1
            .TextMatrix(0, x) = arrHari(x) 'menampilkan hari
        Next

        For x = 0 To .Rows - 1
            .RowHeight(x) = 500
        Next

        .GridLines = flexGridFlat
        .GridLinesFixed = flexGridFlat

        .ForeColorFixed = &H0& 'WARNA_HITAM
        .BackColorSel = &HED9564 'WARNA_BIRU
    End With
End Sub

Private Sub Form_Load()
    Call initHari
    Call initGrid
End Sub

jika source diatas dijalankan akan menghasilkan tampilan seperti berikut :

Selanjutnya kita akan membuat prosedur untuk mengenerate data kalender bulan yang aktif, menampilkan hari libur minggu dan hari libur lainnya.

Dim setMonth    As Date

Private Function roundOff(ByVal num As Double) As Integer
    Dim str     As String
    Dim str2    As String
    Dim ctr     As Integer

    str = CStr(num)
    For ctr = 1 To Len(str)
        If Mid(str, ctr, 1) = "." Then
            roundOff = CInt(str2)
            Exit Function
        Else
            str2 = str2 & Mid(str, ctr, 1)
        End If
    Next

    roundOff = CInt(str2)
End Function

Private Function detrmMonth(ByVal bulan As Integer) As Integer
    Select Case bulan
        Case 1 'January
            If leap = True Then
                detrmMonth = 6
            Else
                detrmMonth = 0
            End If

        Case 2 'Febuary
            If leap = True Then
                detrmMonth = 2
            Else
                detrmMonth = 3
            End If

        Case 3 'March
            detrmMonth = 3

        Case 4 'April
            detrmMonth = 6

        Case 5 'May
            detrmMonth = 1

        Case 6 'June
            detrmMonth = 4

        Case 7 'July
            detrmMonth = 6

        Case 8 'August
            detrmMonth = 2

        Case 9 'September
            detrmMonth = 5

        Case 10 'October
            detrmMonth = 0

        Case 11 'November
            detrmMonth = 3

        Case 12 'December
            detrmMonth = 5
    End Select
End Function

Private Function DOTW(ByVal hari As Integer, ByVal bulan As Integer, ByVal tahun As Integer) As String
    Dim yr      As Double
    Dim result  As Integer

    yr = tahun / 4
    result = roundOff(yr) + tahun

    yr = tahun / 100
    result = result - roundOff(yr)

    yr = tahun / 400
    result = result + roundOff(yr)
    result = result + hari
    result = result + detrmMonth(bulan)
    result = result - 1
    result = result Mod 7

    DOTW = getHariByAngka(result)
End Function

Private Function getHariByAngka(ByVal hari As Integer) As String
    Select Case hari
        Case 0: getHariByAngka = "Minggu"
        Case 1: getHariByAngka = "Senin"
        Case 2: getHariByAngka = "Selasa"
        Case 3: getHariByAngka = "Rabu"
        Case 4: getHariByAngka = "Kamis"
        Case 5: getHariByAngka = "Jum'at"
        Case 6: getHariByAngka = "Sabtu"
    End Select
End Function

Private Function getAngkaByHari(ByVal hari As String) As Integer
    Select Case hari
        Case "Minggu": getAngkaByHari = 0
        Case "Senin": getAngkaByHari = 1
        Case "Selasa": getAngkaByHari = 2
        Case "Rabu": getAngkaByHari = 3
        Case "Kamis": getAngkaByHari = 4
        Case "Jum'at": getAngkaByHari = 5
        Case "Sabtu": getAngkaByHari = 6
    End Select
End Function

Private Sub setToDay(ByVal Col As Integer, ByVal Row As Integer)
    With gridKalender
        .Col = Col
        .Row = Row

        .CellPictureAlignment = flexAlignCenterTop
        Set .CellPicture = LoadPicture(App.Path & "\today.bmp")

        .CellFontBold = True
    End With
End Sub

Private Function getRowByCell(ByVal cell As Integer) As Integer
    Select Case cell
        Case 1 To 7: getRowByCell = 1
        Case 8 To 14: getRowByCell = 2
        Case 15 To 21: getRowByCell = 3
        Case 22 To 28: getRowByCell = 4
        Case 29 To 35: getRowByCell = 5
        Case 36 To 42: getRowByCell = 6
        Case Else: getRowByCell = 1
    End Select
End Function

Private Function getColByCell(ByVal cell As Integer) As Integer
    Select Case cell
        Case 1, 8, 15, 22, 29, 36
            getColByCell = 0

        Case 2, 9, 16, 23, 30, 37
            getColByCell = 1

        Case 3, 10, 17, 24, 31, 38
            getColByCell = 2

        Case 4, 11, 18, 25, 32, 39
            getColByCell = 3

        Case 5, 12, 19, 26, 33, 40
            getColByCell = 4

        Case 6, 13, 20, 27, 34, 41
            getColByCell = 5

        Case 7, 14, 21, 28, 35, 42
            getColByCell = 6
    End Select
End Function

Private Sub setHariLibur(ByVal hari As Integer)
    Dim x   As Long
    Dim y   As Long

    With gridKalender
        For x = 0 To .Cols - 1
            For y = 1 To .Rows - 1
                If Val(.TextMatrix(y, x)) = hari Then
                    .Col = x
                    .Row = y

                    If Day(Now) = hari Then 'hari libur pas hari ini
                        .CellPictureAlignment = flexAlignCenterTop
                    Else
                        .CellPictureAlignment = flexAlignLeftTop
                    End If

                    Set .CellPicture = LoadPicture(App.Path & "\smile.bmp")

                    .CellFontBold = True
                    .CellForeColor = vbRed
                End If
            Next y
        Next x
    End With
End Sub

Private Sub makeCalendar(ByVal jumlahHari As Integer, ByVal bulan As Integer, ByVal tahun As Integer)
    Dim hari        As Integer
    Dim y           As Integer
    Dim Index       As Integer
    Dim cell        As Integer

    Dim baris       As Integer
    Dim kolom       As Integer
    Dim ret         As Integer

    Dim str         As String
    Dim ketLibur    As String

    cell = 0
    lstKetHariLibur.Clear
    For hari = 1 To jumlahHari
        str = DOTW(hari, bulan, tahun)
        y = getAngkaByHari(str)

        For Index = cell To 41
            baris = getRowByCell(cell)
            kolom = getColByCell(cell)

            If kolom = y Then
                Index = 41
                gridKalender.TextMatrix(baris, kolom) = hari

                If Day(Now) = hari And Month(Now) = bulan Then Call setToDay(kolom, baris) 'setToDay -> prosedur untuk menampilkan icon today

                If kolom = 0 Then
                    Call setHariLibur(hari)
                Else
                    strSql = "SELECT COUNT(*) FROM hari_libur " & _
                             "WHERE DAY(tanggal) = " & hari & " AND " & _
                             "MONTH(tanggal) = " & bulan & " AND YEAR(tanggal) = " & tahun & ""
                    ret = CInt(dbGetValue(strSql, 0))
                    If ret > 0 Then
                        Call setHariLibur(hari)

                        strSql = "SELECT keterangan FROM hari_libur " & _
                                 "WHERE DAY(tanggal) = " & hari & " AND " & _
                                 "MONTH(tanggal) = " & bulan & " AND YEAR(tanggal) = " & tahun & ""
                        ketLibur = CStr(dbGetValue(strSql, ""))
                        lstKetHariLibur.AddItem hari & " : " & ketLibur
                    End If
                End If

            Else
                If baris > 0 And kolom > 0 Then gridKalender.TextMatrix(baris, kolom) = ""
            End If

            cell = cell + 1
        Next
    Next
End Sub

Private Function getJumlahHariByBulan(ByVal bulan As Integer, ByVal tahun As Long) As Integer
    getJumlahHariByBulan = Day(DateSerial(tahun, bulan + 1, 0))
End Function

Private Sub resetKalender()
    Dim x   As Integer
    Dim y   As Integer

    With gridKalender
        For x = 0 To .Cols - 1
            For y = 1 To .Rows - 1
                .TextMatrix(y, x) = ""

                .Col = x
                .Row = y
                Set .CellPicture = Nothing

                .CellFontBold = False
                .CellForeColor = &H0& 'WARNA_HITAM
                .CellBackColor = &H80000005 'WARNA_PUTIH
            Next
        Next
    End With
End Sub

Private Sub genKalender()
    Dim jumlahHariByBulan   As Integer
    Dim num                 As Integer

    num = Year(setMonth) Mod 4
    If num = 0 Then
        leap = True
    Else
        leap = False
    End If

    Call resetKalender

    jumlahHariByBulan = getJumlahHariByBulan(Month(setMonth), Year(setMonth))
    Call makeCalendar(jumlahHariByBulan, Month(setMonth), Year(setMonth))
End Sub

Private Sub Form_Load()
    Call initHari
    Call initGrid

    setMonth = Date
    Call genKalender
End Sub

Hari libur akan disimpan didatabase Ms Access dengan struktur seperti berikut :

Prosedur berikutnya adalah untuk melakukan navigasi/perpindahan antar bulan

Dim setMonth    As Date

Private Sub refreshBulan(ByVal bulan As Date)
    txtBulan.Text = getBulanIndonesia(Month(bulan)) & " " & Year(bulan)
End Sub

Private Sub cmdNext_Click()
    setMonth = setNewMonth(True)
    Call refreshBulan(setMonth)
    Call genKalender
End Sub

Private Sub cmdPrev_Click()
    setMonth = setNewMonth(False)
    Call refreshBulan(setMonth)
    Call genKalender
End Sub

Untuk menambah dan menghapus hari libur kita akan memanfaat menu biasa dengan mode Pop Up dan untuk menghemat form untuk inputannya cukup menggunakan fungsi InputBox

Private Sub mnuHariLibur_Click()
    Dim inputKetLibur   As String
    Dim tanggal         As String
    Dim ret             As Integer

    inputKetLibur = InputBox("Keterangan Hari Libur", "Hari Libur")
    If Len(inputKetLibur) > 0 Then
        tanggal = Year(setMonth) & "/" & Month(setMonth) & "/" & Val(gridKalender.TextMatrix(gridKalender.Row, gridKalender.Col))

        strSql = "SELECT COUNT(*) FROM hari_libur " & _
                 "WHERE tanggal = #" & tanggal & "#"
        ret = CInt(dbGetValue(strSql, 0))
        If ret = 0 Then
            strSql = "INSERT INTO hari_libur(tanggal, keterangan) VALUES (#" & _
                     tanggal & "#,'" & inputKetLibur & "')"
            conn.Execute strSql
        End If

        Call genKalender
        cmdNext.SetFocus
    End If
End Sub

Private Sub mnuHapusHariLibur_Click()
    Dim tanggal As String

    If MsgBox("Apakan Anda ingin menghapus hari libur ???", vbExclamation + vbYesNo, "Konfirmasi") = vbYes Then
        If Val(gridKalender.TextMatrix(gridKalender.Row, gridKalender.Col)) > 0 Then
            tanggal = Year(setMonth) & "/" & Month(setMonth) & "/" & Val(gridKalender.TextMatrix(gridKalender.Row, gridKalender.Col))

            strSql = "DELETE FROM hari_libur " & _
                     "WHERE tanggal = #" & tanggal & "#"
            conn.Execute strSql

            Call genKalender
            cmdNext.SetFocus
        End If
    End If
End Sub

adapun kode untuk menampilkan popup menu pada saat mengklik kanan kalender adalah seperti berikut :

Private Sub gridKalender_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = vbRightButton Then
        With gridKalender
            If .MouseCol = 0 Then 'kolom hari minggu, semua menu dinonaktifkan
                mnuHariLibur.Enabled = False
                mnuHapusHariLibur.Enabled = False

            Else
                If Val(.TextMatrix(.MouseRow, .MouseCol)) > 0 Then
                    .Row = .MouseRow
                    .Col = .MouseCol

                    If .CellForeColor > 0 Then 'font warna merah, berarti hari libur
                        mnuHariLibur.Enabled = False 'menu hari libur dinonaktifkan
                        mnuHapusHariLibur.Enabled = True

                    Else
                        mnuHariLibur.Enabled = True
                        mnuHapusHariLibur.Enabled = False
                    End If

                Else
                    mnuHariLibur.Enabled = True
                    mnuHapusHariLibur.Enabled = False
                End If
            End If
        End With

        PopupMenu mnuPopUp
    End If
End Sub

sebagai penutup kita akan menambahkan prosedur otomatis untuk menyimpan hari libur khusus minggu yang akan dijalankan pada method Main

Private Function getFirstSunday() As Integer
    Dim firstDay As String

    firstDay = Year(Now) & "/" & Month(Now) & "/1"
    firstDay = Weekday(firstDay)
    If Val(firstDay) > 1 Then
        getFirstSunday = 9 - Val(firstDay)
    Else
        getFirstSunday = Val(firstDay)
    End If
End Function

Private Sub addHariMinggu()
    Dim i           As Integer
    Dim firstDay    As Integer
    Dim ret         As Integer

    Dim tgl         As String

    firstDay = getFirstSunday 'ambil tgl hari minggu pertama
    For i = firstDay To getJumlahHariByBulan(Month(Now), Year(Now)) Step 7
        tgl = Year(Now) & "/" & Month(Now) & "/" & i

        strSql = "SELECT COUNT(*) FROM hari_libur " & _
                 "WHERE tanggal = #" & tgl & "# AND keterangan = 'Minggu'"
        ret = CInt(dbGetValue(strSql, 0))
        If ret = 0 Then
            strSql = "INSERT INTO hari_libur(tanggal, keterangan) VALUES (#" & tgl & "#, 'Minggu')"
            conn.Execute strSql
        End If
    Next
End Sub

Private Sub openDb()
    Set conn = New ADODB.Connection
    conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\sampleDB.mdb"
    conn.Open
End Sub

Public Sub Main()
    Call openDb

    'prosedur otomatis untuk mengisikan tgl libur khusus hari minggu
    Call addHariMinggu
    frmHariLibur.Show
End Sub

Selamat MENCOBA🙂

  1. August 31, 2010 at 7:11 am

    keren om…. Klo langsung dr form dtmbhkan gmbr dgn format PNG gmna biar vb na support…thanks

    • September 1, 2010 at 1:43 am

      Sayangnya kebanyakan komponen VB 6 yg digunakan untuk menampilkan gambar belum support format PNG om
      CMIIW

  2. September 1, 2010 at 2:26 am

    apa tdk ad cra tip ato trik…patch… Biar jd support…🙂 klo ad share ya om…🙂

  3. September 1, 2010 at 6:04 am

    ok…thaks Ntar dcari🙂

  4. Alan Shufy
    April 25, 2011 at 4:36 pm

    Salam Kenal !
    Aku lagi belajar VB nech, walau gak school kayaknya belajar disini cukup Dech buat pemula.
    saya dah coba Bang, tapi selau error di bagian …….(dbGetValue(……jdi ngak bisa menampilkan hari libur dari database, juga bagian tombol perpindahan bulan, kayaknya sub getBulanIndonesia-nya ngak ada!!!mohon pencerahannya bang!

    • April 26, 2011 at 2:10 am

      Wah salut deh bwt si om jadi benar nih enggak school (sekolah) jangan2x belum bisa baca😀.

      Gini om biasanya sy memang tidak menampilkan semua source code pada artikel, jadi om bisa download source code lengkap artikel diatas disini.

  5. Alan Shufy
    April 26, 2011 at 2:01 pm

    klo nyampe SMU sech Alhamdulillah, tpi yakin ilmu itu ngak semuanya di dapat dari institusi formal ajha, neh contohnya … bisa share ilmu dengan ketulusan….
    makasih banget source codenya, izin sedot yah !!!! semoga ilmunya semakin berlebih…..

    • April 27, 2011 at 1:35 am

      Amin🙂

  6. Alan Shufy
    April 26, 2011 at 2:13 pm

    upss lupa kmarin aku coba download aplikasi smart library school, pada form child yg pake MDItab itu aku coba pake buat percobaan, nah tapi dibagian atasnya ada bagian yang transparan, jdi kelihatan background MDIform-nya, sedangkan di Aplikasi Smart Library School kayaknya enggak dech, mhon bantuannya lgi ya Bang!!!
    Makasih banyak atas keramahannya….🙂

    • April 27, 2011 at 1:37 am

      Mendingan kasih screenshotnya aja om biar jelas.

  7. Alan Shufy
    May 7, 2011 at 2:48 am

    udah Bang ketemu masalahnya, aku lupa pada form load aku masukan me.top 700 jadi ada bagian kosong di atas, mhon maaf lma ngak browsing lgi ada kerjaan. terima kasih… 🙂

    • May 7, 2011 at 4:21 am

      Oke om

  8. Alan Shufy
    May 7, 2011 at 5:30 pm

    tambah lagi ni Bang, aku coba ganti settingan Regional komputernyanya ke Indonesia, Alhasil Hari pada gridkalendernya berubah satu hari ke depan, contoh seharusnya hari senin jadi hari selasa. barangkali ada solusinya nih🙂 ! duh jdi ngerepotin lagi nih !!!

    • May 9, 2011 at 2:57 am

      Kebetulan lagi syibuk nih om😀, jadi belum sempat bantu ngoprek

  9. Alan Shufy
    May 14, 2011 at 12:48 pm

    Ok, ngak apa2. terima kasih atas keramahannya…🙂

  10. Alan Shufy
    May 14, 2011 at 12:50 pm

    Ok, ngak apa2. terima kasih atas keramahannya…🙂, saya dah coba revisi beberapa bagian buat bikin kalender plus penanggalan Sunda. Sangat membantu sekali kang….Sekali lagi Hatur Nuhun Pisan!!!

    • May 15, 2011 at 7:00 am

      Oke om sama2x

  11. pugo
    February 1, 2012 at 9:33 pm

    thans ya gan, kbetulan aq krang lagi blajar vb

    • February 2, 2012 at 7:44 am

      Oke om sering2x aja mampir kesini🙂

  12. Abe
    February 27, 2012 at 9:00 am

    salam kenal bos..!
    Mau nanya nih, Kemarin sy coba ganti formnya dengan mencopy semua yang ada pada formInputHariLibur kok error pada bagian conn.Execute strSql….?
    Mohon Pencerahanya Bos….
    Thank’s Before……

  13. February 27, 2012 at 10:46 am

    Mungkin library Microsoft ActiveX Data Object 2.x belum ditambahkan ke projectnya om

  14. Abe
    February 27, 2012 at 1:15 pm

    Untuk projectnya sy masih pakai yg om punya cuma form didalamnya yg sy ubah.

  15. Abe
    February 27, 2012 at 7:19 pm

    Dah bisa om, Trnyata Public sub main yg blum sy ganti….
    Sory nanya lagi nih om, Maklum masih neubi. Bisa ngga form keterangan hari liburnya dibuatkan tersendiri, trus klo bisa gimana caranya….?
    Thank’s…..

    • February 28, 2012 at 6:05 am

      Emg input keterangan yg skrg kekurangannya apa om ?

  16. Abe
    February 28, 2012 at 9:00 am

    Ngga’ ada sih om, cuman pingin Ngemodif aja tampilanya itung2 buat belajarlah….

    • February 28, 2012 at 5:10 pm

      Ya udah tinggal tambah form aja toh trus tinggal dipanggil dimenu pop upnya

  17. Ando
    September 28, 2012 at 12:38 pm

    om admin, klo di .net bijimana ya…
    flexgridnya ga ada

  1. April 16, 2014 at 9:13 am
Comments are closed.
%d bloggers like this: