MEMBUAT FORM INPUT HARI LIBUR DENGAN VISUAL BASIC

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 :

view sourceprint?

01	Dim arrHari(6)  As String

02

03	Private Sub initHari()

04	arrHari(0) = "Minggu"

05	arrHari(1) = "Senin"

06	arrHari(2) = "Selasa"

07	arrHari(3) = "Rabu"

08	arrHari(4) = "Kamis"

09	arrHari(5) = "Jum'at"

10	arrHari(6) = "Sabtu"

11

End Sub

12

13	Private Sub initGrid()

14	With gridKalender

15

.Cols = 7

16

.Rows = 7

17	.FixedRows = 1

18	.FixedCols = 0

19

20	For x = 0 To .Cols - 1

21

.Col = x

22

.Row = 0

23

24	.CellFontBold = True

25	.FixedAlignment(x) = flexAlignCenterCenter

26

27	.ColWidth(x) = 700

28	.ColAlignment(x) = flexAlignCenterCenter

29

Next x

30

31	For x = 0 To .Cols - 1

32	.TextMatrix(0, x) = arrHari(x) 'menampilkan hari

33

Next

34

35	For x = 0 To .Rows - 1

36	.RowHeight(x) = 500

37

Next

38

39	.GridLines = flexGridFlat

40	.GridLinesFixed = flexGridFlat

41

42	.ForeColorFixed = &H0& 'WARNA_HITAM

43	.BackColorSel = &HED9564 'WARNA_BIRU

44

End With

45

End Sub

46

47	Private Sub Form_Load()

48	Call initHari

49	Call initGrid

50

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.

view sourceprint?

001	Dim setMonth    As Date

002

003	Private Function roundOff(ByVal num As Double) As Integer

004	Dim str     As String

005	Dim str2    As String

006	Dim ctr     As Integer

007

008	str = CStr(num)

009	For ctr = 1 To Len(str)

010	If Mid(str, ctr, 1) = "." Then

011	roundOff = CInt(str2)

012	Exit Function

013

Else

014	str2 = str2 & Mid(str, ctr, 1)

015

End If

016

Next

017

018	roundOff = CInt(str2)

019	End Function

020

021	Private Function detrmMonth(ByVal bulan As Integer) As Integer

022	Select Case bulan

023	Case 1 'January

024	If leap = True Then

025	detrmMonth = 6

026

Else

027	detrmMonth = 0

028

End If

029

030	Case 2 'Febuary

031	If leap = True Then

032	detrmMonth = 2

033

Else

034	detrmMonth = 3

035

End If

036

037	Case 3 'March

038	detrmMonth = 3

039

040	Case 4 'April

041	detrmMonth = 6

042

043	Case 5 'May

044	detrmMonth = 1

045

046	Case 6 'June

047	detrmMonth = 4

048

049	Case 7 'July

050	detrmMonth = 6

051

052	Case 8 'August

053	detrmMonth = 2

054

055	Case 9 'September

056	detrmMonth = 5

057

058	Case 10 'October

059	detrmMonth = 0

060

061	Case 11 'November

062	detrmMonth = 3

063

064	Case 12 'December

065	detrmMonth = 5

066	End Select

067	End Function

068

069	Private Function DOTW(ByVal hari As Integer, ByVal bulan As Integer, ByVal tahun As Integer) As String

070	Dim yr      As Double

071	Dim result  As Integer

072

073	yr = tahun / 4

074	result = roundOff(yr) + tahun

075

076	yr = tahun / 100

077	result = result - roundOff(yr)

078

079	yr = tahun / 400

080	result = result + roundOff(yr)

081	result = result + hari

082	result = result + detrmMonth(bulan)

083	result = result - 1

084	result = result Mod 7

085

086	DOTW = getHariByAngka(result)

087	End Function

088

089	Private Function getHariByAngka(ByVal hari As Integer) As String

090	Select Case hari

091	Case 0: getHariByAngka = "Minggu"

092	Case 1: getHariByAngka = "Senin"

093	Case 2: getHariByAngka = "Selasa"

094	Case 3: getHariByAngka = "Rabu"

095	Case 4: getHariByAngka = "Kamis"

096	Case 5: getHariByAngka = "Jum'at"

097	Case 6: getHariByAngka = "Sabtu"

098	End Select

099	End Function

100

101	Private Function getAngkaByHari(ByVal hari As String) As Integer

102	Select Case hari

103	Case "Minggu": getAngkaByHari = 0

104	Case "Senin": getAngkaByHari = 1

105	Case "Selasa": getAngkaByHari = 2

106	Case "Rabu": getAngkaByHari = 3

107	Case "Kamis": getAngkaByHari = 4

108	Case "Jum'at": getAngkaByHari = 5

109	Case "Sabtu": getAngkaByHari = 6

110	End Select

111	End Function

112

113	Private Sub setToDay(ByVal Col As Integer, ByVal Row As Integer)

114	With gridKalender

115	.Col = Col

116	.Row = Row

117

118	.CellPictureAlignment = flexAlignCenterTop

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

120

121	.CellFontBold = True

122

End With

123

End Sub

124

125	Private Function getRowByCell(ByVal cell As Integer) As Integer

126	Select Case cell

127	Case 1 To 7: getRowByCell = 1

128	Case 8 To 14: getRowByCell = 2

129	Case 15 To 21: getRowByCell = 3

130	Case 22 To 28: getRowByCell = 4

131	Case 29 To 35: getRowByCell = 5

132	Case 36 To 42: getRowByCell = 6

133	Case Else: getRowByCell = 1

134	End Select

135	End Function

136

137	Private Function getColByCell(ByVal cell As Integer) As Integer

138	Select Case cell

139	Case 1, 8, 15, 22, 29, 36

140	getColByCell = 0

141

142	Case 2, 9, 16, 23, 30, 37

143	getColByCell = 1

144

145	Case 3, 10, 17, 24, 31, 38

146	getColByCell = 2

147

148	Case 4, 11, 18, 25, 32, 39

149	getColByCell = 3

150

151	Case 5, 12, 19, 26, 33, 40

152	getColByCell = 4

153

154	Case 6, 13, 20, 27, 34, 41

155	getColByCell = 5

156

157	Case 7, 14, 21, 28, 35, 42

158	getColByCell = 6

159	End Select

160	End Function

161

162	Private Sub setHariLibur(ByVal hari As Integer)

163	Dim x   As Long

164	Dim y   As Long

165

166	With gridKalender

167	For x = 0 To .Cols - 1

168	For y = 1 To .Rows - 1

169	If Val(.TextMatrix(y, x)) = hari Then

170

.Col = x

171

.Row = y

172

173	If Day(Now) = hari Then 'hari libur pas hari ini

174	.CellPictureAlignment = flexAlignCenterTop

175

Else

176	.CellPictureAlignment = flexAlignLeftTop

177

End If

178

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

180

181	.CellFontBold = True

182	.CellForeColor = vbRed

183

End If

184

Next y

185

Next x

186

End With

187

End Sub

188

189	Private Sub makeCalendar(ByVal jumlahHari As Integer, ByVal bulan As Integer, ByVal tahun As Integer)

190	Dim hari        As Integer

191	Dim y           As Integer

192	Dim Index       As Integer

193	Dim cell        As Integer

194

195	Dim baris       As Integer

196	Dim kolom       As Integer

197	Dim ret         As Integer

198

199	Dim str         As String

200	Dim ketLibur    As String

201

202

cell = 0

203	lstKetHariLibur.Clear

204	For hari = 1 To jumlahHari

205	str = DOTW(hari, bulan, tahun)

206	y = getAngkaByHari(str)

207

208	For Index = cell To 41

209	baris = getRowByCell(cell)

210	kolom = getColByCell(cell)

211

212	If kolom = y Then

213	Index = 41

214	gridKalender.TextMatrix(baris, kolom) = hari

215

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

217

218	If kolom = 0 Then

219	Call setHariLibur(hari)

220

Else

221	strSql = "SELECT COUNT(*) FROM hari_libur " & _

222	"WHERE DAY(tanggal) = " & hari & " AND " & _

223	"MONTH(tanggal) = " & bulan & " AND YEAR(tanggal) = " & tahun & ""

224	ret = CInt(dbGetValue(strSql, 0))

225	If ret > 0 Then

226	Call setHariLibur(hari)

227

228	strSql = "SELECT keterangan FROM hari_libur " & _

229	"WHERE DAY(tanggal) = " & hari & " AND " & _

230	"MONTH(tanggal) = " & bulan & " AND YEAR(tanggal) = " & tahun & ""

231	ketLibur = CStr(dbGetValue(strSql, ""))

232	lstKetHariLibur.AddItem hari & " : " & ketLibur

233

End If

234

End If

235

236

Else

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

238

End If

239

240	cell = cell + 1

241

Next

242

Next

243

End Sub

244

245	Private Function getJumlahHariByBulan(ByVal bulan As Integer, ByVal tahun As Long) As Integer

246	getJumlahHariByBulan = Day(DateSerial(tahun, bulan + 1, 0))

247	End Function

248

249	Private Sub resetKalender()

250	Dim x   As Integer

251	Dim y   As Integer

252

253	With gridKalender

254	For x = 0 To .Cols - 1

255	For y = 1 To .Rows - 1

256	.TextMatrix(y, x) = ""

257

258

.Col = x

259

.Row = y

260	Set .CellPicture = Nothing

261

262	.CellFontBold = False

263	.CellForeColor = &H0& 'WARNA_HITAM

264	.CellBackColor = &H80000005 'WARNA_PUTIH

265

Next

266

Next

267

End With

268

End Sub

269

270	Private Sub genKalender()

271	Dim jumlahHariByBulan   As Integer

272	Dim num                 As Integer

273

274	num = Year(setMonth) Mod 4

275	If num = 0 Then

276	leap = True

277

Else

278	leap = False

279

End If

280

281	Call resetKalender

282

283	jumlahHariByBulan = getJumlahHariByBulan(Month(setMonth), Year(setMonth))

284	Call makeCalendar(jumlahHariByBulan, Month(setMonth), Year(setMonth))

285

End Sub

286

287	Private Sub Form_Load()

288	Call initHari

289	Call initGrid

290

291	setMonth = Date

292	Call genKalender

293

End Sub

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

Prosedur berikutnya adalah untuk melakukan navigasi/perpindahan antar bulan

view sourceprint?

01	Dim setMonth    As Date

02

03	Private Sub refreshBulan(ByVal bulan As Date)

04	txtBulan.Text = getBulanIndonesia(Month(bulan)) & " " & Year(bulan)

05

End Sub

06

07	Private Sub cmdNext_Click()

08	setMonth = setNewMonth(True)

09	Call refreshBulan(setMonth)

10	Call genKalender

11

End Sub

12

13	Private Sub cmdPrev_Click()

14	setMonth = setNewMonth(False)

15	Call refreshBulan(setMonth)

16	Call genKalender

17

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

view sourceprint?

01	Private Sub mnuHariLibur_Click()

02	Dim inputKetLibur   As String

03	Dim tanggal         As String

04	Dim ret             As Integer

05

06	inputKetLibur = InputBox("Keterangan Hari Libur", "Hari Libur")

07	If Len(inputKetLibur) > 0 Then

08	tanggal = Year(setMonth) & "/" & Month(setMonth) & "/" & Val(gridKalender.TextMatrix(gridKalender.Row, gridKalender.Col))

09

10	strSql = "SELECT COUNT(*) FROM hari_libur " & _

11	"WHERE tanggal = #" & tanggal & "#"

12	ret = CInt(dbGetValue(strSql, 0))

13	If ret = 0 Then

14	strSql = "INSERT INTO hari_libur(tanggal, keterangan) VALUES (#" & _

15	tanggal & "#,'" & inputKetLibur & "')"

16	conn.Execute strSql

17

End If

18

19	Call genKalender

20	cmdNext.SetFocus

21

End If

22

End Sub

23

24	Private Sub mnuHapusHariLibur_Click()

25	Dim tanggal As String

26

27	If MsgBox("Apakan Anda ingin menghapus hari libur ???", vbExclamation + vbYesNo, "Konfirmasi") = vbYes Then

28	If Val(gridKalender.TextMatrix(gridKalender.Row, gridKalender.Col)) > 0 Then

29	tanggal = Year(setMonth) & "/" & Month(setMonth) & "/" & Val(gridKalender.TextMatrix(gridKalender.Row, gridKalender.Col))

30

31	strSql = "DELETE FROM hari_libur " & _

32	"WHERE tanggal = #" & tanggal & "#"

33	conn.Execute strSql

34

35	Call genKalender

36	cmdNext.SetFocus

37

End If

38

End If

39

End Sub

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

view sourceprint?

01	Private Sub gridKalender_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

02	If Button = vbRightButton Then

03	With gridKalender

04	If .MouseCol = 0 Then 'kolom hari minggu, semua menu dinonaktifkan

05	mnuHariLibur.Enabled = False

06	mnuHapusHariLibur.Enabled = False

07

08

Else

09	If Val(.TextMatrix(.MouseRow, .MouseCol)) > 0 Then

10	.Row = .MouseRow

11	.Col = .MouseCol

12

13	If .CellForeColor > 0 Then 'font warna merah, berarti hari libur

14	mnuHariLibur.Enabled = False 'menu hari libur dinonaktifkan

15	mnuHapusHariLibur.Enabled = True

16

17

Else

18	mnuHariLibur.Enabled = True

19	mnuHapusHariLibur.Enabled = False

20

End If

21

22

Else

23	mnuHariLibur.Enabled = True

24	mnuHapusHariLibur.Enabled = False

25

End If

26

End If

27

End With

28

29	PopupMenu mnuPopUp

30

End If

31

End Sub

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

view sourceprint?

01	Private Function getFirstSunday() As Integer

02	Dim firstDay As String

03

04	firstDay = Year(Now) & "/" & Month(Now) & "/1"

05	firstDay = Weekday(firstDay)

06	If Val(firstDay) > 1 Then

07	getFirstSunday = 9 - Val(firstDay)

08

Else

09	getFirstSunday = Val(firstDay)

10

End If

11	End Function

12

13	Private Sub addHariMinggu()

14	Dim i           As Integer

15	Dim firstDay    As Integer

16	Dim ret         As Integer

17

18	Dim tgl         As String

19

20	firstDay = getFirstSunday 'ambil tgl hari minggu pertama

21	For i = firstDay To getJumlahHariByBulan(Month(Now), Year(Now)) Step 7

22	tgl = Year(Now) & "/" & Month(Now) & "/" & i

23

24	strSql = "SELECT COUNT(*) FROM hari_libur " & _

25	"WHERE tanggal = #" & tgl & "# AND keterangan = 'Minggu'"

26	ret = CInt(dbGetValue(strSql, 0))

27	If ret = 0 Then

28	strSql = "INSERT INTO hari_libur(tanggal, keterangan) VALUES (#" & tgl & "#, 'Minggu')"

29	conn.Execute strSql

30

End If

31

Next

32

End Sub

33

34	Private Sub openDb()

35	Set conn = New ADODB.Connection

36	conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\sampleDB.mdb"

37

conn.Open

38

End Sub

39

40	Public Sub Main()

41	Call openDb

42

43	'prosedur otomatis untuk mengisikan tgl libur khusus hari minggu

44	Call addHariMinggu

45	frmHariLibur.Show

46

End Sub

Selamat mencoba....
salam T.I.....