Coding4ever’s Blog

Just coding… coding… and coding… because coding should be fun :)

Membuat Form Input Hari Libur

| Comments

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 :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

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.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39

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 :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

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

Posted by Admin visual basic

Tentang Penulis

Software developer yang fokus mengembangkan aplikasi di atas platform .NET (Desktop, ASP.NET MVC, Web Service, Microservice) dan Android. Senang mempelajari teknologi baru terutama di bidang OOP, Design Pattern, ORM, Database, Continuous Integration & Deployment dan arsitektur Microservice.
Selain mengajar, saat ini penulis juga bekerja sebagai staf IT di salah satu PTS di Yogyakarta sebagai senior software developer. Di waktu luang insya Alloh akan terus berbagi pengalaman di blog ini :)

« Update SMS Tausiyah Manager Membuat rumus penilaian dinamis »

Comments