Awal Kalimat Kapital |
'Deskripsi: Menampilkan huruf pertama dari setiap kalimat
' menjadi huruf besar/kapital.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id).
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 1 TextBox
' 2. Copy-kan coding berikut ke dalam editor form yang bertalian.
'--------------------------------------------------------------------------
Public Function AwalKalimatKapital(strKalimat As String)
Dim Temp1 As String, Temp2 As String
Dim Lokasi As Integer, i As Integer
Dim huruf As String * 1
Temp1$ = LCase(strKalimat) 'Kecilkan dulu semua
For i% = 1 To Len(Temp1$)
huruf = Chr(Asc(Mid(strKalimat, i%, 1)))
If huruf = "." Then
Lokasi% = i% + 2
End If
If i% = 1 Or i% = Lokasi% Then
Temp2$ = Temp2$ + UCase(Chr(Asc(Mid(Temp1$, i%, 1))))
Else
Temp2$ = Temp2$ + LCase(Chr(Asc(Mid(Temp1$, i%, 1))))
End If
Next i
AwalKalimatKapital = Temp2$
End Function
Private Sub Text1_Change()
Dim posisi As Integer
posisi = Text1.SelStart
Text1.Text = AwalKalimatKapital(Text1.Text)
Text1.SelStart = posisi
End Sub*****************************************************************************
*****************************************************************************
Awal Kata Kapital |
'Deskripsi: Menampilkan huruf pertama dari setiap kata dalam suatu kalimat
' menjadi huruf besar/kapital.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id).
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 1 TextBox
' 2. Copy-kan coding berikut ke dalam editor form yang bertalian.
'--------------------------------------------------------------------------
Public Function AwalKataKapital(strKalimat As String)
Dim i As Integer 'By Masino Sinaga, Bandung, 5 Juli 2002
Dim Temp As String
Dim Lokasi As Integer
Dim huruf As String * 1
Temp$ = ""
For i% = 1 To Len(strKalimat)
huruf = Chr(Asc(Mid(strKalimat, i%, 1)))
If Len(Trim(huruf)) < 1 Then
Lokasi% = i% + 1
End If
If i% = Lokasi% Or i% = 1 Then
Temp$ = Temp$ + UCase(Chr(Asc(Mid(strKalimat, i%, 1))))
Else
Temp$ = Temp$ + LCase(Chr(Asc(Mid(strKalimat, i%, 1))))
End If
Next i
AwalKataKapital = Temp$
End Function
Private Sub Text1_Change()
Dim posisi As Integer
posisi = Text1.SelStart
Text1.Text = AwalKataKapital(Text1.Text)
Text1.SelStart = posisi
End Sub *****************************************************************************
*****************************************************************************
Aplikasi Cetak Laporan |
'Deskripsi: Contoh source code untuk mencetak laporan yang datanya diambil
' dari database, menampilkan ke layar dan mencetaknya ke printer.
' Kategori laporan dapat dipilih berdasarkan menu atau masukan
' dari User. Menggunakan fungsi untuk meratakan suatu teks pada
' suatu kolom laporan (rata kanan dan rata kiri). Laporan dapat
' disimpan dan diambil ke dan dari file teks.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Minggu, 12 Mei 2002
'Persiapan: 1. Buat 1 Project baru dengan 1 Form (frmCetakLaporan) dan
' 1 Module (Module1).
' 2. Pada frmCetakLaporan, tambahkan sebagai berikut:
' * Tiga buah Commandbutton, sbb:
' - cmdSimpan
' - cmdCetak
' - cmdKeluar
' * ComboBox, (Name = cboPrinter)
' 3. Buat Menu dengan struktur sebagai berikut:
' + File (mnuFile)
' - Buka (mnuBuka)
' - Simpan (mnuSimpan)
' - Cetak (mnuCetak)
' - - (mnuSep)
' - Keluar (mnuKeluar)
' + Kategori (mnuKategori)
' - Semua Data (mnuSemua)
' - Tanggal Terima (mnuTanggal)
' - Kode Barang (mnuKode)
' - Nama Barang (mnuNama)
' - Harga Satuan (mnuHarga)
' + Petunjuk (mnuPetunjuk)
' - Bantuan (mnuBantuan)
' - Tentang (mnuTentang)
' 4. Tambahkan control Timer. Set property Interval = 500, Enabled = True.
' 5. Tambahkan reference "Microsoft ActiveX Data Objects 2.0 Library"
' dari menu Project->References...
' 6. Tambahkan component ke form dari menu Project->Components, sbb:
' - "Microsoft Common Dialog Control 6.0 (SP3)" utk ShowOpen/ShowSave.
' - "Microsoft Windows Common Controls 5.0 (SP2), tambahkan StatusBar
' ("StatusBar1") dan ProgressBar ("prgBar1") masing-masing satu.
' - "Microsoft Rich TextBox Control 6.0", tambahkan 1 RichTextBox, beri
' nama dengan "rtfLap1".
' 7. Copy-kan coding untuk setiap form yang bertalian
' (lihat di halaman frmCetakLaporan dan Module1 di bawah)
Klik di sini untuk mendownload source code lengkap aplikasi CetakLaporan ini (36 KB).*******************************************************************************
*******************************************************************************
Menampilkan Data dari Database ke ListView |
'Deskripsi: Menampilkan data dari database MS Access ke
' dalam control ListView dan memungkinkan untuk
' penyortiran data pada setiap field atau kolom di
' ListView jika header ybt diklik. Menggunakan
' reference "Microsoft ActiveX Data Objects 2.0
' Library" untuk coding database, dan control
' "Microsoft Windows Common Control 6.0"
' untuk control ListView.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Senin, 22 Juli 2002
'Persiapan: 1. Buat 1 Project baru dengan 1 Form.
' 2. Tambahkan reference dan component sesuai dengan
' yang disebutkan di atas.
' 3. Tambahkan satu ListView ke dalam form, beri nama
' ListView ini dengan LV.
' 4. Copy-kan coding berikut ke dalam editor form ybt.
'---------------------------------------------------------------
Private Sub Form_Load()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
'Buka koneksi ke database...
cn.Open "Provider=Microsoft.Jet.OLEDB.3.51;" _
& "Data Source=" & _
App.Path & "Data.mdb"
'Buka tabel "Orders"
rs.Open "Orders", cn, adOpenForwardOnly, adLockReadOnly
'Tentukan tampilan ListView...
LV.View = lvwReport 'Jangan lupa yang ini...!
'Ambil data dari recordset...
LoadListViewFromRecordset LV, rs
'Atur ukuran/lebar kolom di setiap listview...
ListViewAdjustColumnWidth LV, True
End Sub
Sub LoadListViewFromRecordset(LV As ListView, _
rs As ADODB.Recordset, Optional MaxRecords As Long)
'Prosedur mengambil data dari Recordset (tabel database)
Dim fld As ADODB.Field, alignment As Integer
Dim recCount As Long, i As Long, fldName As String
Dim li As ListItem
'Bersihkan isi dari ListView.
LV.ListItems.Clear
LV.ColumnHeaders.Clear
'Buat kumpulan ColumnHeader.
For Each fld In rs.Fields
'Menyaring tipe field untuk keperluan
'perataan tampilan teks di ListView
Select Case fld.Type
Case adBoolean, adCurrency, adDate, adDecimal, adDouble
alignment = lvwColumnRight
Case adInteger, adNumeric, adSingle, adSmallInt, adVarNumeric
alignment = lvwColumnRight
Case adBSTR, adChar, adVarChar, adVariant
alignment = lvwColumnLeft
Case Else
alignment = -1 'Berarti: "Unsupported field type".
'atau tipe field tdk mendukung
End Select
'Jika tipe field OK, buat sebuah kolom
'dengan perataan (alignment) yang benar.
If alignment <> -1 Then
'Kolom pertama haruslah rata kiri.
If LV.ColumnHeaders.Count = 0 Then alignment = lvwColumnLeft
LV.ColumnHeaders.Add , , fld.Name, fld.DefinedSize * 200, _
alignment
End If
Next
'Keluar jika tidak ada field yg dapat ditampilkan.
If LV.ColumnHeaders.Count = 0 Then Exit Sub
'Tambahkan semua records dalam recordset.
rs.MoveFirst
Do Until rs.EOF
recCount = recCount + 1
'Tambahkan object utama ListItem.
fldName = LV.ColumnHeaders(1).Text
Set li = LV.ListItems.Add(, , rs.Fields(fldName) & "")
'Tambahkan semua sub (ListSubItems.Add).
For i = 2 To LV.ColumnHeaders.Count
fldName = LV.ColumnHeaders(i)
li.ListSubItems.Add , , rs.Fields(fldName) & ""
Next
If recCount = MaxRecords Then Exit Do
rs.MoveNext
Loop
End Sub
Sub ListViewAdjustColumnWidth(LV As ListView, _
Optional AccountForHeaders As Boolean)
'Prosedur untuk menyesuaikan ukuran/lebar kolom ListView
Dim row As Long, col As Long
Dim width As Single, maxWidth As Single
Dim saveFont As StdFont, saveScaleMode As Integer, cellText As String
'Langsung keluar dari prosedur jika tidak ada
'items yang akan ditampilkan.
If LV.ListItems.Count = 0 Then Exit Sub
'Simpan huruf yang digunakan oleh form,
'dan sesuaikan ke huruf di ListView.
'Kita membutuhkan ini dengan tujuan untuk
'menggunakan metode dari TextWidth milik form.
Set saveFont = LV.Parent.Font
Set LV.Parent.Font = LV.Font
'Sesuaikan ScaleMode = vbTwips untuk form (parent).
saveScaleMode = LV.Parent.ScaleMode
LV.Parent.ScaleMode = vbTwips
For col = 1 To LV.ColumnHeaders.Count
maxWidth = 0
If AccountForHeaders Then
maxWidth = LV.Parent.TextWidth(LV.ColumnHeaders(col).Text) + 200
End If
For row = 1 To LV.ListItems.Count
'Ambil teks dari ListItems atau ListSubItems.
If col = 1 Then
cellText = LV.ListItems(row).Text
Else
cellText = LV.ListItems(row).ListSubItems(col - 1).Text
End If
'Hitung lebarnya, dan tetapkan untuk batas.
'Catatan: Tidak berlaku untuk "multiple-line text fields"
'atau teks yang fieldnya mengandung dari banyak baris.
width = LV.Parent.TextWidth(cellText) + 200
'Update lebar maksimum jika kita menemukan
'sebuah string yang lebih lebar.
If width > maxWidth Then maxWidth = width
Next
'Ubah lebar kolom sekarang...
LV.ColumnHeaders(col).width = maxWidth
Next
'Ganti property parent milik ListView
Set LV.Parent.Font = saveFont
LV.Parent.ScaleMode = saveScaleMode
End Sub
Private Sub Form_Resize()
'coding ini shrsnya jika error lanjut saja, sengaja dihilangkan spy dapat diupload ke brinkster
LV.Move 0, 0
LV.Height = Me.ScaleHeight - 250
LV.width = Me.ScaleWidth - 20
End Sub
'Menyortir data di ListView jika header kolom ybt
'diklik
Private Sub LV_ColumnClick(ByVal ColumnHeader As _
MSComctlLib.ColumnHeader)
'Urutkan data berdasarkan di kolom ybt...
If LV.Sorted And _
ColumnHeader.Index - 1 = LV.SortKey Then
'Telah diurutkan di kolom ini,
'balikkan urutan sortir.
LV.SortOrder = 1 - LV.SortOrder
Else
LV.SortOrder = lvwAscending
LV.SortKey = ColumnHeader.Index - 1
End If
LV.Sorted = True
End Sub
Klik di sini untuk mendownload source code + database lengkap aplikasi Database ini (39 KB).*****************************************************************************
*****************************************************************************
Membuat File Excel dari Program |
'Deskripsi: Membuat file MS Excel dengan menggunakan coding.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 1 Commandbutton.
' 2. Tambahkan reference dari Project->References... ceklist
' Microsoft Excel X.0 Object Library, lalu klik OK
' 3. Copy-kan coding berikut ke dalam editor form ybt.
'--------------------------------------------------------------------
Private Sub Command1_Click()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet
Set xlApp = New Excel.Application
Set xlWB = xlApp.Workbooks.Add
Set xlWS = xlWB.Worksheets.Add
'Baris berikut ini akan mengisi cell (2,2) dengan tulisan "hello",
'dan akan mengisi cell (1,3) dengan tulisan "World"
xlWS.Cells(2, 2).Value = "hello"
xlWS.Cells(1, 3).Value = "World"
'Baris berikut ini menyimpan spreadsheet menjadi file "c:mysheet.xls".
xlWS.SaveAS "c:mysheet.xls"
xlApp.Quit
'Bebaskan memory...
Set xlWS = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub *****************************************************************************
*****************************************************************************
Menampilkan Daftar Tabel di Database |
'Deskripsi: Menampilkan daftar tabel yang terdapat di dalam file database
' MS Access (*.mdb) menggunakan reference DAO.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Rabu, 8 Mei 2002.
'Persiapan: 1. Buat 1 Project baru dengan 1 Form, 1 Listbox.
' 2. Tambahkan reference Microsoft DAO 3.X Object Library dari menu
' Project->References
' 3. Copy-kan coding berikut ke dalam editor form yang bertalian.
'-------------------------------------------------------------------------------
Option Explicit 'Setiap variabel yang digunakan harus dideklarasikan dulu...
Private Sub Form_Load()
Dim db As Database
Dim qdef As QueryDef
Dim td As TableDef
Dim dbname As String
'Buka database. Ganti "c:DBfile.mdb" dengan nama file database Anda
'Jika database di password, sesuaikan dengan metoda pembukaan file database
'yang diprotect dengan password... Pada contoh ini, kita anggap file *.mdb
'ybt tidak dipassword.
Set db = OpenDatabase("c:DBfile.mdb")
'Tampilkan nama tabel yang ada.
For Each td In db.TableDefs
'Jika Anda ingin menampilkan juga tabel sistem, ganti baris coding
'di bawah dengan: List1.AddItem td.Name, jadi tanpa pengecekan If...
If td.Attributes = 0 Then List1.AddItem td.Name
Next td
db.Close
End Sub ******************************************************************************
******************************************************************************
Entri/Cari Data di ListBox |
'Deskripsi: Jika user menekan huruf 'a' di textbox, item pertama yang diawali dengan ' huruf 'a' pada ListBox akan ditandai (disorot). 'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id) 'Persiapan: 1. Buat 1 Project baru dengan 1 Form, 1 Module, 1 TextBox, dan 1 ListBox. ' 2. Tambahkan beberapa item ke dalam List1. ' 3. Copy-kan coding berikut ke dalam editor Module/Form ybt. '------------------------------------------------------------------------------------ '--- Coding ini di Module... Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As _ Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Any) As Long Public Const LB_FINDSTRING = &H18F '--- Batas coding di Module... '--- Coding ini di Form... Private Sub Form_Load() 'Tambahkan beberapa item ke dalam List1 List1.AddItem "Adi" List1.AddItem "Aman" List1.AddItem "Akhmad" List1.AddItem "Armanto" List1.AddItem "Badu" List1.AddItem "Bobo" List1.AddItem "Joko" List1.AddItem "Jaka" List1.AddItem "Parto" List1.AddItem "Paino" End Sub Private Sub Text1_Change() List1.ListIndex = SendMessage(List1.hwnd, LB_FINDSTRING, -1, ByVal CStr(Text1.Text)) End Sub '--- Batas coding di Form...
*******************************************************************************
*******************************************************************************
Mengetahui Daftar Field di Tabel Database (ADO) |
'Deskripsi: Mengetahui daftar nama field beserta tipe dan ukuran field
' di suatu tabel database dengan menggunakan reference ADO.
' Ketika Anda mengklik nama tabel di daftar List1, maka
' seluruh field yang terdapat di tabel tersebut akan
' ditampilkan di List2. Jika nama field di List2 diklik,
' maka akan ditampilkan tipe dan ukuran field tersebut.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Minggu, 15 September 2002
'Persiapan: 1. Buat 1 Project baru dengan 1 Form.
' 2. Tambahkan 2 ListBox, 1 Commandbutton, dan 2 Label.
' 3. Tambahkan reference Microsoft ActiveX Data Objects 2.0
' Library dari menu Project->References...
' 4. Copy-kan coding berikut ke editor form yang bertalian.
---------------------------------------------------------------------
'Variabel Connection dan Recordset ADO
Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset
'Buat tipe data untuk menampung data tipe dan ukuran
Private Type arrTipe
Tipe As String
Ukuran As Integer
End Type
'Buat array dinamis bertipe arrTipe di atas
Dim tabTipe() As arrTipe
Private Sub DaftarTabel(Daftar As ListBox)
On Error GoTo Pesan
'Inisialisasi variabel Connection
Set cnn = New ADODB.Connection
cnn.CursorLocation = adUseClient
'Sesuaikan lokasi database di PC Anda
cnn.ConnectionString = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=D:rinksterfilesADOKontrolmahasiswa.mdb;" & _
"Jet OLEDB:Database Password=;"
cnn.Open
'Buka skema tabel dengan OpenSchema
Set rs = cnn.OpenSchema(adSchemaTables)
'Bersihkan daftar tempat menampungnya dulu
Daftar.Clear
While rs.EOF <> True
'MSys untuk tabel sistem di MS Access
'sys biasanya tabel sistem di MS SQL Server
'Jadi, tabel sistem tidak perlu ditampilkan...
If Left(rs.Fields("Table_Name").Value, 4) <> "MSys" And _
Left(rs.Fields("Table_Name").Value, 3) <> "sys" Then
'Tambahkan ke daftar...
Daftar.AddItem rs.Fields("Table_Name")
End If
rs.MoveNext
Wend
'Jika sudah selesai, sorot item paling atas
Daftar.Text = Daftar.List(0)
Exit Sub
Pesan: 'Jika ada error, tampilkan nomor dan deskripsinya
MsgBox Err.Number & " - " & _
Err.Description, vbCritical, "Error"
End Sub
Private Sub Command1_Click()
'Tampilkan daftar tabel ke List1
Call DaftarTabel(List1)
End Sub
Private Sub DaftarField(NamaTabel As String, Daftar As ListBox)
Dim Adofl As ADODB.Field, i As Integer
'Gunakan kembali variabel rs, tapi bersihkan dulu...
Set rs = New ADODB.Recordset
'Buka tabel dari parameter
rs.Open NamaTabel, cnn, adOpenKeyset, adLockOptimistic, adCmdTable
'Alokasi ulang array dinamis untuk menampung jumlah field
ReDim tabTipe(rs.Fields.Count)
'Bersihkan daftar tempat menampungnya dulu
Daftar.Clear
'Untuk setiap Field di Recordset rs
For Each Adofl In rs.Fields
'Tambahkan satu per satu ke daftar
Daftar.AddItem Adofl.Name
'Tampung ke array tipe dan ukurannya
tabTipe(i).Tipe = TipeField(Adofl.Type)
tabTipe(i).Ukuran = Adofl.DefinedSize
i = i + 1 'Counter untuk maju ke berikutnya
Next
'Setelah selesai, sorot item yang teratas
Daftar.Text = Daftar.List(0)
End Sub
Private Sub Form_Load()
'Kosongkan label mula-mula
Label1.Caption = ""
Label2.Caption = ""
End Sub
Private Sub List1_Click()
'Jika item (namatabel) di List1 diklik, maka tampilkan
'daftar field dari tabel ybt di List2
Call DaftarField(List1.Text, List2)
End Sub
Private Sub List2_Click()
'Jika item di List2 diklik, maka tampilkan tipe dan ukuran field-nya
If List2.ListIndex <> -1 And _
tabTipe(List2.ListIndex).Tipe <> "" Then
'Tampilkan tipe dan ukurannya masing-masing
'ke Label1 dan Label2
Label1.Visible = True
Label2.Visible = True
Label1.Caption = "Tipe Field: " & tabTipe(List2.ListIndex).Tipe
Label2.Caption = "Ukuran Field: " & tabTipe(List2.ListIndex).Ukuran
Else
'Jika record tidak ada...
Label1.Visible = False
Label2.Visible = False
End If
End Sub
Public Function TipeField(intType As Integer) As String
'Fungsi berikut untuk menentukan tipe suatu field
Select Case intType
Case adEmpty '0
TipeField = "adEmpty"
Case adTinyInt '16
TipeField = "adTinyInt"
Case adSmallInt '2
TipeField = "adSmallInt"
Case adInteger '3
TipeField = "adInteger"
Case adBigInt '20
TipeField = "adBigInt"
Case adUnsignedTinyInt '17
TipeField = "adUnsignedTinyInt"
Case adUnsignedSmallInt '18
TipeField = "adUnsignedSmallInt"
Case adUnsignedInt '19
TipeField = "adUnsignedInt"
Case adUnsignedBigInt '21
TipeField = "adUnsignedBigInt"
Case adSingle '4
TipeField = "adSingle"
Case adDouble '5
TipeField = "adDouble"
Case adCurrency '6
TipeField = "adCurrency"
Case adDecimal '14
TipeField = "adDecimal"
Case adNumeric '131
TipeField = "adNumeric"
Case adBoolean '11
TipeField = "adBoolean"
Case adError '10
TipeField = "adError"
Case adUserDefined '132
TipeField = "adUserDefined"
Case adVariant '12
TipeField = "adVariant"
Case adIDispatch '9
TipeField = "adIDispatch"
Case adIUnknown '13
TipeField = "adIUnknown"
Case adGUID '72
TipeField = "adGUID"
Case adDate '7
TipeField = "adDate"
Case adDBDate '133
TipeField = "adDBDate"
Case adDBTime '134
TipeField = "adDBTime"
Case adDBTimeStamp '135
TipeField = "adDBTimeStamp"
Case adBSTR '8
TipeField = "adBSTR"
Case adChar '129
TipeField = "adChar"
Case adVarChar '200
TipeField = "adVarChar"
Case adLongVarChar '201
TipeField = "adLongVarChar"
Case adWChar '130
TipeField = "adWChar"
Case adVarWChar '202
TipeField = "adVarWChar"
Case adLongVarWChar '203
TipeField = "adLongVarWChar"
Case adBinary '128
TipeField = "adBinary"
Case adVarBinary '204
TipeField = "adVarBinary"
Case adLongVarBinary '205
TipeField = "adLongVarBinary"
Case adChapter '136
TipeField = "adChapter"
Case dbBoolean
TipeField = "dbBoolean"
Case dbByte
TipeField = "dbByte"
Case dbInteger
TipeField = "dbInteger"
Case dbLong
TipeField = "dbLong"
Case dbCurrency
TipeField = "dbCurrency"
Case dbSingle
TipeField = "dbSingle"
Case dbDouble
TipeField = "dbDouble"
Case dbDate
TipeField = "dbDate"
Case dbText
TipeField = "dbText"
Case dbLongBinary
TipeField = "dbLongBinary"
Case dbMemo
TipeField = "dbMemo"
Case dbGUID
TipeField = "dbGUID"
End Select
End Function
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'Tutup semua variabel recordset dan connection
rs.Close
cnn.Close
'Bersihkan memory yang telah digunakan
Set rs = Nothing
Set cnn = Nothing
End Sub *******************************************************************************
*******************************************************************************
Menampilkan Tanggal dan Jam Sistem On-Line |
'Deskripsi: Pernahkah Anda ingin menampilkan tanggal dengan format tertentu
' beserta jam sistem yang keduanya dapat menyesuaikan dengan
' perubahan waktu di komputer Anda? Ada kalanya pada saat program
' Anda dijalankan, saat itu juga dilakukan perubahan tanggal dan
' jam sistem di komputer Anda, misalnya dari menu Date/Time di
' Control Panel atau perubahan terjadi karena pergantian hari dan
' tanggal (lewat tengah malam). Agar perubahan tersebut juga
' terjadi di program Anda, silahkan gunakan tips berikut ini.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Minggu, 12 Mei 2002
'Persiapan: 1. Buat 1 Project baru dengan 1 Form, 2 Label, dan 1 Timer.
' 2. Copy-kan coding berikut ke dalam editor form yang bertalian.
'----------------------------------------------------------------------------
Dim sHari As String 'Deklarasi variabel global, karena digunakan
Dim aHari 'oleh lebih dari satu prosedur
Private Sub Form_Load() 'Inisialisasi array untuk hari
aHari = Array("Minggu", "Senin", "Selasa", "Rabu", _
"Kamis", "Jumat", "Sabtu")
Timer1.Interval = 500 'Set property interval
Timer1.Enabled = True 'Aktifkan jika belum...
End Sub
'Prosedur ini meng-update tanggal & jam setiap ada perubahan, baik
'perubahan yang dilakukan melalui Date/Time di menu Control Panel
'maupun perubahan yang terjadi karena pergantian hari/tanggal.
Private Sub Timer1_Timer()
sHari = aHari(Abs(Weekday(Date) - 1)) 'Tampilkan hari
Label1.Caption = "" & sHari & ", " _
& Format(Date, "dd mmmm yyyy")
Label2.Caption = Format(Time, "hh:mm:ss")
End Sub ******************************************************************************
******************************************************************************
Mengencrypt/decrypt File Teks |
'Deskripsi: Mengencrypt/decrypt suatu file teks menjadi file teks yang
' lainnya dengan menggunakan password.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Rabu, 22 Mei 2002
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 1 RichTextBox.
' 2. Beri nama RichTextBox dengan "rtfEncDec".
' 3. Copy-kan coding berikut ke dalam editor form ybt.
'---------------------------------------------------------------------
'Pada contoh ini, nama file default telah tersedia ketika
'kotak dialog InputBox ditampilkan. Klik saja OK tanpa
'mengganti nama file yang telah terisi di InputBox tersebut.
'Untuk mencoba ulang, hapus file Masino.txt, Masino1.txt,
'dan file Sinaga.txt yang terbentuk di direktori program ini...
Sub FileEncodeAndDecode(InputFile As String, _
OutputFile As String, _
PasswordKey As String)
Dim temp As Single
Dim Char As String * 1
Dim XORMask As Single
Dim temp1 As Integer
Open InputFile For Binary As #1
Open OutputFile For Binary As #2
For x = 1 To Len(PasswordKey)
temp = Asc(Mid$(PasswordKey, x, 1))
For y = 1 To temp
temp1 = Rnd
Next y
Randomize temp1
Next x
Counter = 0
For z = 1 To FileLen(InputFile)
XORMask = Int(Rnd * 256)
Get 1, , Char
Char = Chr$((Asc(Char) Xor XORMask))
Put 2, , Char
Counter = Counter + 1
If Counter > Len(PasswordKey) Then Counter = 1
For x = 1 To (Asc(Mid$(PasswordKey, Counter, 1)) * 2)
temp = Rnd
Next x
Next z
Close #1
Close #2
'Tampilkan hasilnya ke rtfEncDec...
Open OutputFile For Binary As #3
rtfEncDec.Text = Input(LOF(3), 3)
Close #3
End Sub
Private Sub Command1_Click()
Dim InputFile As String
Dim OutputFile As String
Dim PasswordKey As String
On Error GoTo Pesan
'Jika file Masino.txt sudah ada dan file Sinaga.txt belum
If Dir(App.Path & "Masino.txt") <> "" And _
Dir(App.Path & "Sinaga.txt") = "" Then
InputFile = InputBox("Masukkan nama file yang akan " & _
"di-encrypt/decrypt:", _
"File Sumber", "Masino.txt")
If StrPtr(InputFile) = 0 Or InputFile = "" Then Exit Sub
'Jika file Masino.txt dan Sinaga.txt sudah ada
ElseIf Dir(App.Path & "Masino.txt") <> "" And _
Dir(App.Path & "Sinaga.txt") <> "" Then
InputFile = InputBox("Masukkan nama file yang akan " & _
"di-encrypt/decrypt:", _
"File Sumber", "Sinaga.txt")
If StrPtr(InputFile) = 0 Or InputFile = "" Then Exit Sub
End If
Open App.Path & "" & InputFile For Binary As #1
rtfEncDec.Text = Input(LOF(1), 1)
Close #1
'Jika file Masino.txt sudah ada dan file Sinaga.txt belum
If Dir(App.Path & "Masino.txt") <> "" And _
Dir(App.Path & "Sinaga.txt") = "" Then
OutputFile = InputBox("Masukkan nama file hasil " & _
"encrypt/decrypt: ", _
"File Tujuan", "Sinaga.txt")
If StrPtr(OutputFile) = 0 Or OutputFile = "" Then Exit Sub
'Jika file Masino.txt dan Sinaga.txt sudah ada
ElseIf Dir(App.Path & "Masino.txt") <> "" And _
Dir(App.Path & "Sinaga.txt") <> "" Then
OutputFile = InputBox("Masukkan nama file hasil " & _
"encrypt/decrypt: ", _
"File Tujuan", "Masino1.txt")
If StrPtr(OutputFile) = 0 Or OutputFile = "" Then Exit Sub
End If
PasswordKey = InputBox("Masukkan password:", _
"Password", "masinosinaga")
Call FileEncodeAndDecode(App.Path & "" & InputFile, _
App.Path & "" & OutputFile, _
PasswordKey)
MsgBox "Berhasil di-encrypt/decrypt ke " & OutputFile, _
vbInformation, "Encrypt/Decrypt OK"
End
Exit Sub
Pesan:
MsgBox Err.Number & " - " & Err.Description
End Sub
Private Sub Form_Load()
BuatFileTeks 'Buat file teks pada permulaan aplikasi ini
rtfEncDec.RightMargin = rtfEncDec.Width + 500
End Sub
Sub BuatFileTeks()
Open App.Path & "Masino.txt" For Output As #1
Print #1, "Testing membuat file teks..."
Print #1, "Isinya akan digunakan untuk encode/decode"
Print #1, "-----------------------------------------"
Print #1, "Masino Sinaga"
Print #1, "Asrama Melati 219 Puslatpos"
Print #1, "Jalan Terusan Sari Asih 54 Bandung 40151"
Close #1
End Sub ******************************************************************************
******************************************************************************
Menampilkan Tulisan Berjalan di StatusBar |
'Deskripsi: Menampilkan tulisan berjalan di StatusBar (bagian bawah form)
' dengan bantuan control Timer.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Senin, 22 Juli 2002
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 1 StatusBar. StatusBar
' dapat Anda peroleh dari component yang bernama:
' ""Microsoft Windows Common Controls 5.0 (SP2)"
' dari Add->Components...
' 2. Copy-kan coding berikut ke dalam editor form yang bertalian.
'--------------------------------------------------------------------------
Dim Counter As Integer
Private Sub Form_Load()
Counter = 0
Timer1.Interval = 50 '<-- Atur kecepatannya di sini
With StatusBar1
.Panels(1).Width = 4000
.Panels(1).Alignment = sbrRight
End With
End Sub
Private Sub Timer1_Timer()
Dim Kalimat As String
Dim pnlX1 As Panel
Set pnlX1 = StatusBar1.Panels(1)
Kalimat = "Testing tulisan berjalan"
Counter = Counter + 1
DoEvents
pnlX1.Text = TulisJalan(Counter, Kalimat, 150)
End Sub
Public Function TulisJalan(Hitung As Integer, _
strKalimat As String, _
Panjang As Integer)
If Hitung = Len(strKalimat) + Panjang Then
Hitung = 0
ElseIf Hitung > Len(strKalimat) Then
TulisJalan = strKalimat & Space(Hitung - Len(strKalimat))
Else
TulisJalan = Mid(strKalimat, 1, Hitung)
End If
End Function ******************************************************************************
******************************************************************************
Terbilang Desimal Indonesia |
'Deskripsi: Menampilkan tulisan terbilang dengan bahasa Indonesia dari
' besar uang yang dimasukkan ke dalam textbox. Besar uang
' yang dimasukkan dapat dipisahkan dengan separator koma.
'Pembuat : (Dari berbagai sumber); disarikan oleh Masino Sinaga
' (masino_sinaga@posindonesia.co.id)
'Modifik. : Bandung, 2 Mei 2003.
' - Membetulkan ejaan untuk bilangan setelah tanda koma,
' sebelumnya menggunakan KonversiBilangan, kini memakai
' KonversiPecahan (setiap 1 angka dibaca satu per satu)
' - Membuat parameter "MataUang" yg bersifat opsional,
' di mana default-nya = "rupiah" untuk fungsi
' TerbilangBulat dan TerbilangDesimal.
' Jika parameter ini dikosongkan dengan "" maka
' kata "rupiah" tidak muncul.
' Jika parameter ini tidak ada (hanya memiliki 1 parameter),
' kata "rupiah" ditampilkan.
'Modifik. : Bandung, 6 Mei 2003.
' - Membuat parameter "MataUang" yg bersifat opsional,
' untuk fungsi TerbilangInggris, di mana
' default-nya = "dollars". Jika parameter ini
' dikosongkan dengan "" maka kata "dollars" tidak muncul.
' Jika parameter ini tidak ada (hanya memiliki 1 parameter),
' kata "dollars" ditampilkan. Anda bisa mengganti
' dengan nama mata uang negara lain pada parameter
' kedua ini.
'Modifik. : Bandung, 14 Mei 2003
' - Mengatasi kemungkinan adanya nilai sen yang > 99
' atau memiliki digit pecahan lebih dari 2 digit,
' maka pecahan tersebut dibulatkan ke kelipatan
' terdekat sebanyak 2 digit.
' Contoh: TerbilangDesimal("20,599") ->
' menampilkan MataUang
' dibulatkan menjadi: 20,60 -> dibaca:
' "Dua Puluh Rupiah Enam Puluh Sen", BUKAN:
' "Dua Puluh Rupiah Enam Sen"
' Hal ini berlaku utk yg menampilkan MataUang.
' - Mengatasi kemungkinan jlh digit sen yang hanya 1 angka.
' maka pecahan tersebut harus ditambahkan dgn nol virtual.
' Contoh: TerbilangDesimal("20,5") -> menampilkan MataUang
' dibulatkan menjadi: 20,5 -> dibaca menjadi:
' "Dua Puluh Rupiah Lima Puluh Sen" dan BUKAN:
' "Dua Puluh Rupiah Lima Sen".
' Hal ini berlaku hanya yg menampilkan MataUang.
' - Menangani kemungkinan ejaan sen jika menggunakan
' mata uang rupiah, di mana nilai sen harus berada
' di antara mulai 1 dan 99. (Kemungkinan I)
' Contoh: TerbilangDesimal("20,99") dibaca:
' "Dua Puluh Rupiah Sembilan Puluh Sembilan Sen".
' - Menangani kemungkinan ejaan desimal tanpa menggunakan
' MataUang rupiah, di mana nilai desimal dieja per satu
' karakter. (Kemungkinan II)
' Contoh: TerbilangDesimal("20,99", "") dibaca;
' "Dua Puluh Koma Sembilan Sembilan")
' - Memeriksa kemungkinan adanya angka: 20,00
' seharusnya dibaca sebagai: "Dua Puluh Rupiah"
' dan BUKAN "Dua Puluh Rupiah Sen"
' Jika pemeriksaan berikut ini tidak ada, maka 20,00
' akan dibaca dengan: "Dua Puluh Rupiah Sen"
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 2 TextBox
' 2. Text1 untuk input dengan angka, Text2 menampilkan terbilang.
' 3. Copy-kan coding berikut ke dalam editor form yang bertalian.
'--------------------------------------------------------------------------
Public Function TerbilangDesimal(InputCurrency As String, _
Optional MataUang As String = "rupiah") As String
Dim strInput As String
Dim strBilangan As String
Dim strPecahan As String
On Error GoTo Pesan
Dim strValid As String, huruf As String * 1
Dim i As Integer
'Periksa setiap karakter yg diketikkan ke kotak UserID
strValid = "1234567890,"
For i% = 1 To Len(InputCurrency)
huruf = Chr(Asc(Mid(InputCurrency, i%, 1)))
If InStr(strValid, huruf) = 0 Then
Set AngkaTerbilang = Nothing
MsgBox "Harus karakter angka!", _
vbCritical, "Karakter Tidak Valid"
Exit Function
End If
Next i%
If InputCurrency = "" Then Exit Function
If Len(Trim(InputCurrency)) > 15 Then GoTo Pesan
strInput = CStr(InputCurrency) 'Konversi ke string
'Periksa apakah ada tanda "," jika ya berarti pecahan
If InStr(1, strInput, ",", vbBinaryCompare) Then
strBilangan = Left(strInput, InStr(1, strInput, ",", vbBinaryCompare) - 1)
'strBilangan = Right(strInput, InStr(1, strInput, ".", vbBinaryCompare) - 2)
strPecahan = Trim(Right(strInput, Len(strInput) - Len(strBilangan) - 1))
If MataUang <> "" Then
'Updated by Masino Sinaga, 14 Mei 2003, Bandung.....
'- Mengatasi kemungkinan adanya nilai sen yang > 99 atau
' memiliki digit pecahan lebih dari 2 digit, maka pecahan
' tersebut dibulatkan ke kelipatan terdekat sebanyak 2 digit.
' Contoh: TerbilangDesimal("20,599") -> menampilkan MataUang
' dibulatkan menjadi: 20,60 -> dibaca menjadi:
' "Dua Puluh Rupiah Enam Puluh Sen" dan BUKAN:
' "Dua Puluh Rupiah Enam Sen".
' Hal ini berlaku hanya yg menampilkan MataUang.
If CLng(Trim(strPecahan)) > 99 Then
strInput = Format(Round(CDbl(strInput), 2), "#0.00")
strPecahan = Format((Right(strInput, Len(strInput) - Len(strBilangan) - 1)), "00")
End If
'Update by Masino Sinaga, 14 Mei 2003, Bandung......
'- Mengatasi kemungkinan jumlah digit sen yang hanya 1 angka.
' maka pecahan tersebut harus ditambahkan dengan nol virtual.
' Contoh: TerbilangDesimal("20,5") -> menampilkan MataUang
' dibulatkan menjadi: 20,5 -> dibaca menjadi:
' "Dua Puluh Rupiah Lima Puluh Sen" dan BUKAN:
' "Dua Puluh Rupiah Lima Sen".
' Hal ini berlaku hanya yg menampilkan MataUang.
If Len(Trim(strPecahan)) = 1 Then
strInput = Format(Round(CDbl(strInput), 2), "#0.00")
strPecahan = Format((Right(strInput, Len(strInput) - Len(strBilangan) - 1)), "00")
End If
'Yang ini ditutup, untuk memperbaiki ejaan sesudah tanda
'koma (pecahan)...
'TerbilangDesimal = (KonversiBilangan(strBilangan) & "koma " & KonversiBilangan(strPecahan) & "rupiah")
'Updated by Masino Sinaga, 2 Mei 2003, Bandung.....
'-------------------------------------------------------
'- Membetulkan ejaan untuk bilangan setelah tanda koma,
' sebelumnya menggunakan KonversiBilangan, kini memakai
' KonversiPecahan (setiap 1 angka dibaca satu per satu)
'- Membuat parameter "MataUang" yg bersifat opsional,
' di mana default-nya = "rupiah". Jika parameter ini
' dikosongkan dengan "" maka kata "rupiah" tidak muncul.
'Updated by Masino Sinaga, 14 Mei 2003, Bandung.....
'- Menangani kemungkinan ejaan sen jika menggunakan
' mata uang rupiah, di mana nilai sen harus di antara
' mulai 1 dan 99. (Kemungkinan I)
' Contoh: TerbilangDesimal("20,99")
' "Dua Puluh Rupiah Sembilan Puluh Sembilan Sen".
'- Menangani kemungkinan ejaan desimal tanpa menggunakan
' mata uang rupiah, di mana nilai desimal dieja per satu
' karakter. (Kemungkinan II)
' Contoh: TerbilangDesimal("20,99", "")
' "Dua Puluh Koma Sembilan Sembilan")
'BANDINGKAN Kemungkinan I dan Kemungkinan II...
'MULAI PERIKSA >>>>>>
'Jika tanpa parameter MataUang (default), berarti akan
'menampilkan kata "Rupiah" dan perhatikan pula penanganan
'ejaan untuk sen. Lihat contoh Kemungkinan I di atas...
'Periksa lagi kemungkinan adanya angka: 20,00
'seharusnya: "Dua Puluh Rupiah"
' dan BUKAN "Dua Puluh Rupiah Sen"
'Jika pemeriksaan berikut ini tidak ada, maka 20,00
'akan dibaca dengan: "Dua Puluh Rupiah Sen"
If CLng(Trim(strPecahan)) = 0 Then
TerbilangDesimal = (KonversiBilangan(strBilangan) & MataUang & " " & KonversiBilangan(strPecahan))
Else
TerbilangDesimal = (KonversiBilangan(strBilangan) & MataUang & " " & KonversiBilangan(strPecahan) & "sen")
End If
Else
TerbilangDesimal = (KonversiBilangan(strBilangan) & "koma " & KonversiPecahan(strPecahan))
End If
Else
TerbilangDesimal = (KonversiBilangan(strInput))
End If
Exit Function
Pesan:
TerbilangDesimal = "(maksimal 15 digit)"
End Function
'Fungsi ini untuk mengkonversi nilai pecahan (setelah angka 0)
Private Function KonversiPecahan(strAngka As String) As String
Dim i%, strJmlHuruf$, Urai$, Kar$
If strAngka = "" Then Exit Function
strJmlHuruf = Trim(strAngka)
Urai = ""
Kar = ""
For i = 1 To Len(strJmlHuruf)
'Tampung setiap satu karakter ke Kar
Kar = Mid(strAngka, i, 1)
Urai = Urai & Kata(CInt(Kar))
Next i
KonversiPecahan = Urai
End Function
'Fungsi ini untuk menterjemahkan setiap satu angka ke kata
Private Function Kata(angka As Byte) As String
Select Case angka
Case 1: Kata = "satu "
Case 2: Kata = "dua "
Case 3: Kata = "tiga "
Case 4: Kata = "empat "
Case 5: Kata = "lima "
Case 6: Kata = "enam "
Case 7: Kata = "tujuh "
Case 8: Kata = "delapan "
Case 9: Kata = "sembilan "
Case 0: Kata = "nol "
End Select
End Function
'Ini untuk mengkonversi nilai bilangan sebelum pecahan
Private Function KonversiBilangan(strAngka As String) As String
Dim strJmlHuruf$, intPecahan As Integer, strPecahan$, Urai$, Bil1$, strTot$, Bil2$
Dim X, Y, z As Integer
If strAngka = "" Then Exit Function
strJmlHuruf = Trim(strAngka)
X = 0
Y = 0
Urai = ""
While (X < Len(strJmlHuruf))
X = X + 1
strTot = Mid(strJmlHuruf, X, 1)
Y = Y + Val(strTot)
z = Len(strJmlHuruf) - X + 1
Select Case Val(strTot)
'Case 0
' Bil1 = "NOL "
Case 1
If (z = 1 Or z = 7 Or z = 10 Or z = 13) Then
Bil1 = "satu "
ElseIf (z = 4) Then
If (X = 1) Then
Bil1 = "se"
Else
Bil1 = "satu "
End If
ElseIf (z = 2 Or z = 5 Or z = 8 Or z = 11 Or z = 14) Then
X = X + 1
strTot = Mid(strJmlHuruf, X, 1)
z = Len(strJmlHuruf) - X + 1
Bil2 = ""
Select Case Val(strTot)
Case 0
Bil1 = "sepuluh "
Case 1
Bil1 = "sebelas "
Case 2
Bil1 = "dua belas "
Case 3
Bil1 = "tiga belas "
Case 4
Bil1 = "empat belas "
Case 5
Bil1 = "lima belas "
Case 6
Bil1 = "enam belas "
Case 7
Bil1 = "tujuh belas "
Case 8
Bil1 = "delapan belas "
Case 9
Bil1 = "sembilan belas "
End Select
Else
Bil1 = "se"
End If
Case 2
Bil1 = "dua "
Case 3
Bil1 = "tiga "
Case 4
Bil1 = "empat "
Case 5
Bil1 = "lima "
Case 6
Bil1 = "enam "
Case 7
Bil1 = "tujuh "
Case 8
Bil1 = "delapan "
Case 9
Bil1 = "sembilan "
Case Else
Bil1 = ""
End Select
If (Val(strTot) > 0) Then
If (z = 2 Or z = 5 Or z = 8 Or z = 11 Or z = 14) Then
Bil2 = "puluh "
ElseIf (z = 3 Or z = 6 Or z = 9 Or z = 12 Or z = 15) Then
Bil2 = "ratus "
Else
Bil2 = ""
End If
Else
Bil2 = ""
End If
If (Y > 0) Then
Select Case z
Case 4
Bil2 = Bil2 + "ribu "
Y = 0
Case 7
Bil2 = Bil2 + "juta "
Y = 0
Case 10
Bil2 = Bil2 + "milyar "
Y = 0
Case 13
Bil2 = Bil2 + "trilyun "
Y = 0
End Select
End If
Urai = Urai + Bil1 + Bil2
Wend
KonversiBilangan = Urai
End Function
Private Sub Text1_Change() 'Isi besar uang diulangi dengan terbilang huruf...
Text2.Text = TerbilangDesimal(Text1.Text)
End Sub ********************************************************************************
********************************************************************************
Terbilang Desimal Inggris |
'Deskripsi: Menampilkan tulisan terbilang dengan bahasa Inggeris dari
' besar uang yang dimasukkan ke dalam textbox. Besar uang
' yang dimasukkan dapat dipisahkan dengan separator koma
' (setting Indonesia) atau titik (setting Inggris) untuk
' menyatakan "sen" (cent).
'Pembuat : (Dari berbagai sumber); disarikan oleh Masino Sinaga
' (masino_sinaga@posindonesia.co.id).
'Persiapan: 1. Buat 1 Project baru dengan 1 Form, 1 TextBox, dan 1 Label
' 2. Beri nama textbox dengan txtAngka, dan label lblTerbilang.
' 3. Copy-kan coding berikut ke dalam editor form yang bertalian.
'--------------------------------------------------------------------------
Private Function SpellDigit(strNumeric As Integer)
Dim cRet As String
On Error GoTo Pesan
cRet = ""
Select Case strNumeric
Case 0: cRet = " zero"
Case 1: cRet = " one"
Case 2: cRet = " two"
Case 3: cRet = " three"
Case 4: cRet = " four"
Case 5: cRet = " five"
Case 6: cRet = " six"
Case 7: cRet = " seven"
Case 8: cRet = " eight"
Case 9: cRet = " nine"
Case 10: cRet = " ten"
Case 11: cRet = " eleven"
Case 12: cRet = " twelve"
Case 13: cRet = " thirteen"
Case 14: cRet = " fourteen"
Case 15: cRet = " fifteen"
Case 16: cRet = " sixteen"
Case 17: cRet = " seventeen"
Case 18: cRet = " eighteen"
Case 19: cRet = " ninetieen"
Case 20: cRet = " twenty"
Case 30: cRet = " thirty"
Case 40: cRet = " fourthy"
Case 50: cRet = " fifty"
Case 60: cRet = " sixty"
Case 70: cRet = " seventy"
Case 80: cRet = " eighty"
Case 90: cRet = " ninety"
Case 100: cRet = " one hundred"
Case 200: cRet = " two hundred"
Case 300: cRet = " three hundred"
Case 400: cRet = " four hundred"
Case 500: cRet = " five hundred"
Case 600: cRet = " six hundred"
Case 700: cRet = " seven hundred"
Case 800: cRet = " eight hundred"
Case 900: cRet = " nine hundred"
End Select
SpellDigit = cRet
Exit Function
Pesan:
SpellDigit = "(maksimal 9 digit)"
End Function
Private Function SpellUnit(strNumeric As Integer)
Dim cRet As String
Dim n100 As Integer
Dim n10 As Integer
Dim n1 As Integer
On Error GoTo Pesan
cRet = ""
n100 = Int(strNumeric / 100) * 100
n10 = Int((strNumeric - n100) / 10) * 10
n1 = (strNumeric - n100 - n10)
If n100 > 0 Then
cRet = SpellDigit(n100)
End If
If n10 > 0 Then
If n10 = 10 Then
cRet = cRet & SpellDigit(n10 + n1)
Else
cRet = cRet & SpellDigit(n10)
End If
End If
If n1 > 0 And n10 <> 10 Then
cRet = cRet & SpellDigit(n1)
End If
SpellUnit = cRet
Exit Function
Pesan:
SpellUnit = "(maksimal 9 digit)"
End Function
Public Function TerbilangInggris(strNumeric As String) As String
Dim cRet As String
Dim n1000000 As Long
Dim n1000 As Long
Dim n1 As Integer
Dim n0 As Integer
On Error GoTo Pesan
Dim strValid As String, huruf As String * 1
Dim i As Integer
'Periksa setiap karakter masukan
strValid = "1234567890.,"
For i% = 1 To Len(strNumeric)
huruf = Chr(Asc(Mid(strNumeric, i%, 1)))
If InStr(strValid, huruf) = 0 Then
MsgBox "Harus karakter angka!", _
vbCritical, "Karakter Tidak Valid"
Exit Function
End If
Next i%
If strNumeric = "" Then Exit Function
If Len(Trim(strNumeric)) > 9 Then GoTo Pesan
cRet = ""
n1000000 = Int(strNumeric / 1000000) * 1000000
n1000 = Int((strNumeric - n1000000) / 1000) * 1000
n1 = Int(strNumeric - n1000000 - n1000)
n0 = (strNumeric - n1000000 - n1000 - n1) * 100
If n1000000 > 0 Then
cRet = SpellUnit(n1000000 / 1000000) & " million"
End If
If n1000 > 0 Then
cRet = cRet & SpellUnit(n1000 / 1000) & " thousand"
End If
If n1 > 0 Then
cRet = cRet & SpellUnit(n1)
End If
If n0 > 0 Then
cRet = cRet & " and cents" & SpellUnit(n0)
End If
TerbilangInggris = cRet & " only"
Exit Function
Pesan:
TerbilangInggris = "(maximum 9 digit)"
End Function
Private Sub txtAngka_Change()
lblTerbilang.Caption = TerbilangInggris(txtAngka.Text)
End Sub
********************************************************************************
********************************************************************************
Mengubah Warna Latar Teks di ListView |
'Deskripsi: Mengubah warna latar teks di ListView
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Rabu, 22 Mei 2002
'Persiapan: 1. Buat 1 Project baru dengan 1 Form, 1 Module, dan
' 1 ListView.
' 2. ListView dapat Anda ambil dari component bernama
' "Microsoft Windows Common Controls 5.0 (SP2)" dengan
' cara klik kanan di Toolbox lalu pilih component tsb.
' 3. Copy-kan coding berikut ke dalam editor form & module ybt.
'-------------------------------------------------------------------------
'--- Coding ini di Module...
Public Const LVM_FIRST As Long = &H1000
Public Const LVM_SETTEXTBKCOLOR As Long = (LVM_FIRST + 38)
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
'--- Akhir coding di Module...
'--- Coding ini di Form...
Private Sub Form_Load()
ListView1.ListItems.Add , , "Hello, Masino Sinaga....."
Call SendMessage(ListView1.hwnd, LVM_SETTEXTBKCOLOR, 0&, vbGreen)
End Sub
'--- Akhir coding di Form... *****************************************************************************
*****************************************************************************
Multiline Tooltip Gaya Balon |
'Deskripsi: Menampilkan "multiline-tooltip" dengan gaya balon.
' Selama ini, Visual Basic hanya dapat menampilkan
' tooltip pada suatu control sebanyak 1 baris saja.
' Walaupun Anda menambahkan karakter VbCrLf pada
' string di tooltip tersebut, hal ini tidak akan
' menampilkan tooltip dengan multiline di VB standar.
' Untuk melihat tooltip yang multiline, tempatkan
' pointer mouse Anda di atas tombol Command1.
' Bandingkan tooltip standar VB pada tombol Command2.
'Pembuat : Sheppe Pharis (sheppe@home.com);
' Diterjemahkan dan dimodifikasi oleh:
' Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Rabu, 14 Mei 2003
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 2 Commanbutton.
' 2. Copy-kan coding berikut ke dalam editor form ybt.
'-------------------------------------------------------------------
Option Explicit
'Pemanggilan fungsi API diperlukan untuk membuat dan menghancurkan
'tooltip di Sistem Operasi Windows.
Private Declare Function CreateWindowEx Lib "user32" _
Alias "CreateWindowExA" (ByVal dwExStyle As Long, _
ByVal lpClassName As String, ByVal lpWindowName As String, _
ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As Long, ByVal hMenu As Long, _
ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) _
As Long
Private Declare Function GetClientRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function DestroyWindow Lib "user32" _
(ByVal hwnd As Long) As Long
'UDT (User Defined Type) RECT.
'Digunakan untuk pengaturan batas dari jendela tooltip.
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'UDT TOOLINFO.
'Digunakan untuk menentukan semua tanda yang diperlukan
'untuk membuat jendela tooltip.
Private Type TOOLINFO
cbSize As Long
uFlags As Long
hwnd As Long
uid As Long
RECT As RECT
hinst As Long
lpszText As String
lParam As Long
End Type
'Sebuah konstanta yang digunakan untuk menghubungkan
'ke fungsi API yang bernama: CreateWindowEx.
'Hal ini untuk menandakan nilai default yang digunakan.
Private Const CW_USEDEFAULT = &H80000000
'Konstanta untuk fungsi API bernama: SetWindowPosition.
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOSIZE = &H1
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1
Private Const HWND_BOTTOM = 1
'Konstanta untuk menentukan gaya dari jendela tooltip.
Private Const WS_POPUP = &H80000000
Private Const WS_EX_TOPMOST = &H8&
'Konstanta yang digunakan dengan fungsi API SendMessage
'untuk mendefinisikan pesan private.
Private Const WM_USER = &H400
'Messages yang digunakan untuk menentukan durasi waktu dari tooltips.
'Tidak digunakan di sini.
Private Const TTDT_AUTOMATIC = 0
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
Private Const TTDT_RESHOW = 1
'Semua "penanda" untuk jendela tooltip.
Private Const TTF_ABSOLUTE = &H80
Private Const TTF_CENTERTIP = &H2
Private Const TTF_DI_SETITEM = &H8000
Private Const TTF_IDISHWND = &H1
Private Const TTF_RTLREADING = &H4
Private Const TTF_SUBCLASS = &H10
Private Const TTF_TRACK = &H20
Private Const TTF_TRANSPARENT = &H100
'Semua pesan yang tersedia untuk tooltip Windows.
Private Const TTM_ACTIVATE = (WM_USER + 1)
Private Const TTM_ADDTOOLA = (WM_USER + 4)
Private Const TTM_ADDTOOLW = (WM_USER + 50)
Private Const TTM_ADJUSTRECT = (WM_USER + 31)
Private Const TTM_DELTOOLA = (WM_USER + 5)
Private Const TTM_DELTOOLW = (WM_USER + 51)
Private Const TTM_ENUMTOOLSA = (WM_USER + 14)
Private Const TTM_ENUMTOOLSW = (WM_USER + 58)
Private Const TTM_GETBUBBLESIZE = (WM_USER + 30)
Private Const TTM_GETCURRENTTOOLA = (WM_USER + 15)
Private Const TTM_GETCURRENTTOOLW = (WM_USER + 59)
Private Const TTM_GETDELAYTIME = (WM_USER + 21)
Private Const TTM_GETMARGIN = (WM_USER + 27)
Private Const TTM_GETMAXTIPWIDTH = (WM_USER + 25)
Private Const TTM_GETTEXTA = (WM_USER + 11)
Private Const TTM_GETTEXTW = (WM_USER + 56)
Private Const TTM_GETTIPBKCOLOR = (WM_USER + 22)
Private Const TTM_GETTIPTEXTCOLOR = (WM_USER + 23)
Private Const TTM_GETTOOLCOUNT = (WM_USER + 13)
Private Const TTM_GETTOOLINFOA = (WM_USER + 8)
Private Const TTM_GETTOOLINFOW = (WM_USER + 53)
Private Const TTM_HITTESTA = (WM_USER + 10)
Private Const TTM_HITTESTW = (WM_USER + 55)
Private Const TTM_NEWTOOLRECTA = (WM_USER + 6)
Private Const TTM_NEWTOOLRECTW = (WM_USER + 52)
Private Const TTM_POP = (WM_USER + 28)
Private Const TTM_RELAYEVENT = (WM_USER + 7)
Private Const TTM_SETDELAYTIME = (WM_USER + 3)
Private Const TTM_SETMARGIN = (WM_USER + 26)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Private Const TTM_SETTITLEA = (WM_USER + 32)
Private Const TTM_SETTITLEW = (WM_USER + 33)
Private Const TTM_SETTOOLINFOA = (WM_USER + 9)
Private Const TTM_SETTOOLINFOW = (WM_USER + 54)
Private Const TTM_TRACKACTIVATE = (WM_USER + 17)
Private Const TTM_TRACKPOSITION = (WM_USER + 18)
Private Const TTM_UPDATE = (WM_USER + 29)
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTM_UPDATETIPTEXTW = (WM_USER + 57)
Private Const TTM_WINDOWFROMPOINT = (WM_USER + 16)
'Konstanta untuk menentukan gaya dari jendela tooltip.
'
'Selalu tip, walalupun jika jendela utama tidak aktif.
Private Const TTS_ALWAYSTIP = &H1
'
'Menggunakan gaya balon tooltip.
Private Const TTS_BALLOON = &H40
'
'Win98 and up - jangan gunakan sliding tooltips.
Private Const TTS_NOANIMATE = &H10
'
'Win2K and up - jangan hilangkan tooltips.
Private Const TTS_NOFADE = &H20
'
'Mencegah Windows dari penghapusan karakter ampersand apapun di dalam
'string tooltip. Tanpa penanda ini, Windows otomatis akan menghapus
'karakter ampersand dari string tersebut.
'Hal ini dilakukan untuk mengizinkan string yang sama dapat digunakan
'sebagai teks dari tooltip, dan sebagai tulisan dari sebuah control.
Private Const TTS_NOPREFIX = &H2
'Class untuk dua tooltip yang berbeda.
Private Const TOOLTIPS_CLASS = "tooltips_class"
Private Const TOOLTIPS_CLASSA = "tooltips_class32"
'Sebuah variabel bertipe Long untuk menyimpan hwnd (window handle)
'dari jendela tooltip yang dibuat di contoh ini.
'Hal ini akan menjadi sebuah array bertipe Long jika kita membuat
'tooltip Windows untuk banyak control atau banyak jendela.
Dim hwndTT As Long
'Event Code. Untuk mencoba coding ini, yakinkan sekali lagi bahwa
'di form Anda sudah ada 2 tombol bernama "Command1" dan
'"Command2"
Private Sub Form_Load()
'Deklarasikan sebuah variabel bertipe UDT TOOLINFO.
Dim ti As TOOLINFO
'Variabel ini digunakan untuk menandakan batas dari jendela tooltip
Dim RECT As RECT
'Untuk melewatkan toolinfo UDT sebagai sebuah ID untuk jendela tooltip.
'Tidak melakukan apapun di contoh ini, untuk menjelaskan saja.
Dim uid As Long
uid = 0
'Sebuah string yang akan ditampilkan di dalam tooltip.
Dim strPntr As String
strPntr = "Inilah tooltip yang dibuat dengan menggunakan fungsi API. " & vbCrLf & _
"Seperti yang dapat Anda lihat, dia kini mendukung banyak baris, " & vbCrLf & _
"pindah baris, menampilkan batas atau jendela tooltip bergaya balon, " & vbCrLf & _
"serta dapat menampilkan warna latar dan huruf sesuai keinginan."
'Nilai yang dikembalikan saat pemanggilan fungsi API.
Dim RetVal As Long
'Buat sebuah jendela tooltip, dan tangani hwnd-nya di dalam
'lebar form hwndTT yang bertipe Long.
hwndTT = CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASSA, _
vbNullString, _
WS_POPUP Or TTS_NOPREFIX Or TTS_BALLOON, _
CW_USEDEFAULT, CW_USEDEFAULT, _
CW_USEDEFAULT, CW_USEDEFAULT, _
Me.hwnd, 0, App.hInstance, 0)
'Gunakan fungsi API setwindowpos untuk menentukan posisi jendela
'dari tooltip.
SetWindowPos hwndTT, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE
'Mendeteksi batas control yang tooltipnya sedang ditambahkan.
'Ini akan menjadi batas untuk mengaktifkan jendela tooltip.
GetClientRect Command1.hwnd, RECT
'Tentukan semua informasi yang diperlukan untuk toolinfo UDT.
'
'Ukuran UDT toolinfo dalam bytes. Harus di-set!
ti.cbSize = Len(ti)
'
'Penanda yang akan kita lewatkan untuk tooltip.
'TTF_CENTERTIP tidak perlu, tapi tengahkan tooltip ke jendela
'di mana tooltip sedang diaplikasikan (jika memungkinkan).
'TTF_SUBCLASS memberitahukan ke jendela tooltip window untuk meng-
'sub-class jendela yang sedang diaplikasikan. Ini cara terbaik di
'VB, jadi subclassing oleh pengembang tidak diperlukan.
ti.uFlags = TTF_CENTERTIP Or TTF_SUBCLASS
'
'hwnd dari control yang tooltipnya sedang diaplikasikan.
ti.hwnd = Command1.hwnd
'
'Instansiasi dari aplikasi yang tooltip-nya sedang diaplikasikan.
ti.hinst = App.hInstance
'
'ID (hwnd) dari jendela tooltip. Tidak diperlukan kecuali
'jendela dibuat dengan menggunakan penanda TTF_IDISHWND.
ti.uid = uid
'
'Sebuah pointer ke tooltip.
ti.lpszText = strPntr
'
'Koordinat yang menentukan batas jendela tooltip ketika aktif.
ti.RECT.Left = RECT.Left
ti.RECT.Top = RECT.Top
ti.RECT.Right = RECT.Right
ti.RECT.Bottom = RECT.Bottom
'Kirim sebuah pesan ke jendela tooltip untuk menampilkan tooltip
'pada control yang sedang diaplikasikan.
RetVal = SendMessage(hwndTT, TTM_ADDTOOLA, 0, ti)
'Kirim sebuah pesan ke jendela tooltip untuk menentukan lebar maksimum
'agar dapat mendukung pindah baris (line-breaking).
RetVal = SendMessage(hwndTT, TTM_SETMAXTIPWIDTH, 0, 80)
'Kirim pesan ke jendela tooltip untuk menentukan warna latar balon
'dan warna huruf. Dalam hal ini, kita menggunakan fungsi warna RGB
'RetVal = SendMessage(hwndTT, TTM_SETTIPBKCOLOR, RGB(255, 255, 255), 0)
'Coba ganti warna latar dengan hijau muda...
RetVal = SendMessage(hwndTT, TTM_SETTIPBKCOLOR, &HC0FFC0, 0)
'RetVal = SendMessage(hwndTT, TTM_SETTIPTEXTCOLOR, RGB(0, 0, 150), 0)
'Coba ganti warna huruf tooltip dengan warna biru
RetVal = SendMessage(hwndTT, TTM_SETTIPTEXTCOLOR, vbBlue, 0)
'Kirim sebuah pesan ke jendela tooltip untuk mengupdate dirinya.
'(Jika ada warna latar dan huruf yang baru).
RetVal = SendMessage(hwndTT, TTM_UPDATETIPTEXTA, 0, ti)
'Tentukan teks dari tombol kedua untuk menampilkan tooltip standar
'milik Visual Basic (tidak mendukung multi-line).
Command2.ToolTipText = "Inilah tooltip standar VB. " _
& vbCrLf & "Seperti yang Anda lihat, karakter CrLf di sebelah kiri " _
& "baris ini tidak berfungsi di sini. " & vbCrLf & _
"Karakter VbCrLf ditandai dengan garis dua tebal vertikal"
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Ketika form unload, yakinkan bahwa tooltip yang dibuat
'dihancurkan (dibebaskan dari memory)
DestroyWindow hwndTT
End Sub *******************************************************************************
*******************************************************************************
Keluar Otomatis Bila Program Tidak Aktif |
'Deskripsi: Memeriksa apakah aplikasi sedang digunakan atau
' tidak. Jika tidak sedang digunakan selama sekian
' detik, maka aplikasi langsung keluar. Di contoh ini
' untuk mendeteksi apakah aplikasi mengalami suatu
' aktivitas atau tidak adalah melalui event procedure
' Form_MouseMove(...). Jika ada pergerakan mouse di
' atas form ybt, maka aplikasi dinyatakan aktif atau
' sedang digunakan (seperti ScreenSaver Windows).
' Anda bisa menambahkan bukan hanya pada MouseMove
' saja, tapi pada penekanan tombol lainnya...
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Hari/Tgl : Selasa, 27 Agustus 2002
'Persiapan: 1. Buat 1 project baru dengan 1 form.
' 2. Tambahkan 1 Timer dan 2 Textbox
' 3. Copy-kan source code ini ke dalam editor form ybt
'----------------------------------------------------------------
Dim awal As Date
Dim Gerak As Boolean
Dim Aksi As Boolean
Private Sub Form_Load()
'Inisialisasi semua variabel dan Timer
Gerak = False
Aksi = False
Timer1.Interval = 500
Timer1.Enabled = True
awal = Time
End Sub
Private Sub Form_MouseMove(Button As Integer, _
Shift As Integer, _
X As Single, Y As Single)
'Jika ada pergerakan mouse di form, set waktu mulai
'utk perhitungan durasi dengan waktu saat itu
awal = Time
'Update status...
Aksi = True
End Sub
Private Sub Timer1_Timer()
Dim durasi As Date
Aksi = False
'Periksa...
If Aksi = False Then
Gerak = False
Timer1.Enabled = True
Else 'Jika ada perubahan di Mouse_Move
Gerak = True
Timer1.Enabled = False
End If
Text1.Text = awal
Text2.Text = Time
'Jika tidak ada pergerakan, aktifkan perhitungan durasi
If Gerak = False Then
durasi = Time - awal
'Dalam contoh ini, jika 5 detik aplikasi tidak
'mengalami kegiatan, maka langsung keluar...
If Format(durasi, "hh:mm:ss") = "00:00:05" Then
'Sebelum keluar, bebaskan semua variabel di form ini
Set Form1 = Nothing
Unload Me
End If
End If
End Sub *******************************************************************************
*******************************************************************************
Menyembunyikan Program dari TaskList |
'Deskripsi: Menyembunyikan program Anda dari daftar TaskList
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 2 Commandbutton.
' 2. Copy-kan coding berikut ke dalam editor form yang bertalian.
'--------------------------------------------------------------------------
'Tekan tombol yang pertama untuk menyembunyikan program Anda
'dan tombol kedua untuk menampilkannya lagi di daftar TaskList
'Untuk memeriksa apakah program Anda ada atau tidak di daftar
'TaskList, coba tekan tombol Ctrl+Alt+Del di keyboard, lalu
'lihat pada daftar yang muncul...
'--- Coding ini di Module...
Public Const RSP_SIMPLE_SERVICE = 1
Public Const RSP_UNREGISTER_SERVICE = 0
Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Declare Function RegisterServiceProcess Lib "kernel32" (ByVal dwProcessID _
As Long, ByVal dwType As Long) As Long
'--- Akhir coding di Module...
'-- Coding ini di Form...
Public Sub HideApp(Hide As Boolean)
Dim ProcessID As Long
ProcessID = GetCurrentProcessId()
If Hide Then
retval = RegisterServiceProcess(ProcessID, RSP_SIMPLE_SERVICE)
Else
retval = RegisterServiceProcess(ProcessID, RSP_UNREGISTER_SERVICE)
End If
End Sub
Private Sub Command1_Click()
HideApp (True)
End Sub
Private Sub Command2_Click()
HideApp (False)
End Sub
'--- Akhir coding di Form... ******************************************************************************
******************************************************************************
Menampilkan Windows Explorer dalam ListBox |
'Deskripsi: Menampilkan Windows Explorer dalam satu ListBox saja!
' Anda dapat berpindah antar drive, direktori, dan memilih
' file melalui ListBox ini saja.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Jumat, 10 Mei 2002
'Persiapan: 1. Buat 1 Project baru dengan 1 Form, 1 ListBox, 1 DriveListBox,
' 1 DirListBox, 1 FileListBox, dan 1 Label.
' 2. Copy-kan coding berikut ke dalam editor form yang bertalian.
------------------------------------------------------------------------------
Function StripPath(T$) As String
Dim x%, ct%
StripPath$ = T$
x% = InStr(T$, "")
Do While x%
ct% = x%
x% = InStr(ct% + 1, T$, "")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function
Sub UpdatePath()
Dim I, D, J, K As Integer
For D = 0 To List1.ListCount - 1
List1.RemoveItem "0"
Next D
If Not Right(Dir1.List(-1), 1) = "" Then
List1.AddItem "[^] .."
End If
For I = 0 To Dir1.ListCount - 1
List1.AddItem "[] " & StripPath(Dir1.List(I))
Next I
For J = 0 To File1.ListCount - 1
List1.AddItem "[*] " & File1.List(J)
Next J
For K = 0 To Drive1.ListCount - 1
List1.AddItem "[o] " & Drive1.List(K)
Next K
Label1.Caption = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
UpdatePath
End Sub
Private Sub Form_Load()
Drive1.Visible = False
File1.Visible = False
Dir1.Visible = False
UpdatePath
Me.Move (Screen.Width - Me.Width) / 2, _
(Screen.Height - Me.Height) / 2
End Sub
Private Sub List1_DblClick()
On Error GoTo ErrHdlr
If Right(List1.Text, 2) = ".." Then
Dir1.Path = Dir1.Path & ".."
ElseIf Left(List1.Text, 3) = "[]" Then
If Right(Dir1.List(-1), 1) = "" Then
Dir1.Path = Dir1.Path & _
Right(List1.Text, Len(List1.Text) - 4)
Else
Dir1.Path = Dir1.Path & _
"" & Right(List1.Text, _
Len(List1.Text) - 4)
End If
ElseIf Left(List1.Text, 3) = "[o]" Then
Drive1.Drive = Right(Left(List1.Text, 6), 2)
Else
MsgBox "File " & Chr(34) & _
Right(List1.Text, Len(List1.Text) - 4) & _
Chr(34) & " dipilih.", _
vbInformation, "File Terpilih"
End If
Exit Sub
ErrHdlr:
MsgBox "Drive tidak siap!", vbCritical, "Tidak Siap"
Exit Sub
End Sub ******************************************************************************
******************************************************************************
Component TrueDBGrid7 |
| Nama File | Deskripsi/Petunjuk Download | Tanggal Upload |
| TrueDBGrid7B_Eval001.zip Ukuran: 398 KB | Component TrueDBGrid7 merupakan component yang dapat Anda gunakan di project VB Anda untuk menampilkan data ke grid (seperti DBGrid) dan memiliki banyak fitur-fitur menarik, seperti: dapat menampilkan combobox, checkbox, optionbutton, gambar/image, multi-row, dan masih banyak lagi ke dalam grid yang bertalian. Karena banyaknya permintaan rekan-rekan di mailing-list Indoprog-VB agar menaruh file ini di situs saya, maka saya memecah-mecah file ini (SPLIT) sebelum meng-upload-nya ke server brinkster.com mengingat peraturan yang ditetapkan di brinkster agar tidak mengupload file yang berukuran di atas 1 MB dan keterbatasan bandwith yang diberikan brinkster dalam satu hari (sekitar 16 MB), serta keterbatasan bandwith bagi Anda yang akan mendownload-nya. Jika saat Anda akan atau sedang mendownload file ini muncul pesan dari brinkster.com yang memberitahukan bahwa situs saya tidak dapat diakses sampai lewat tengah malam waktu mereka, itu berarti karena banyaknya pengunjung yang mengakses situs saya atau mendownload file-file yang terdapat di situs saya dan batas (limit) bandwith yang disediakan untuk situs saya sudah melampaui batas. Jangan kecewa. Anda bisa mencobanya lagi di lain kesempatan. Asli file ini hanya satu buah dan berukuran sekitar 7 MB yang saya download dari http://www.componentone.com. Jika Anda ingin langsung mendownload satu file tersebut, silahkan langsung ke web tersebut. Namun jika Anda ingin mendownload sebagian-sebagian, Anda tidak perlu ke web di atas, tapi cukup mendownload ke-14 file ini. Setelah semuanya Anda download, extract ke-14 file tersebut ke dalam satu folder. Untuk menggabungkan (JOIN) ke-14 file tersebut menjadi 1 file, Anda harus menggunakan software khusus bernama HJSplit Setelah Anda men-join ke-14 file tersebut, maka nanti akan terbentuk satu file yang bernama "TrueDBGrid7B_Eval.exe". Jalankan file ini untuk menginstall component ini ke PC Anda. Component ini masih "evaluation version" (30 hari). Agar Anda dapat bebas memakainya, Anda harus mengisi kode aktivasi. Klik di sini untuk mendownload file aktivasi tersebut. Setelah proses aktivasi selesai, Anda dapat menggunakan component ini secara "free-version". Anda dapat melihat contoh source code penggunaannya di dalam folder hasil penginstall-annya di PC Anda. | Sabtu, 17/08/2002 |
| TrueDBGrid7B_Eval002.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval003.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval004.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval005.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval006.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval007.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval008.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval009.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval010.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval011.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval012.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval013.zip Ukuran: 501 KB | Sabtu, 17/08/2002 | |
| TrueDBGrid7B_Eval014.zip Ukuran: 468 KB | Sabtu, 17/08/2002 |
******************************************************************************
******************************************************************************
Membuat Efek Ledakan pada Form |
'Deskripsi: Membuat suatu efek ledakan pada pemunculan awal suatu form.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 1 Module, dan 1 Commandbutton.
' 2. Copy-kan coding berikut ke dalam editor Module/Form ybt.
'----------------------------------------------------------------------------------
'--- Coding ini di Module...
#If Win16 Then
Type RECT
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
#Else
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#End If
#If Win16 Then
Declare Sub GetWindowRect Lib "User" (ByVal hwnd As Integer, lpRect As RECT)
Declare Function GetDC Lib "User" (ByVal hwnd As Integer) As Integer
Declare Function ReleaseDC Lib "User" (ByVal hwnd As Integer, ByVal hdc As _
Integer) As Integer
Declare Sub SetBkColor Lib "GDI" (ByVal hdc As Integer, ByVal crColor As Long)
Declare Sub Rectangle Lib "GDI" (ByVal hdc As Integer, ByVal X1 As Integer, _
ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer)
Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer
Declare Function SelectObject Lib "GDI" (ByVal hdc As Integer, ByVal hObject _
As Integer) As Integer
Declare Sub DeleteObject Lib "GDI" (ByVal hObject As Integer)
#Else
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, _
lpRect As RECT) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal _
hdc As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal _
crColor As Long) As Long
Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function SelectObject Lib "user32" (ByVal hdc As Long, ByVal hObject _
As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
#End If
Sub ExplodeForm(f As Form, Movement As Integer)
Dim myRect As RECT
Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
Dim TheScreen As Long
Dim Brush As Long
GetWindowRect f.hwnd, myRect
formWidth = (myRect.Right - myRect.Left)
formHeight = myRect.Bottom - myRect.Top
TheScreen = GetDC(0)
Brush = CreateSolidBrush(f.BackColor)
For i = 1 To Movement
Cx = formWidth * (i / Movement)
Cy = formHeight * (i / Movement)
X = myRect.Left + (formWidth - Cx) / 2
Y = myRect.Top + (formHeight - Cy) / 2
Rectangle TheScreen, X, Y, X + Cx, Y + Cy
Next i
X = ReleaseDC(0, TheScreen)
DeleteObject (Brush)
End Sub
Public Sub ImplodeForm(f As Form, Movement As Integer)
Dim myRect As RECT
Dim formWidth%, formHeight%, i%, X%, Y%, Cx%, Cy%
Dim TheScreen As Long
Dim Brush As Long
GetWindowRect f.hwnd, myRect
formWidth = (myRect.Right - myRect.Left)
formHeight = myRect.Bottom - myRect.Top
TheScreen = GetDC(0)
Brush = CreateSolidBrush(f.BackColor)
For i = Movement To 1 Step -1
Cx = formWidth * (i / Movement)
Cy = formHeight * (i / Movement)
X = myRect.Left + (formWidth - Cx) / 2
Y = myRect.Top + (formHeight - Cy) / 2
Rectangle TheScreen, X, Y, X + Cx, Y + Cy
Next i
X = ReleaseDC(0, TheScreen)
DeleteObject (Brush)
End Sub
'--- Batas coding di Module...
'--- Coding ini di Form...
Private Sub Command1_Click()
'Ganti '500' di bawah dengan kecepatan dari efek ledakan form.
Call ImplodeForm(Me, 500)
End
Set Form1 = Nothing
End Sub
Private Sub Form_Load()
Call ExplodeForm(Me, 500) 'ledakan form
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call ImplodeForm(Me, 500) 'pengembalian form
End Sub ******************************************************************************
******************************************************************************
Membuat Scrollbar Horizontal di ListBox |
'Deskripsi: Membuat scrollbar horizontal pada sebuah listbox yang di dalamnya
' terdapat data yang melebihi lebar dari listbox tersebut.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Persiapan: 1. Buat 1 Project baru dengan 1 ListBox.
' 2. Copy-kan coding berikut ke dalam editor form yang bertalian.
' 3. Jika Declare Function berikut ingin ditempatkan dalam
' suatu Module tersendiri, hapus kata "Private" sebelum
' "Declare Function..."
'--------------------------------------------------------------------------
Private Declare Function SendMessageByNum Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal _
wParam As Long, ByVal lParam As Long) As Long
Const LB_SETHORIZONTALEXTENT = &H194
Private Sub Form_Load()
Static x As Long
'Lebar string akan menjadi lebar dari horizontal scroll bar tsb
'Tambahkan suatu string yang panjangnya melebihi lebar dari scroll bar ybt.
List1.List(0) = "Selamat datang di Situs Masino Sinaga. Semoga Sukses Menyertai Anda Sekalian!"
If x < TextWidth(List1.List(0) & " ") Then
x = TextWidth(List1.List(0) & " ")
If ScaleMode = vbTwips Then x = x / Screen.TwipsPerPixelX
SendMessageByNum List1.hwnd, LB_SETHORIZONTALEXTENT, x, 0
End If
End Sub
******************************************************************************
******************************************************************************
Memeriksa Event KeyDown di Form |
'Deskripsi: Memeriksa event KeyDown, KeyPress, dan KeyUp di Form
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Diupload : Rabu, 15 Mei 2002
'Persiapan: 1. Buat 1 Project baru dengan 1 Form.
' 2. Copy-kan coding berikut ke editor form yang bertalian.
---------------------------------------------------------------------
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Dim msg As String
frmForm1.Cls
frmForm1.CurrentX = 100
frmForm1.CurrentY = 100
msg = "Mendapat event KeyDown. KeyCode = " & KeyCode
msg = msg & " Shift = " & Shift
frmForm1.Print msg
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
Dim msg As String
frmForm1.CurrentX = 100
frmForm1.CurrentY = 500
msg = "Mendapat event KeyPress. KeyAscii = " & KeyAscii
frmForm1.Print msg
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
Dim msg As String
frmForm1.CurrentX = 100
frmForm1.CurrentY = 900
msg = "Mendapat event KeyUp. KeyCode = " & KeyCode
msg = msg & " Shift = " & Shift
frmForm1.Print msg
End Sub
Private Sub Form_Load()
frmForm1.FontTransparent = False
End Sub *****************************************************************************
*****************************************************************************
Hanya Huruf Besar Boleh Dientri ke TextBox |
'Deskripsi: Hanya huruf besar yang ditampilkan/dientri ke textbox.
' Ada dua cara untuk menampilkan input data dengan huruf
' besar di suatu textbox.
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Persiapan: 1. Buat 1 Project baru dengan 1 Form dan 2 Textbox.
' 2. Copy-kan coding berikut ke dalam editor form yang bertalian.
'--------------------------------------------------------------------------
Private Sub Text1_Change() 'Text1 menggunakan event Change
Dim posisi As Integer
posisi = Text1.SelStart
Text1.Text = UCase(Text1.Text)
Text1.SelStart = posisi
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer) 'Text2 menggunakan KeyPress
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub ******************************************************************************
******************************************************************************
Label Kedap-kedip (Blank) |
'Deskripsi: Contoh penggunaan control Label dan Timer untuk menampilkan
' tulisan kedap-kedip di atas form Anda (blink).
'Pembuat : Masino Sinaga (masino_sinaga@posindonesia.co.id)
'Persiapan: 1. Buat satu proyek baru dengan 1 Form, 1 Label, dan 1 Timer
' 2. Copy-kan coding berikut ke dalam editor form yang bertalian.
'--------------------------------------------------------------------------
Dim i As Long 'Deklarasi
Dim merah, hijau, biru As Integer 'Variabel global
Private Sub Form_Load()
i = 0 'Inisialisasi detik
Timer1.Interval = 500 'Kalau 1000 biasanya lompat 1 detik
End Sub
Private Sub Timer1_Timer()
i = i + 1
If i = 1000000 Then i = 0 'Supaya tdk overflow, dsb...
merah = Int(255 * Rnd) 'Bangkitkan angka random untuk merah
hijau = Int(255 * Rnd) 'Bangkitkan angka random untuk hijau
biru = Int(255 * Rnd) 'Bangkitkan angka random untuk biru
Label1.ForeColor = RGB(merah, hijau, biru) 'Campur tiga warna
If i Mod 2 = 0 Then 'Jika counter habis dibagi 2
Label1.Visible = True 'Tampilkan label
Else 'Jika counter tidak habis dibagi 2
Label1.Visible = False 'Sembunyikan label
End If 'Akhir pemeriksaan
End Sub
Source code ini dicopi dari http://www30.brinkster.com/masinosinaga/labelblink.html
