Membuat “Splash Screen” pada Excel dengan VBA

Bagaimana membuat “Splash Screen” sebagai intro  ketika file excel kita buka (klik).  Berikut ini script yang saya peroleh dari buku excel 2013 power programming with VBA – John WalkenBach.

splahScreen

Script pada UserForm

Option Explicit

Const GWL_STYLE = -16
Const WS_CAPTION = &HC00000
Private Declare PtrSafe Function GetWindowLong Lib “user32” Alias “GetWindowLongA” (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib “user32” Alias “SetWindowLongA” (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib “user32” (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function FindWindowA Lib “user32” (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

‘Script untuk menghilangkan bingkai window pada UserForm

Private Sub UserForm_Initialize()
Dim lngWindow As Long, lFrmHdl As Long
lFrmHdl = FindWindowA(vbNullString, Me.Caption) ‘ The UserForm must have a caption
lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)
lngWindow = lngWindow And (Not WS_CAPTION)
Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)
Call DrawMenuBar(lFrmHdl)
End Sub

‘Script untuk Splash Screen

Private Sub UserForm_Activate()
Application.OnTime Now + TimeValue(“00:00:05”), “KillTheForm”
End Sub

‘Prosedur untuk tombol test splash screen dan  “KillTheForm”

Sub TestSplashScreen()
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) – (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) – (0.5 * .Height)
.Show
End With
End Sub

Private Sub KillTheForm()
Unload UserForm1
End Sub

download file contoh : splash Screen 

Advertisements

Membuat Program (Sederhana) Periksa Test Pilihan Ganda dengan Excel VBA

periksaTest01

Salah satu alat bantu yang harus kita miliki untuk mempersiapkan siswa kelas 9 SMP menghadapi ujian nasional adalah program periksa test pilihan ganda. Dengan program periksa test kita dapat mengevaluasi secara cepat di mana kekurangan siswa dalam menghadapi ujian nasional matematika. Pada posting ini saya share kan, script VBA untuk membuat program (sederhana) periksa test.

Ada tiga  procedure yang saya buat untuk program periksa test ini,

Procedure yang pertama untuk mengecek cell yang terisi jawaban peserta, sedangkan procedure yang kedua untuk menghapus data (jika kita akan menggunakan kembali untuk test yang lain)

periksaTest04dan procedure yang ketiga, untuk memeriksa input jawaban peserta test

periksaTest05

Cara penggunaan program periksa test (pilihan ganda) :

1. Inputkan nama peserta dan jawaban peserta

periksaTest022. Setelah selesai memasukkan semua data  nama dan jawaban peserta, selanjutnya tekan tombol periksa

periksaTest03

download : program periksa test (xlsm)

 

VBA for Excel : Membuat TTS Interaktif dengan Excel

Pada posting ini disajikan listing program untuk membuat TTS Interaktif dengan Excel.

Kotak TTS :

gbr1

Pertanyaan TTS :

gbr2

 

Listing Program agar TTS Excel anda menjadi Interaktif :

ttribute VB_Name = “Module1”
Sub reset()
‘KOSONGKAN CELL
Dim kotakClear As Variant

kotakClear = Array(Range(“B4:K4”), Range(“B6,E6,G6,I6,K6,L6”), Range(“B8:E8,G8:I8,K8”), _
Range(“B10,D10:G10,I10:L10”), Range(“B12,D12,F12,H12,J12,L12”), Range(“B14:E14,G14:J14,L14”), _
Range(“C16,E16:G16,I16:L16”), Range(“B18,C18,E18,G18,I18,L18”), Range(“C20:L20”))

For i = 0 To 8
With kotakClear(i)
.Value = “”
.Font.Color = RGB(0, 0, 0)
End With
Next

Worksheets(“TTSNo2”).Shapes(“Button 2”).Visible = True

End Sub
Sub periksa()

Dim kunci1 As Variant
Dim kunci2 As Variant
Dim kotak As Variant
Dim Jbenar As Integer
Dim nilaiTTS As Double

‘KUNCI JAWABAN DENGAN HURUF KAPITAL
kunci1 = Array(“P”, “O”, “L”, “I”, “K”, “L”, “I”, “N”, “I”, “K”, _
“A”, “R”, “A”, “U”, “U”, “U”, _
“T”, “A”, “L”, “I”, “K”, “A”, “R”, “D”, _
“U”, “A”, “T”, “A”, “U”, “I”, “K”, “A”, “N”, _
“N”, “I”, “S”, “R”, “A”, “O”, _
“G”, “U”, “N”, “A”, “S”, “I”, “A”, “L”, “N”, _
“F”, “M”, “A”, “U”, “S”, “A”, “I”, “S”, _
“M”, “U”, “A”, “A”, “I”, “E”, _
“K”, “A”, “L”, “I”, “M”, “A”, “N”, “T”, “A”, “N”)
‘KUNCI JAWABAN DENGAN HURUF KECIL
kunci2 = Array(“p”, “o”, “l”, “i”, “k”, “l”, “i”, “n”, “i”, “k”, _
“a”, “r”, “a”, “u”, “u”, “u”, _
“t”, “a”, “l”, “i”, “k”, “a”, “r”, “d”, _
“u”, “a”, “t”, “a”, “u”, “i”, “k”, “a”, “n”, _
“n”, “i”, “s”, “r”, “a”, “o”, _
“g”, “u”, “n”, “a”, “s”, “i”, “a”, “l”, “n”, _
“f”, “m”, “a”, “u”, “s”, “a”, “i”, “s”, _
“m”, “u”, “a”, “a”, “i”, “e”, _
“k”, “a”, “l”, “i”, “m”, “a”, “n”, “t”, “a”, “n”)
‘KOTAK YANG DIGUNAKAN UNTUK ISIAN TTS
kotak = Array(Range(“B4”), Range(“C4”), Range(“D4”), Range(“E4”), Range(“F4”), Range(“G4”), Range(“H4”), Range(“I4”), Range(“J4”), Range(“K4”), _
Range(“B6”), Range(“E6”), Range(“G6”), Range(“I6”), Range(“K6”), Range(“L6”), _
Range(“B8”), Range(“C8”), Range(“D8”), Range(“E8”), Range(“G8”), Range(“H8”), Range(“I8”), Range(“K8”), _
Range(“B10”), Range(“D10”), Range(“E10”), Range(“F10”), Range(“G10”), Range(“I10”), Range(“J10”), Range(“K10”), Range(“L10”), _
Range(“B12”), Range(“D12”), Range(“F12”), Range(“H12”), Range(“J12”), Range(“L12”), _
Range(“B14”), Range(“C14”), Range(“D14”), Range(“E14”), Range(“G14”), Range(“H14”), Range(“I14”), Range(“J14”), Range(“L14”), _
Range(“C16”), Range(“E16”), Range(“F16”), Range(“G16”), Range(“I16”), Range(“J16”), Range(“K16”), Range(“L16”), _
Range(“B18”), Range(“C18”), Range(“E18”), Range(“G18”), Range(“I18”), Range(“L18”), _
Range(“C20”), Range(“D20”), Range(“E20”), Range(“F20”), Range(“G20”), Range(“H20”), Range(“I20”), Range(“J20”), Range(“K20”), Range(“L20”))

‘PERIKSA JAWABAN DENGAN KUNCI
Jbenar = 0

For i = 0 To 71
If kotak(i).Text = kunci1(i) Or kotak(i).Text = kunci2(i) Then
With kotak(i)
.Font.Color = RGB(0, 0, 255)
End With
Jbenar = Jbenar + 1
Else
With kotak(i)
.Font.Color = RGB(255, 0, 0)
End With
Jbenar = Jbenar + 0
End If
Next
nilaiTTS = Round((Jbenar / 72) * 100, 2)

If nilaiTTS >= 80 Then
UserForm1.Label1.Caption = nilaiTTS
UserForm1.Show
Else
UserForm2.Label1.Caption = nilaiTTS
UserForm2.Show
End If
Worksheets(“TTSNo2”).Shapes(“Button 2”).Visible = False
End Sub

Sub kareem()
UserForm3.Show
End Sub

 

download : TTS Excel Interaktif (file xlsm)