BAB XVI SEPULUH PROGRAM MENARIK Pada pembahasan kali ini, saya mengajak Anda mencoba membuat seembilan program menarik menggunakan Visual Basic. Semua program dibuat pada template VB Enterprise Edition Control. Jadi saat Anda menjalankan Visual Basic, pilih tempate tersebut untuk memulai project baru. Diharapkan Anda sudah menguasai semua bahasan-bahasan sebelum bab ini.
16.1. Windows Explorer Program ini mencontoh aplikasi Windows Explorer, untuk menampilkan folder dan file pada komputer Anda.
a. Desain Form Buatlah folder baru di alamat: “C:\Menggali VB\Bab 16”, namai dengan “Explorer”. Pada form, sisipkan objek ImageList, namai dengan: imgMain. Klik kanan pada imgMain, pilih: 16 x 16, pada tab General. Klik tab Images, klik Insert Picture… Masukkan, 25 gambar ikon (ikon-ikon disediakan pada CD yang disertakan). Ubah nama Key dari tiap-tiap Image seperti pada table di bawah ini: Index 1 2 3 4 5 6 7 8 9 10 11 12 13
Key komputer ini inf mid wav bat exe dll imf txt jpg drivelepas doc
Index 14 15 16 17 18 19 20 21 22 23 24 25
Key xls mdb recycle filegeneric mp3 folder1 folder2 diska cdrom desktop disket diskanet
Catatan: Hati-hati dalam pemberian nama Key dari Image-Image pada ImageList. Perbedaan huruf besar dan huruf kecil sangat berpengaruh pada hasil bersifat (case sensitif). Sisipkan objek kontrol dan atur propertinya seperti pada table di bawah ini: Pengaturan Properti Pengaturan pada: Form1 No Objek Kontrol Properti Name 2 TreeView ImageList Name 3 ListView ImageList Name 4 RichTextBox Appearance ScrollBar Name 5 ProgressBar Scrolling
Perubahan tvwExplor imgMain lvwExplor imgMain rtbExplor 0-rtfFlat 3-rtfBoth pgbExplor 1-ccScrollingSmooth
Simpan semua komponen project di alamat: “C:\Menggali VB\Bab 16\Explorer”.
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
1
Gambar 16.1. Desain Form Explorer. Setelah desain form selesai, klik menu Project-References.... Pada dialog “References – Project1”, tandai kotak periksa dari list: “Microsoft Scripting Runtime”. Jika Anda tidak menemukan list ini, klik tombol Browse.... Pada dialog “Add References”, klik file: “scrrun.dll” (alamat menunjukkan direktori Windows\System atau Windows\System32). Klik Open.
b. Baris Kode Baris Kode Baris kode pada: Form1 1 Option Explicit ' 2 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 ' 3 Private ObjekFile As New FileSystemObject 4 Dim strPathX As String 5 Dim TwipsInHimetric! 6 Dim sPath As String ' 7 Private Sub Form_Load() 8 On Error Resume Next 9 Dim drvDrive As Drive 10 Dim strIkon As String 11 Dim strNama As String 12 Dim fldFolder As Folder 13 Dim fldDrive As Folder ' 14 TwipsInHimetric = ScaleX(1, vbTwips, _ vbHimetric) 15 For Each drvDrive In ObjekFile.Drives 16 If drvDrive.DriveType = CDRom Then 17 strIkon = "cdrom" 18 If drvDrive.IsReady Then 19 strNama = drvDrive.VolumeName 20 Else: strNama = "CD-ROM" 21 End If 22 ElseIf drvDrive.DriveType = Fixed Then 23 strIkon = "diska" 24 If drvDrive.IsReady Then 25 strNama = drvDrive.VolumeName 26 Else: strNama = "Hard Drive" 27 End If 28 ElseIf drvDrive.DriveType = Remote Then 29 strIkon = "diskanet" 30 If drvDrive.IsReady Then 31 strNama = drvDrive.ShareName 32 Else: strNama = "Network Drive" 33 End If 34 ElseIf drvDrive.DriveType = Removable _ Then 35 If drvDrive.DriveLetter = "A" Or _ drvDrive.DriveLetter = "B" Then 36 strIkon = "disket" Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
2
37 38 39 20 21 22 23 24 25 26 27 28 29 30 31 32 33
34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
Else: strIkon = "drivelepas" End If If drvDrive.IsReady Then strNama = drvDrive.VolumeName Else If drvDrive.DriveLetter = "A" Or _ drvDrive.DriveLetter = "B" Then strNama = "Floppy Drive" Else: strNama = "Drive Lepas" End If End If If drvDrive.IsReady Then strNama = drvDrive.VolumeName Else strNama = "Tidak diketahui" End If End If ' tvwExplor.Nodes.Add , , "pc", _ "komputerku", "komputer", "komputer" tvwExplor.Nodes.Add "pc", _ tvwChild, drvDrive.Path, _ strNama & " (" & _ UCase(drvDrive.DriveLetter) & ":)", strIkon ' If drvDrive.IsReady Then Set fldDrive = ObjekFile.GetFolder( _ drvDrive.RootFolder) For Each fldFolder In fldDrive.SubFolders tvwExplor.Nodes.Add drvDrive.Path, 4, _ fldFolder.Path, fldFolder.Name, "folder1" Next End If Next Me.tvwExplor.Nodes(1).Selected = True End Sub Private Sub Form_Resize() Me.tvwExplor.Move tvwExplor.Left, _ tvwExplor.Top, tvwExplor.Width, _ Me.ScaleHeight - Me.pgbExplor.Height Me.lvwExplor.Move lvwExplor.Left, _ lvwExplor.Top, Me.lvwExplor.Width, _ Me.ScaleHeight - Me.pgbExplor.Height Me.pgbExplor.Move 0, Me.ScaleHeight - _ Me.pgbExplor.Height, Me.ScaleWidth, _ Me.pgbExplor.Height Me.rtfExplor.Width = Me.ScaleWidth - _ Me.lvwExplor.Width - _ Me.tvwExplor.Width - 100 Me.rtfExplor.Height = Me.ScaleHeight - _ Me.pgbExplor.Height End Sub Private Sub lvwExplor_ItemClick( _ ByVal Item As MSComctlLib.ListItem) Dim nSt As Integer Me.Caption = strPathX & IIf( _ Len(strPathX) <= 4, "", "\") & Item.Text LihatFile Me.Caption End Sub ' Private Sub tvwExplor_Collapse( _ ByVal Node As MSComctlLib.Node) If Node.Image = "folder2" Then _ Node.Image = "folder1" End Sub ' Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
3
58 59 60 61 62 63 64 65 66 67 68 39 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100
101 102 103 104
105
Private Sub tvwExplor_Expand( _ ByVal Node As MSComctlLib.Node) On Error Resume Next Dim SubSubfolder As Folder Dim Subfolder As Folder Dim fldFolder As Folder Dim i% If Node.Image = "folder1" Then _ Node.Image = "folder2" Set fldFolder = ObjekFile.GetFolder( _ Node.Key & "\") For Each Subfolder In fldFolder.SubFolders For Each SubSubfolder In Subfolder.SubFolders tvwExplor.Nodes.Add Subfolder.Path, 4, _ SubSubfolder.Path, _ SubSubfolder.Name, "folder1" i = i + 1 Me.pgbExplor.Value = i / _ fldFolder.SubFolders.Count * 100 'DoEvents Next If Me.pgbExplor.Value >= 100 Then Me.pgbExplor.Value = 0 i = 0 End If Next End Sub ' Private Sub tvwExplor_NodeClick( _ ByVal Node As MSComctlLib.Node) On Error Resume Next Dim SubSubfolder As Folder Dim fldFolder As Folder Dim filFile As File Dim Subfolder As Folder lvwExplor.ListItems.Clear Set fldFolder = ObjekFile.GetFolder( _ Node.Key & "\") strPathX = fldFolder Me.Caption = strPathX Dim xFile$, i As Integer ' For Each Subfolder In fldFolder.SubFolders lvwExplor.ListItems.Add , _ Subfolder.Path, Subfolder.Name, _ "folder1", "folder1" i = i + 1 Me.pgbExplor.Value = i / _ fldFolder.SubFolders.Count * 100 DoEvents Next For Each filFile In fldFolder.Files xFile = LCase(Right(filFile.Name, 3)) lvwExplor.ListItems.Add , _ fldFolder.Path & "\" & _ filFile.Name, filFile.Name, xFile, _ xFile i = i + 1 Me.pgbExplor.Value = i / _ fldFolder.Files.Count * 100 ' If Err Then lvwExplor.ListItems.Add , _ fldFolder.Path & "\" & _ filFile.Name, filFile.Name, _ "filegeneric", "filegeneric" End If Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
4
106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
Next If Me.pgbExplor.Value >= 100 Then Me.pgbExplor.Value = 0 i = 0 End If End Sub ' Sub LihatFile(sFile As String) rtfExplor.Locked = False rtfExplor.Font.Size = 8 rtfExplor.Text = "" rtfExplor.SelAlignment = 0 rtfExplor.RightMargin = 0 sPath = sFile On Error GoTo ErrHandler Select Case LCase(Right$(sFile, 4)) Case ".bmp", ".jpg", ".gif" Dim pic As StdPicture Set pic = LoadPicture(sPath) Clipboard.Clear Clipboard.SetData pic SendMessage rtfExplor.hwnd, _ &H302, 0, 0 Clipboard.Clear rtfExplor.RightMargin = _ pic.Width \ TwipsInHimetric Case ".rtf" rtfExplor.LoadFile sPath, rtfRTF Case ".txt" rtfExplor.LoadFile sPath, _ rtfText Case Else rtfExplor.LoadFile sPath, _ rtfText End Select rtfExplor.Refresh rtfExplor.Locked = True Exit Sub ErrHandler: On Error GoTo 0 rtfExplor.Text = "Format tidak dikenal" rtfExplor.Refresh rtfExplor.Locked = True End Sub
c. Tes Program Jalankan program! Tampilan program saat berjalan, akan tampak seperti ilustrasi gambar di bawah ini.
Gambar 16.2. Program sedang berjalan, menampilkan file gambar.
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
5
16.2. Kalkulator Sepertinya tidak ada yang perlu dijelaskan, langsung saja, buat project baru pada Standard Exe. Sebelumnya, buatlah folder baru di: “C:\Menggali VB\Bab 16”, namai dengan “Kalkulator”, untuk menyimpan project Anda.
a. Desain Form Gambarkan sebuah objek CommandButton, namai dengan: cmdNumber, gandakan menjadi 10 buah, ubah Caption, sesuai dengan Index-nya masing-masing. Gambarkan lagi sebuah objek CommandButton namai dengan cmdOperator, gandakan menjadi 5 buah. Ubah properti Caption seperti pada table di bawah ini. Objek pada: Form1 Nama Objek Properti Name Index Command2 Caption TabIndex Name Index Command2 Caption TabIndex Name Index Command2 Caption TabIndex Name Index Command2 Caption TabIndex Name Index Command2 Caption TabIndex
Perubahan cmdOperator 0 / 13 cmdOperator 1 + 14 cmdOperator 2 x 15 cmdOperator 3 16 cmdOperator 4 = 17
Gambarkan lagi 4 (empat) buah CommandButton dan sebuah Label, atur properti seperti pada table di bawah: Objek pada: Form1 Nama Objek Properti Name Command1 Caption TabIndex Name Command2 Caption TabIndex Name Command3 Caption TabIndex Name Command4 Caption TabIndex Name Caption Alignment Label1 BackColor TabIndex
Perubahan cmdPercent % 18 cmdDecimal . 19 cmdCancel C 1 cmdCancelEntry CE 2 lblDisplay 0. 1-Right Justify Putih atau warna terang lainnya 0
Sehingga tampilan akhir desain, seperti pada gambar di bawah ini.
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
6
Gambar 16.3. Desain Form kalkulator.
b. Baris Kode Baris Kode Baris kode pada: Form1 1 Option Explicit 2 3 4 5 6 7
Dim Dim Dim Dim Dim Dim
8 9 10 11 12 13 14
Private Sub cmdCancel_Click() On Error Resume Next lblDisplay = "0." Operator1 = 0 Operator2 = 0 Form_Load End Sub ' Private Sub cmdCancelEntry_Click() On Error Resume Next lblDisplay = "0." DecimalFlag = False AkhirMasukan = "CE" End Sub ' Private Sub cmdDecimal_Click() On Error Resume Next If AkhirMasukan = "NEG" Then lblDisplay = "-0." ElseIf AkhirMasukan <> "NUMS" Then lblDisplay = "0." End If DecimalFlag = True AkhirMasukan = "NUMS" End Sub ' Private Sub cmdNomor_Click(Index As Integer) On Error Resume Next If Len(lblDisplay) <= 17 Then If AkhirMasukan <> "NUMS" Then lblDisplay = "." DecimalFlag = False End If If DecimalFlag Then lblDisplay = lblDisplay + _ cmdNomor(Index).Caption Else lblDisplay = Left(lblDisplay, _ InStr(lblDisplay, ".") - 1) + _ cmdNomor(Index).Caption + "." End If If AkhirMasukan = "NEG" Then _
15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43
Operator1, Operator2 DecimalFlag As Integer NumOps As Integer AkhirMasukan JnOperator TempPembacaan
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
7
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
lblDisplay = "-" & lblDisplay AkhirMasukan = "NUMS" End If End Sub ' Private Sub cmdOperator_Click(Index As Integer) On Error Resume Next TempPembacaan = lblDisplay If AkhirMasukan = "NUMS" Then NumOps = NumOps + 1 End If Select Case NumOps Case 0 If cmdOperator(Index).Caption = "-" _ And AkhirMasukan <> "NEG" Then lblDisplay = "-" & lblDisplay AkhirMasukan = "NEG" End If Case 1 Operator1 = lblDisplay If cmdOperator(Index).Caption = "-" _ And AkhirMasukan <> "NUMS" And _ JnOperator <> "=" Then lblDisplay = "-" AkhirMasukan = "NEG" End If Case 2 Operator2 = TempPembacaan Select Case JnOperator Case "+" Operator1 = Operator1 + Operator2 Case "-" Operator1 = Operator1 - Operator2 Case "X" Operator1 = Operator1 * Operator2 Case "/" If Operator2 = 0 Then MsgBox "Ga bisa membagi dengan Nol", _ 48, "Kalkulator" Else Operator1 = Operator1 / Operator2 End If Case "=" Operator1 = Operator2 Case "%" Operator1 = Operator1 * Operator2 End Select lblDisplay = Operator1 NumOps = 1 End Select If AkhirMasukan <> "NEG" Then AkhirMasukan = "OPS" JnOperator = cmdOperator(Index).Caption End If End Sub
94 95 96 97 98 99 100 101
Private Sub cmdPercent_Click() On Error Resume Next lblDisplay = lblDisplay / 100 AkhirMasukan = "OPS" JnOperator = "%" NumOps = NumOps + 1 DecimalFlag = True End Sub
102 103
Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii >= Asc("0") And _ KeyAscii <= Asc("9") Then
44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
8
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
cmdNomor_Click (KeyAscii - 48) ElseIf KeyAscii = Asc("/") Then cmdOperator_Click (0) ElseIf KeyAscii = Asc("+") Then cmdOperator_Click (1) ElseIf KeyAscii = Asc("*") Then cmdOperator_Click (2) ElseIf KeyAscii = Asc("-") Then cmdOperator_Click (3) ElseIf KeyAscii = Asc("=") Then cmdOperator_Click (4) ElseIf KeyAscii = 13 Then cmdOperator_Click (4) ElseIf KeyAscii = Asc("%") Then cmdPercent_Click ElseIf KeyAscii = Asc(".") Then cmdDecimal_Click End If End Sub
123 124 125 126 127 128 129
Private Sub Form_Load() On Error Resume Next DecimalFlag = False NumOps = 0 AkhirMasukan = "NONE" JnOperator = " " End Sub
c. Tes Program Jalankan program! Cobalah untuk menggunakan Numpad pada keyboard, ini akan berfungsi seperti jika Anda menggunakan aplikasi Calculator kepunyaan Windows.
16.3. Konversi Angka Program kali ini, saya akan membuat suatu program untuk mengkonversi sebuah nilai (angka) menjadi jenis baru seperti: angka Romawi, Binear, Hexadecimal, dan huruf nominal. Sebelumnya, buatlah folder di: “C:\Menggali VB\Bab 16”, dengan nama “Konversi”, untuk menyimpan project Anda. Program ini juga hanya menggunakan satu buah form.
a. Desain Program Pada form Gambarkan 5 (lima) buah Label, 5 (lima) buah TextBox, dan sebuah CommandButton. Ubah propertinya seperti pada table di bawah: Pengaturan Properti Pengaturan pada: Form1 No Objek Kontrol Properti 1 Label1 Caption 2 Label2 Caption 3 Label3 Caption 4 Label4 Caption 5 Label5 Caption Name 6 Text1 Alignment Name 7 Text2 Alignment Name 8 Text3 Alignment Name 9 Text4 Alignment
Perubahan Angka Masukan Konversi Romawi Konversi Binear Konversi Hexa Konversi Huruf txtAngka 1 – Right Justify txtKonversi1 0 – Left Justify txtKonversi2 1 – Right Justify txtKonversi3 1 – Right Justify
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
9
10
Text5
11
Command1
Name Alignment Multiline ScrollBar Name Caption
txtKonversi4 0 – Left Justify True 2 – Vertical cmdKonversi &Konversi
Tampilan akhir desain form seperti pada gambar di bawah ini.
Gambar 16.4. Desain form Konversi. Tambahkan sebuah Module pada project Anda, namai dengan mdlKonversi.
b. Baris Kode Baris Kode Baris kode pada: mdlKonversi 1 Dim HurufKe(20) As Double 2 3 4 5 6 7 8 9 10 11 12 13 14 15
Function HurufSatuan(Angka As Select Case Angka Case 1: HurufSatuan = Case 2: HurufSatuan = Case 3: HurufSatuan = Case 4: HurufSatuan = Case 5: HurufSatuan = Case 6: HurufSatuan = Case 7: HurufSatuan = Case 8: HurufSatuan = Case 9: HurufSatuan = Case 0: HurufSatuan = End Select End Function
16 17 18 19 20 21 22 23 24 25 26 27
Function Huruf(Angka As Double) As String Dim Satuan$, Puluhan$, Ratusan$, Dim Ribuan$, PuluhRibuan$, RatusRibuan$ Dim Jutaan$, PuluhJutaan$, RatusJutaan$ Dim Milyaran$, PuluhMilyaran$ Dim RatusMilyaran$, Panjang%, i% Panjang = Len(CStr(Angka)) For i = 1 To 20 HurufKe(i) = 0 Next For i = Panjang To 1 Step -1 HurufKe(i) = (Mid(CStr(Angka), _ (Panjang + 1) - i, 1)) Next If HurufKe(1) = 1 Then Satuan = "satu" Else Satuan = HurufSatuan(HurufKe(1)) End If If HurufKe(2) > 1 Then Puluhan = HurufSatuan(HurufKe(2)) & _ "puluh "
28 29 30 31 32 33 34 35
Double) As String "se" "dua" "tiga" "empat" "lima" "enam" "tujuh" "delapan" "sembilan" ""
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
10
36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
ElseIf HurufKe(2) = 1 Then If HurufKe(1) > 0 Then Satuan = HurufSatuan(HurufKe(1)) & _ "belas" Else Satuan = "sepuluh" End If End If If HurufKe(3) > 0 Then Ratusan = HurufSatuan(HurufKe(3)) & _ "ratus " End If If HurufKe(5) > 1 Then PuluhRibuan = HurufSatuan(HurufKe(5)) & _ "puluh " If HurufKe(4) > 0 Then If HurufKe(4) = 1 Then Ribuan = "satu ribu " Else Ribuan = HurufSatuan( _ HurufKe(4)) & "ribu " End If Else Ribuan = "ribu " End If ElseIf HurufKe(5) = 1 Then If HurufKe(4) = 0 Then PuluhRibuan = HurufSatuan( _ HurufKe(4)) & "sepuluh ribu " Else PuluhRibuan = HurufSatuan( _ HurufKe(4)) & "belas ribu " End If Else If HurufKe(4) > 0 Then Ribuan = HurufSatuan(HurufKe(4)) & _ "ribu " End If End If '-------------------------------------If HurufKe(6) > 0 Then If HurufKe(5) > 0 Then RatusRibuan = HurufSatuan( _ HurufKe(6)) & "ratus " ElseIf HurufKe(5) = 0 Then If HurufKe(4) = 0 Then RatusRibuan = HurufSatuan( _ HurufKe(6)) & "ratus ribu " Else RatusRibuan = HurufSatuan( _ HurufKe(6)) & "ratus " End If End If End If '-----------------------------------If HurufKe(8) > 1 Then PuluhJutaan = HurufSatuan(HurufKe(8)) & _ "puluh " If HurufKe(7) > 0 Then If HurufKe(7) = 1 Then Jutaan = "satu juta " Else Jutaan = HurufSatuan( _ HurufKe(7)) & "juta " End If Else Jutaan = "juta " End If Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
11
91 92 93
139
ElseIf HurufKe(8) = 1 Then If HurufKe(7) = 0 Then PuluhJutaan = HurufSatuan( _ HurufKe(7)) & "sepuluh juta " Else PuluhJutaan = HurufSatuan( _ HurufKe(7)) & "belas juta " End If Else If HurufKe(7) > 0 Then If HurufKe(7) = 1 Then Jutaan = "satu juta " Else Jutaan = HurufSatuan( _ HurufKe(7)) & "juta " End If End If End If If HurufKe(9) > 0 Then RatusJutaan = HurufSatuan( _ HurufKe(9)) & "ratus " End If If HurufKe(11) > 1 Then PuluhMilyaran = HurufSatuan( _ HurufKe(11)) & "puluh " If HurufKe(10) > 0 Then If HurufKe(10) = 1 Then Milyaran = "satu milyar " Else Milyaran = HurufSatuan( _ HurufKe(10)) & "milyar " End If ElseIf HurufKe(10) = 0 Then PuluhMilyaran = HurufSatuan( _ HurufKe(11)) & "puluh milyar " End If ElseIf HurufKe(11) = 1 Then If HurufKe(10) > 0 Then PuluhMilyaran = HurufSatuan( _ HurufKe(10)) & "belas milyar " ElseIf HurufKe(10) = 0 Then PuluhMilyaran = "sepuluh milyar " End If ElseIf HurufKe(11) = 0 Then If HurufKe(10) = 1 Then Milyaran = "satu milyar " ElseIf HurufKe(10) > 1 Then Milyaran = HurufSatuan( _ HurufKe(10)) & "milyar " End If End If If HurufKe(12) > 0 Then RatusMilyaran = HurufSatuan( _ HurufKe(12)) & "ratus " End If Huruf = RatusMilyaran & PuluhMilyaran & _ Milyaran & RatusJutaan & _ PuluhJutaan & Jutaan & _ RatusRibuan & PuluhRibuan & _ Ribuan & Ratusan$ & Puluhan$ & Satuan End Function
140 141 142 143 144 145
Function BASIS(IntAngka%, NBASIS%) As String Dim INTNILAI&, INTLEN%, J% Dim STRHASIL$, STRHEXA$, STREND$, STRSUB$ Do INTNILAI = IntAngka Mod NBASIS IntAngka = IntAngka \ NBASIS
94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
12
146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
Select Case INTNILAI Case 10: STRHEXA = "A" Case 11: STRHEXA = "B" Case 12: STRHEXA = "C" Case 13: STRHEXA = "D" Case 14: STRHEXA = "E" Case 15: STRHEXA = "F" Case Else: STRHEXA = CStr(INTNILAI) End Select STRHASIL = STRHASIL + STRHEXA Loop Until IntAngka < NBASIS INTLEN = Len(STRHASIL): STREND = CStr(IntAngka) For J = INTLEN To 1 Step -1 STRSUB = STRSUB + Mid(STRHASIL, J, 1) Next If (Mid(STREND + STRSUB, 1, 1)) = "0" Then BASIS = Mid(STREND + STRSUB, _ 2, Len(STREND + STRSUB) - 1) Else: BASIS = STREND + STRSUB: End If End Function
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211
Function ROMAN(IntAngka As Integer) As String Dim i%, IntSeribu%, IntLimaRatus% Dim IntSeratus%, IntLimaPuluh% Dim IntSepuluh%, IntLima%, IntSatu% Dim StrSeribu$, StrLimaRatus$, StrSeratus$ Dim StrLimaPuluh$, StrSepuluh$ Dim StrLima$, StrSatu$, StrRomawi$ IntSatu = IntAngka IntSeribu = IntAngka \ 1000 IntSatu = IntAngka Mod 1000 IntLimaRatus = IntSatu \ 500 IntSatu = IntAngka Mod 500 IntSeratus = IntSatu \ 100 IntSatu = IntAngka Mod 100 IntLimaPuluh = IntSatu \ 50 IntSatu = IntAngka Mod 50 IntSepuluh = IntSatu \ 10 IntSatu = IntAngka Mod 10 IntLima = IntSatu \ 5 IntSatu = IntAngka Mod 5 For i = 0 To IntSeribu - 1 StrSeribu = StrSeribu + "M" Next If IntSeratus <> 4 Then For i = 0 To IntLimaRatus - 1 StrLimaRatus = StrLimaRatus + "D" Next End If For i = 0 To IntSeratus - 1 StrSeratus = StrSeratus + "C" Next If IntSeratus = 4 Then If IntLimaRatus = 1 Then StrSeratus = StrRomawi + "CM" Else: StrSeratus = StrRomawi + "CD" End If End If If IntSepuluh <> 4 Then For i = 0 To IntLimaPuluh - 1 StrLimaPuluh = StrLimaPuluh + "L" Next End If For i = 0 To IntSepuluh - 1 StrSepuluh = StrSepuluh + "X" Next If IntSepuluh = 4 Then Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
13
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233
If IntLimaPuluh = 1 Then StrSepuluh = StrRomawi + "XC" Else: StrSepuluh = StrRomawi + "XL" End If End If If IntSatu <> 4 Then For i = 0 To IntLima - 1 StrLima = StrLima + "V" Next End If For i = 0 To IntSatu - 1 StrSatu = StrSatu + "I" Next If IntSatu = 4 Then If IntLima = 1 Then StrSatu = StrRomawi + "IX" Else: StrSatu = StrRomawi + "IV" End If End If StrRomawi = StrSeribu + StrLimaRatus _ + StrSeratus + StrLimaPuluh _ + StrSepuluh + StrLima + StrSatu ROMAN = StrRomawi End Function
Baris kode pada: Form1 1 Option Explicit 2 3 4 5 6 7
Private Sub cmdKonversi_Click() Me.txtKonversi1.Text = _ ROMAN(CInt(Me.txtAngka.Text)) Me.txtKonversi2.Text = _ BASIS(CInt(Me.txtAngka.Text), 2) Me.txtKonversi3.Text = _ BASIS(CInt(Me.txtAngka.Text), 16) Me.txtKonversi4.Text = _ Huruf(CDbl(Me.txtAngka.Text)) End Sub
c. Tes Program Jalankan program! Ketikkan suatu nilai di Angka Masukan, misal: 1234, klik tombol Konversi. Hasil akan seperti pada ilustrasi gambar berikut:
Gambar 16.5. Program Konversi sedang berjalan. Catatan: Konversi Huruf (nominal) di atas, mampu membaca hingga nominal ratusan milyar. Tetapi pada program ini batasan atas nilai yang dapat diuji adalah 32.767. Untuk menguji nilai di atas batas tersebut, beri tanda kutip tunggal (‘) di baris kode nomor 3, 4, dan 5 pada form (yang menandakan bahwa hanya konversi Huruf yang dapat digunakan untuk nilai melampaui batas atas yang ditentukan).
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
14
16.4. Text Editor Program ini adalah untuk mengedit file rich text format (rtf) seperti program WinWord kepunyaan Windows. Buatlah folder baru di alamat: “C:\Menggali VB\Bab 16” dengan nama “Text Editor”, untuk menyimpan project Anda.
a. Desain Form Tempatkan sebuah RichTextBox dan sebuah ImageList pada form. Namai RichTextBox dengan rtfEditor dan ImageList dengan imlMenu. Ubah property ImageWidth dan ImageHeight dari imlMenu, masing-masing menjadi 13. Masukkan 17 gambar pada imlMenu (gambar bisa Anda dapatkan pada CD).
Gambar 16.6. Property Pages ImageList. Tambahkan CommonDialog, namai dengan cdlEditor. Dengan Menu Editor, buatlah beberapa menu seperti pada table di bawah Caption &Editor &New &Open &Save Cu&t &Copy &Paste &Bold &Italic &Underline &Left C&enter &Right &Font… &Gambar… &Quit
Name mnuEditor mnuENew mnuEOpen mnuESave Spr1 mnuECut mnuECopy mnuEPaste Spr2 mnuEBold mnuEItalic mnuEUnderline Spr3 mnuELeft mnuECenter mnuERoght Spr4 mnuEFont mnuEGambar Spr5 mnuEQuit
ShortCut
CheckBox
Ctrl + N Ctrl + O Ctrl + S Ctrl + X Ctrl + C Ctrl + V Ctrl + B Ctrl + I Ctrl + U
tandai tandai tandai
Ctrl + L Ctrl + E Ctrl + R
tandai tandai tandai
Ctrl + F Ctrl + G Ctrl + Q
Indentasi 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1
Tampilan akhir desain seperti pada gambar di bawah:
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
15
Gambar 16.7. Desain form Editor.
b. Baris Kode Baris Kode Baris kode pada: Form1 1 Option Explicit 2
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
3
13 14 15 16 17 18 19 20
Dim TwipsInHimetric! ' Private Sub EBold() With Me.rtbEditor If Not .SelBold Then .SelBold = True Else: .SelBold = False End If End With End Sub ' Private Sub EItalic() With Me.rtbEditor If Not .SelItalic Then .SelItalic = True Else: .SelItalic = False End If End With End Sub
21 22 23 24 25 26 27 28
Private Sub EUnderline() With Me.rtbEditor If Not .SelUnderline Then .SelUnderline = True Else: .SelUnderline = False End If End With End Sub
29 30 31 32
Private Sub ECut() Clipboard.SetText Me.rtbEditor.SelRTF Me.rtbEditor.SelText = vbNullString End Sub
33 34 35
Private Sub ECopy() Clipboard.SetText Me.rtbEditor.SelRTF End Sub
36 37 38
Private Sub EPaste() Me.rtbEditor.SelRTF = Clipboard.GetText End Sub
39 40 41 42 43 44
Private Sub EOpen() With Me.cdlEditor .DialogTitle = "Buka File" .CancelError = True .FileName = "" .Filter = "Rich Text Format (*.rtf)" & _ "|*.rtf|Word Document (*.doc)" & _ "|*.doc|Text Document (*.txt)" & _ "|*.txt|Semua File (*.*)|*.*" On Error Resume Next .ShowOpen: On Error GoTo 0 If .FileName = "" Then
4 5 6 7 8 9 10 11
45 46 47
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
16
48 49 50 51 52
Exit Sub Else: Me.rtbEditor.FileName = .FileName End If End With End Sub
53 54 55 56 57 58
Private Sub EFont() With Me.cdlEditor .Flags = &H3 Or &H100 Or &H1 .FontBold = Me.rtbEditor.SelBold .FontItalic = Me.rtbEditor.SelItalic .FontUnderline = _ rtbEditor.SelUnderline .FontName = Me.rtbEditor.SelFontName .FontSize = Me.rtbEditor.SelFontSize .ShowFont rtbEditor.SelBold = .FontBold rtbEditor.SelItalic = .FontItalic rtbEditor.SelUnderline = _ .FontUnderline rtbEditor.SelColor = .Color rtbEditor.SelFontSize = .FontSize rtbEditor.SelFontName = .FontName End With End Sub
59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
Private Sub EGambar() Dim pic As StdPicture With Me.cdlEditor .DialogTitle = "Buka File" .CancelError = True .FileName = "" .Filter = "Gambar JPG (*.jpg)" & _ "|*.jpg|Gambar Bmp (*.bmp)" & _ "|*.bmp" On Error Resume Next .ShowOpen: On Error GoTo 0 If .FileName = "" Then Exit Sub Else: Set pic = LoadPicture(.FileName) Clipboard.Clear: Clipboard.SetData pic SendMessage rtbEditor.hwnd, &H302, 0, 0 rtbEditor.SelText = vbCrLf End If End With End Sub
88 89 90
Private Sub ERight() Me.rtbEditor.SelAlignment = rtfRight End Sub
91 92 93
Private Sub ECenter() Me.rtbEditor.SelAlignment = rtfCenter End Sub
94 95 95
Private Sub ELeft() Me.rtbEditor.SelAlignment = rtfLeft End Sub
96 97 98 99 100 101 102
Private Sub ESave() With Me.cdlEditor .DialogTitle = "Simpan File" .CancelError = True .FileName = "" .Filter = "Rich Text File (*.rtf)" & _ "|*.rtf" On Error Resume Next .ShowSave: On Error GoTo 0
103
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
17
104 105 106 107 108 109 110
If .FileName = "" Then Exit Sub Else: Error Resume Next Me.rtbEditor.SaveFile .FileName End If End With End Sub
111 112 113
Private Sub ENew() Me.rtbEditor.Text = "" End Sub
114 115 116
Private Sub Form_Load() rtbEditor_SelChange: Call TambahkanGambar Me End Sub
117 118 119 120
Private Sub Form_Resize() On Error Resume Next Me.rtbEditor.Move 0, 0, Me.ScaleWidth, _ Me.ScaleHeight End Sub
121 122 123
Private Sub mnuEBold_Click() Call EBold End Sub
124 125 126
Private Sub mnuECenter_Click() Call ECenter End Sub
127 128 129
Private Sub mnuECopy_Click() Call ECopy End Sub
130 131 132
Private Sub mnuECut_Click() Call ECut End Sub
133 134 135
Private Sub mnuEFont_Click() Call EFont End Sub
136 137 138
Private Sub mnuEGambar_Click() Call EGambar End Sub
139 140 141
Private Sub mnuEItalic_Click() Call EItalic End Sub
142 143 144
Private Sub mnuELeft_Click() Call ELeft End Sub
145 146 147
Private Sub mnuENew_Click() Call ENew End Sub
148 149 150
Private Sub mnuEOpen_Click() Call EOpen End Sub
151 152 153
Private Sub mnuEPaste_Click() Call EPaste End Sub
154 155
Private Sub mnuEQuit_Click() Unload Me Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
18
156
End Sub
157 158 159
Private Sub mnuERight_Click() Call ERight End Sub
160 161 162
Private Sub mnuEUnderline_Click() Call EUnderline End Sub
163 164 165
Private Sub mnuESave_Click() Call ESave End Sub
166
Private Sub rtbEditor_MouseDown( _ Button As Integer, Shift As Integer, _ x As Single, y As Single) If Button = 2 Then Me.PopupMenu Me.mnuEditor, 2 Or 4 TambahkanGambar Me : End If End Sub
167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196
Private Sub rtbEditor_SelChange() With Me.rtbEditor If .SelBold = True Then Me.mnuEBold.Checked = True Else: Me.mnuEBold.Checked = False End If If .SelItalic = True Then Me.mnuEItalic.Checked = True Else: Me.mnuEItalic.Checked = False End If If .SelUnderline = True Then Me.mnuEUnderline.Checked = True Else: Me.mnuEUnderline.Checked = False End If Me.mnuELeft.Checked = False Me.mnuECenter.Checked = False Me.mnuERight.Checked = False If .SelAlignment = 0 Then Me.mnuELeft.Checked = True ElseIf .SelAlignment = 1 Then Me.mnuERight.Checked = True ElseIf .SelAlignment = 2 Then Me.mnuECenter.Checked = True End If End With Call TambahkanGambar Me End Sub
c. Tes Program
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
19
Gambar 16.8. Program Editor sedang berjalan, menampilkan teks dan gambar. Jalankan program! Bukan hanya teks yang dapat Anda sisipkan pada program Text Editor ini, Anda diperkenankan untuk menyisipkan file gambar seperti: jpg, bmp atau gif. Selain itu menu-menu yang ditampilkan pun lebih kelihatan menarik, karena dihiasi gambar-gambar kecil di sisi tiaptiap menunya. Cobalah untuk menggunakan semua menu yang disediakan
16.5. Screen Saver Tentunya Anda tahu definisi Screen Saver. Jika tidak tahu, Screen Saver adalah tampilan program saat Sistem Operasi tidak menerima suatu aksi baik itu penekanan tombol keyboard ataupun pergerakkan pointer mouse. Contoh program berikut ini, mencoba membuat sebuah file Screen Saver dengan tampilan jam analog. Seperti biasa, buatlah sebuah folder baru di alamat: “C:\Menggali VB\Bab 16”, namai degan “Screen Saver”. a.
Desain Program
Ubah nama Project1 menjadi: “ssaverVian” (perubahan nama project sebetulnya tidak terlalu berperan, jadi boleh saja bagi Anda untuk tidak menggantinya). Ubah Name dari Form1 menjadi: frmJAM, ubah BorderStyle menjadi: 0-None. Gambarkan sebuah PictureBox, di dalam PictureBox tersebut gambarkan objek Line. Ubah properti Name dari Line1 dengan: linJam, dan ubah nilai properti Index menjadi: 0 (nol). Gambarkan objek kontrol Timer. Ubah properti-properti dari PictureBox dan Timer, seperti pada table di bawah: Objek pada: frmJAM Nama Object Properti Name Autosize AutoRedraw Picture1 BorderStyle DrawStyle FillStyle Picture Name Timer1 Interval
Pengaturan picLogo True True 0-None 0-Solid 1-Transparent Terserah Anda tmrJam 100
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
20
Gambar 16.9. Desain form frmJAM. Tambahkan sebuah form baru, Namai dengan: frmSET. Bila perlu ubah Caption dengan: “Settings”. Masukkan objek control-objek control dan atur properti-propertinya seperti pada table di bawah ini: Pengaturan Properti Pengaturan pada: Form1 No Objek Kontrol Properti 1 Frame Caption 2 Frame Caption 3 Label1 Caption 4 Label2 Caption 5 Label3 Caption 6 Label4 Caption 7 Label5 Caption 8 Label6 Caption 9 Label7 Caption 10 Text1 Name 11 Combo1 Name 12 Combo2 Name 13 Combo3 Name Name 14 Command1 Caption Name 15 Command2 Caption Name 16 Command3 Caption Name 17 Command4 Caption Name 18 Command5 Caption Default Name 19 Command6 Caption Cancel 20 CommonDialog Name
Perubahan Tebal Jarum Warna Jarum Jam Jam Menit Menit Detik Detik Alamat &Gambar txtAlamat cboTebalJam cboTebalMenit cboTebalDetik cmdAlamat … cmdWarnaJam … cmdWarnaMenit … cmdWarnaDetik … cmdOK OK True cmdCancel Cancel True dlgSet
Gambar 16.10. Desain form frmSET. Tambahkan sebuah Module pada project Anda. Kita mulai membuat kode sumber.
b. Baris kode Baris Kode Baris kode pada: Module1 1 Option Explicit 2
Public Declare Function SystemParametersInfo _ Lib "user32" Alias "SystemParametersInfoA" _ (ByVal uAction As Long, ByVal uParam As Long, _ ByRef lpvParam As Any, _ ByVal fuWinIni As Long ) As Long Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
21
3
Public Declare Function ShowCursor _ Lib "user32" (ByVal bShow As Long) As Long
4
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
5 6 7 8 9 10 11
Const Const Const Const Const Const Const
12
Public Const SPI_SETSCREENSAVEACTIVE = 17
13 14
Sub MakeNormal(iForm As Form) SetWindowPos iForm.hwnd, _ HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS End Sub
15 16 17 18
HWND_TOPMOST = -1 HWND_NOTOPMOST = -2 SWP_NOMOVE = &H2 SWP_NOSIZE = &H1 SWP_NOACTIVATE = &H10 SWP_SHOWWINDOW = &H40 TOPMOST_FLAGS = _ SWP_NOMOVE Or SWP_NOSIZE
Sub MakeTopMost(iForm As Form) SetWindowPos iForm.hwnd, _ HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS End Sub
Baris kode pada: frmJAM 1 Option Explicit 2 3 4 5 6 7 8
Private Private Private Private Private Private Private
WarnaJam& WarnaMenit& WarnaDetik& TebalJam% TebalMenit% TebalDetik% Alamat$
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34
Sub Loading() On Error Resume Next Dim i, Sudut, X, Y, J GetSettings Me.picLogo.Picture = LoadPicture(Alamat) Me.KeyPreview = True MakeTopMost Me Me.BackColor = 0 Me.linJam(0).X1 = -100 Me.linJam(0).X2 = -200 With Me.picLogo .Cls .PaintPicture .Picture, 0, 0, _ .Width, .Height End With Me.picLogo.AutoSize = True For i = 0 To 10 If i > 0 Then Load linJam(i) linJam(i).Visible = True Next i Me.picLogo.Scale (-1, 1)-(1, -1) Sudut = J * 2 * Atn(1) / 15 linJam(J).X1 = 3 * Cos(Sudut) linJam(J).Y1 = 3 * Sin(Sudut) linJam(J).X2 = Cos(Sudut) Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
22
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76
End Sub
linJam(J).Y2 = Sin(Sudut) linJam(J).BorderColor = vbBlue
Private Sub Form_KeyDown( _ KeyCode As Integer, Shift As Integer) Unload Me: End End Sub Private Sub Form_Load() Dim X X = SystemParametersInfo( _ SPI_SETSCREENSAVEACTIVE, 0, ByVal 0&, 0) Select Case UCase(Mid(Command$, 2, 1)) Case Is = "P" Unload Me: End: Exit Sub Case Is = "C" FSET.Show Unload Me Exit Sub Case Is = "A" MsgBox "Password tidak" & _ " disediakan", 64, "Informasi" Unload Me: End: Exit Sub Case Is = "S" X = ShowCursor(False) Me.Show Case Else X = ShowCursor(True) Unload Me: End: Exit Sub End Select End Sub Private Sub Form_MouseMove(Button As Integer, _ Shift As Integer, X As Single, Y As Single) Me.TutupMouse X, Y End Sub Private Sub Form_Resize() On Error Resume Next Call Loading Me.Move 0, 0, Screen.Width, Screen.Height Me.picLogo.Move (Me.ScaleWidth - _ Me.picLogo.Width) / 2, _ (Me.ScaleHeight - Me.picLogo.Height) / 2 End Sub Private Sub Form_Unload(Cancel As Integer) Dim Ret MakeNormal Me Ret = SystemParametersInfo( _ SPI_SETSCREENSAVEACTIVE, 2, ByVal 0&, 0) Ret = ShowCursor(True) End Sub
78 79
Private Sub picLogo_MouseMove( _ Button As Integer, Shift As Integer, _ X As Single, Y As Single) TutupMouse X, Y End Sub
80 81 82 83 84 85 86
Private Sub tmrJam_Timer() On Error Resume Next Const LenganJam = 10 Const LenganJam2 = 9 Const LenganJam3 = 8 Const LenganMenit = 7 Const LenganMenit2 = 6 Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
23
87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
Const LenganMenit3 = 5 Const LenganDetik = 4 Const LenganDetik2 = 3 Const LenganDetik3 = 2 Dim Sudut Static DetikAkhir If Second(Now) = DetikAkhir Then Exit Sub DetikAkhir = Second(Now) With Me Sudut = 0.5236 * (15 - (Hour(Now) + _ Minute(Now) / 60) + 0.2) .linJam(LenganJam).X1 = 0 .linJam(LenganJam).Y1 = 0 .linJam(LenganJam).X2 = 0.3 * Cos(Sudut) .linJam(LenganJam).Y2 = 0.3 * Sin(Sudut) .linJam(LenganJam).BorderColor = _ WarnaJam .linJam(LenganJam).BorderWidth = _ TebalDetik Sudut = 0.5236 * (15 - (Hour(Now) + _ Minute(Now) / 60) - 0.2) .linJam(LenganJam2).X1 = 0 .linJam(LenganJam2).Y1 = 0 .linJam(LenganJam2).X2 = 0.3 * _ Cos(Sudut) .linJam(LenganJam2).Y2 = 0.3 * _ Sin(Sudut) .linJam(LenganJam2).BorderColor = _ WarnaJam .linJam(LenganJam2).BorderWidth = _ TebalDetik Sudut = 0.5236 * (15 - (Hour(Now) + _ Minute(Now) / 60)) .linJam(LenganJam3).X1 = 0 .linJam(LenganJam3).Y1 = 0 .linJam(LenganJam3).X2 = 0.4 * _ Cos(Sudut) .linJam(LenganJam3).Y2 = 0.4 * _ Sin(Sudut) .linJam(LenganJam3).BorderColor = _ WarnaJam .linJam(LenganJam3).BorderWidth = _ TebalDetik Sudut = 0.1047 * (75 - (Minute(Now) + _ Second(Now) / 60) + 0.4) .linJam(LenganMenit).X1 = 0 .linJam(LenganMenit).Y1 = 0 .linJam(LenganMenit).X2 = 0.5 * _ Cos(Sudut) .linJam(LenganMenit).Y2 = 0.5 * _ Sin(Sudut) .linJam(LenganMenit).BorderColor = _ WarnaMenit .linJam(LenganMenit).BorderWidth = _ TebalMenit Sudut = 0.1047 * (75 - (Minute(Now) + _ Second(Now) / 60) - 0.4) .linJam(LenganMenit2).X1 = 0 .linJam(LenganMenit2).Y1 = 0 .linJam(LenganMenit2).X2 = 0.5 * _ Cos(Sudut) .linJam(LenganMenit2).Y2 = 0.5 * _ Sin(Sudut) .linJam(LenganMenit2).BorderColor = _ WarnaMenit .linJam(LenganMenit2).BorderWidth = _ TebalMenit Sudut = 0.1047 * (75 - (Minute(Now) + _ Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
24
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163
Second(Now) / 60)) .linJam(LenganMenit3).X1 = 0 .linJam(LenganMenit3).Y1 = 0 .linJam(LenganMenit3).X2 = 0.6 * Cos(Sudut) .linJam(LenganMenit3).Y2 = 0.6 * Sin(Sudut) .linJam(LenganMenit3).BorderColor = _ WarnaMenit .linJam(LenganMenit3).BorderWidth = _ TebalMenit Sudut = 0.1047 * (75 - Second(Now) + 0.2) .linJam(LenganDetik).X1 = 0 .linJam(LenganDetik).Y1 = 0 .linJam(LenganDetik).X2 = 0.6 * Cos(Sudut) .linJam(LenganDetik).Y2 = 0.6 * Sin(Sudut) .linJam(LenganDetik).BorderColor = _ WarnaDetik .linJam(LenganDetik).BorderWidth = _ TebalDetik Sudut = 0.1047 * (75 - Second(Now) - 0.2) .linJam(LenganDetik2).X1 = 0 .linJam(LenganDetik2).Y1 = 0 .linJam(LenganDetik2).X2 = 0.6 * Cos(Sudut) .linJam(LenganDetik2).Y2 = 0.6 * Sin(Sudut) .linJam(LenganDetik2).BorderColor = _ WarnaDetik .linJam(LenganDetik2).BorderWidth = _ TebalDetik Sudut = 0.1047 * (75 - Second(Now)) .linJam(LenganDetik3).X1 = 0 .linJam(LenganDetik3).Y1 = 0 .linJam(LenganDetik3).X2 = 0.7 * Cos(Sudut) .linJam(LenganDetik3).Y2 = 0.7 * Sin(Sudut) .linJam(LenganDetik3).BorderColor = _ WarnaDetik .linJam(LenganDetik3).BorderWidth = _ TebalDetik End With End Sub
170
Sub GetSettings() WarnaJam = CLng(VBA.GetSetting("Jam", _ "Warna", "Jam", CLng(vbRed))) WarnaMenit = CLng(VBA.GetSetting("Jam", _ "Warna", "Menit", CLng(vbGreen))) WarnaDetik = CLng(VBA.GetSetting("Jam", _ "Warna", "Detik", CLng(vbBlue))) TebalJam = CStr( _ VBA.GetSetting("Jam", "Tebal", "Jam", "5")) TebalMenit = CStr( _ VBA.GetSetting("Jam", "Tebal", "Jam", "5")) TebalDetik = CStr( _ VBA.GetSetting("Jam", "Tebal", "Jam", "5")) Alamat = CStr(VBA.GetSetting("Jam", _ "Alamat", "Gambar", App.Path & "\Jam.Bmp")) End Sub
171 172 173 174 175 176 177 178 179 180 181
Sub TutupMouse(X As Single, Y As Single) Static xAkhir, yAkhir Dim xSkr, ySkr xSkr = X: ySkr = Y If xAkhir = 0 And yAkhir = 0 Then xAkhir = xSkr yAkhir = ySkr Exit Sub End If If xSkr <> xAkhir Or ySkr <> yAkhir Then Unload Me: End
164 165 166 167 168 169
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
25
182 183
End If End Sub
Baris kode pada: frmSET 1 Option Explicit ' 2 Private Sub cmdAlamat_Click() 3 With Me.dlgSet 4 .DialogTitle = "Pilih Gambar" 5 .Flags = 4096 6 .Filter = "File Gambar|*.jpg;*.bmp;*.gif" 8 .CancelError = True 9 On Error Resume Next 10 .ShowOpen 11 If .FileName <> "" Then 12 Me.txtAlamat.Text = .FileName 13 End If 14 End With 15 End Sub 16 17 18
Private Sub cmdCancel_Click() Unload Me End Sub
19 20 21
Private Sub cmdOK_Click() SaveSettings: Unload Me End Sub
22 23
Private Sub cmdWarnaJam_Click() UbahWarna Me.cmdWarnaJam End Sub
24 25 26
Private Sub cmdWarnaMenit_Click() UbahWarna Me.cmdWarnaMenit End Sub
27 28 29
Private Sub cmdWarnaDetik_Click() UbahWarna Me.cmdWarnaDetik End Sub
30 31 32 33 34
Sub UbahWarna(ctl As Control) With Me.dlgSet .ShowColor: ctl.BackColor = .Color End With End Sub
35 36 37 38 39 40 41 42 43
Private Sub Form_Load() Dim i As Integer For i = 1 To 10 Me.cboTebalJam.AddItem CStr(i) Me.cboTebalMenit.AddItem CStr(i) Me.cboTebalDetik.AddItem CStr(i) Next GetSettings End Sub
44 45
Sub SaveSettings() VBA.SaveSetting "Jam", "Warna", "Jam", _ CStr(Me.cmdWarnaJam.BackColor) VBA.SaveSetting "Jam", "Warna", "Menit", _ CStr(Me.cmdWarnaMenit.BackColor) VBA.SaveSetting "Jam", "Warna", "Detik", _ CStr(Me.cmdWarnaDetik.BackColor) VBA.SaveSetting "Jam", "Alamat", "Gambar", _ Me.txtAlamat.Text VBA.SaveSetting "Jam", "Tebal", "Jam", _ Me.cboTebalJam.Text VBA.SaveSetting "Jam", "Tebal", "Menit", _
46 47 48 49 50
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
26
51 52 53 54 55 56 57 58 59 60 61
Me.cboTebalMenit.Text VBA.SaveSetting "Jam", "Tebal", "Detik", _ Me.cboTebalDetik.Text End Sub Sub GetSettings() Me.cmdWarnaJam.BackColor = CLng( _ VBA.GetSetting("Jam", "Warna", "Jam", _ CLng(vbRed))) Me.cmdWarnaMenit.BackColor = CLng( _ VBA.GetSetting("Jam", "Warna", "Menit", _ CLng(vbGreen))) Me.cmdWarnaDetik.BackColor = CLng( _ VBA.GetSetting("Jam", "Warna", "Detik", _ CLng(vbBlue))) Me.cboTebalJam.Text = CStr( _ VBA.GetSetting("Jam", "Tebal", "Jam", "5")) Me.cboTebalMenit.Text = CStr( _ GetSetting("Jam", "Tebal", "Menit", "5")) Me.cboTebalDetik.Text = CStr( _ GetSetting("Jam", "Tebal", "Detik", "5")) Me.txtAlamat.Text = CStr( _ VBA.GetSetting("Jam", "Alamat", "Gambar", _ App.Path & "\Jam.Bmp")) End Sub
c. Tes Program Anda tidak akan dapat menjalankan program. Anda harus membuat eksekusi dari project Anda. Klik menu FileMake ssaverVian.exe. Pada dialog Make Prooject, Almatkan kombo “Save in:” ke: “C:\Windows\System32” (untuk OS Windows XP) atau ke: “C:\Windows\ System” (untuk OS Windows 98). Ketikkan: “Screen.scr” di kotak: “File name”. Terakhir OK.
Gambar 16.11. Dialog Make Project. Minimize-kan Visual Basic Anda, atau tekan variasi tombol Logo Windows + D, pada keyboard. Pada lingkungan Desktop, klik kanan dan pilih Properties, untuk menampilkan dialog Display Properies. Klik tab: “Screen Saver”. Klik kombo: “Scrren Saver”, pastikan ditemukan list dengan teks: “Screen”. Klik tombol Settings. Silakan ubah alamat gambar, warna jarum, dan tebal jarum sesuai keinginan Anda. Klik OK. Klik tombol Preview. Jangan geserkan mouse Anda!
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
27
Gambar 16.12. Dialog Display Propertis. Menampilkan form Setting.
Gambar 16.13. Potongan Tampilan Screen Saver. Catatan: File Screen Saver yang Anda buat tidak akan ada masalah pada OS Windows 98. Jujur saja, pada OS Windows XP (SP2) saya, Screen Saver tidak dapat ditampilkan maksimal. Entah diakibatkan oleh OS yang rusak atau memang OS Windows XP (SP2) tidak menerima format Screen Saver tersebut.
16.6. Paint Mari kita mencoba membuat program pengolah grafis. Berikut ini contoh program untuk mengolah grafis seperti: Menggambar garis, kotak, dan lingkaran. Program ini mencontoh program aplikasi Ms. Paint yang merupakan program bawaan Windows untuk menggambar, menampilkan atau menangkap gambar/grafis. Program sederhana ini hanya meggunakan sebuah form. Sebelumnya seperti biasa, buat folder di: “C:\Menggali VB\Bab 16”, namai dengan “Paint”.
a. Desain Form Gambarkan 4 (empat) buah PictureBox. Ubah propertinya sebagai berikut: Pengaturan Properti Pengaturan pada: frmPaint No Objek Kontrol Properti Name BorderStyle 1 Picture1 Alignment Width (Posisi) Name BorderStyle 2 Picture2 Alignment Height (Posisi) Name AutoRedraw 3 Picture3 BorderStyle (Posisi) BackColor
Perubahan picLeft 0-None 3-Align Left 375 (Sisi kiri Form) picBawah 0-None 3-Align Bottom 645 (Sisi bawah Form) picGambar True 0-None (Sisi tengah Form) Putih
Pada picLeft gambarkan tiga buah OptionButton, ubah properti seperti pada tabel di bawah ini:
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
28
Pengaturan Properti Pengaturan pada: frmPaint No Objek Kontrol Properti Name Index Height 4 Option1 Width Style Picture Name Index Height 5 Option2 Width Style Picture Name Index Height 6 Option3 Width Style Picture
Perubahan optTool 0 375 375 1-Graphic Gambar berformat ico optTool 1 375 375 1-Graphic Gambar berformat ico optTool 2 375 375 1-Graphic Gambar berformat ico
Pada picBawah gambarkan dua buah PictureBox, empat buah Label, dan sebuah ComboBox. Ubah propertinya seperti table di bawah. Pengaturan Properti Pengaturan pada: frmPaint No Objek Kontrol Properti Name BackColor 7 Picture1 Height Width Name 8 Picture2 AutoRedraw Width 9 Label1 Caption Name 10 Label2 Caption Name 11 Label3 Caption Name 12 Label4 AutoSize Caption Name 13 Combo1 Text
Perubahan picPick Hitam 375 375 picColor True 3015 Line Width lblX X lblY Y lblRGB True R cboLineWidth 1
Tampilan akhir desain seperti gambar di berikut ini:
Gambar 16.14. Form saat didesain.
b. Baris Kode
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
29
Baris Kode Baris kode pada: frmPaint 1 Option Explicit 2 3 4 5
Dim Dim Dim Dim
6 7
Private Sub cboLineWidth_Change() Me.picGambar.DrawWidth = _ Val(Me.cboLineWidth.Text) End Sub
8 9 10 11 12 13 14
X1!, Y1!, Y1!, Y2!, cX!, cY!, LX!, LY!, PusatX!, PusatY!, Aspek!, Radius!, nTool% WarnaDasar As OLE_COLOR Seret As Boolean
Private Sub cboLineWidth_Click() Me.picGambar.DrawWidth = _ Val(Me.cboLineWidth.Text) End Sub
15
Private Sub Form_Unload(Cancel As Integer) On Error Resume Next VB.SavePicture Me.picGambar.Image, _ "C:\Gambar.bmp" End Sub
16 17 18 19 20
Private Sub optTool_Click(Index As Integer) If Me.optTool(Index).Value = True Then nTool = Index End If End Sub
21 22 23 24 25 26 27 28 29 30 31
Private Sub Form_Load() Dim i As Integer nTool = 100 BikinWarna With Me.cboLineWidth .AddItem "1" For i = 2 To 20 Step 2 .AddItem i Next End With End Sub
32 33
Private Sub Form_Resize() Me.picGambar.Move picKiri.Width, 0, _ Me.ScaleWidth - Me.picKiri.Width, _ Me.ScaleHeight - Me.picBawah.Height End Sub
34 35 36 37 38 39 40 41 42 43 44 45 46 47
Private Sub picColor_MouseUp( _ Button As Integer, Shift As Integer, _ X As Single, Y As Single) picPick.BackColor = picColor.Point(X, Y) WarnaDasar = picColor.Point(X, Y) End Sub Private Sub picGambar_MouseDown( _ Button As Integer, Shift As Integer, _ X As Single, Y As Single) Select Case nTool Case 2 Me.picGambar.MousePointer = 99 Me.picGambar.MouseIcon = _ Me.optTool(2).Picture End Select If Button And 3 Then Seret = True X1 = X: Y1 = Y: X2 = X: Y2 = Y Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
30
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103
Me.picGambar.DrawMode = 10 Me.picGambar.ForeColor = WarnaDasar If nTool = 0 Then Me.picGambar.Line (X1, Y1)- _ (X2, Y2), , B ElseIf nTool = 1 Then If Lingkaran(X1, Y1, X2, Y2) Then picGambar.Circle (PusatX, _ PusatY), Radius, , , , Aspek Radius = 0 End If ElseIf nTool = 2 Then Me.picGambar.ForeColor = WarnaDasar Me.picGambar.Line (X1, Y1)-(X, Y) End If If Button = 2 Then Me.picGambar.FillStyle = vbFSSolid Me.picGambar.FillColor = WarnaDasar End If End If End Sub Private Sub picGambar_MouseMove( _ Button As Integer, Shift As Integer, _ X As Single, Y As Single) Dim clr&, R&, G&, B& If Seret Then If nTool = 0 Then picGambar.ForeColor = WarnaDasar picGambar.Line (X1, Y1)-(X2, Y2), , B X2 = X: Y2 = Y picGambar.Line (X1, Y1)-(X2, Y2), , B ElseIf nTool = 1 Then If Lingkaran(X1, Y1, X2, Y2) Then picGambar.Circle (PusatX, PusatY), _ Radius, , , , Aspek Radius = 0 End If X2 = X: Y2 = Y If Lingkaran(X1, Y1, X2, Y2) Then picGambar.Circle (PusatX, PusatY), _ Radius, , , , Aspek Radius = 0 End If ElseIf nTool = 2 Then Me.picGambar.Line (X1, Y1)-(X, Y) X1 = X: Y1 = Y Me.picGambar.Line (X1, Y1)-(X, Y) End If End If Me.lblX.Caption = "X = " & X Me.lblY.Caption = "Y = " & Y clr = Me.picGambar.Point(X, Y) R = clr Mod 256 G = (clr \ 256) Mod 256 B = clr \ 256 \ 256 lblRGB.Caption = " R = " & G & ", G = " & _ G & ", B = " & B & " " & clr End Sub Private Sub picGambar_MouseUp( _ Button As Integer, Shift As Integer, _ X As Single, Y As Single) If Seret Then Seret = False Me.picGambar.ForeColor = WarnaDasar Me.picGambar.DrawMode = vbCopyPen If nTool = 0 Then Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
31
104 105 106 107 108 109 110 111 112 113 114 115 116
Me.picGambar.Line (X1, Y1)-(X, Y), , B ElseIf nTool = 1 Then If Lingkaran(X1, Y1, X2, Y2) Then picGambar.Circle (PusatX, PusatY), _ Radius, , , , Aspek Radius = 0 End If ElseIf nTool = 2 Then Me.picGambar.Line (X1, Y1)-(X, Y) End If Me.picGambar.FillStyle = vbFSTransparent End If Me.picGambar.MousePointer = 0 End Sub
117 118 119 120 121 122 123 124 125 126 127 128 129 130
Private Function Lingkaran(iX1, iY1, iX2, iY2) LX = Abs(iX2 - iX1) If LX <> 0 Then LY = Abs(iY2 - iY1) Aspek = Abs(LY / LX) If LX > LY Then Radius = LX / 2 Else: Radius = LY / 2 End If PusatX = iX1 + (iX2 - iX1) / 2 PusatY = iY1 + (iY2 - iY1) / 2 End If Lingkaran = LX End Function
131 132 133 134 135 136 137
Sub BikinWarna() Dim i%, HalfPic!, HPic As!, WPic As! WPic = Me.picColor.ScaleWidth HPic = Me.picColor.ScaleHeight HalfPic = Me.picColor.ScaleHeight / 2 For i = 0 To 7 Me.picColor.Line (i * (WPic / 8), _ 0)-Step(400, HalfPic), QBColor(i), BF Me.picColor.Line (i * (WPic / 8), _ HalfPic)-Step(400, _ HPic), QBColor(i + 8), BF Me.picColor.Line (i * (WPic / 8), _ 0)-Step(400, HalfPic), QBColor(15), B Me.picColor.Line (i * (WPic / 8), _ HalfPic)-Step(400, _ HPic - 20), QBColor(15), B Next End Sub
138 139 140 141 142
c. Tes Program Jalankan program, klik sebuah tombol di sisi kiri layar, pindahkan pointer ke daerah kanvas (layar tengah), kemudian lakukan dragging di daerah kanvas. Tentukan ketebalan garis dengan memilih angka ketebalan pada combobox “LineWidth”. Coba pula klik tombol bergambar Ellips, pindahkan pointer ke daerah kanvas. Lakukkan dragging dengan menggunakan klik kanan di daerah kanvas. Klik tombol Close (x). Periksa drive C dengan menggunakan Windows Explorer. Anda akan menemukan sebuah file gambar dengan format (.bmp) dengan nama Gambar.bmp. Klik ganda file tersebut. Gambar dari file tersebut adalah gambar yang telah Anda buat pada program paint tadi.
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
32
Gambar 16.15. Program sedang berjalan.
16.7. Brightness Ini adalah contoh program untuk menambahkan efek pencahayaan (brightness) suatu file gambar, yang mungkin sering Anda temukan pada program aplikasi pengolah grafis seperti CorelDraw, PhotoShop dan sebagainnya. Program ini hanya menggunakan sebuah form dan dua buah objek kontrol.
a. Desain Form Jalankan Visual Basic pada template VB Enterprise Edition Control. Masukkan sebuah PictureBox dan sebuah CommonDialog ke dalam form, kemudian atur propertinya sebagai berikut: Pengaturan Properti Pengaturan pada: Form1 No Objek Kontrol Properti Name AutoRedraw 1 Picture1 AutoSize ScaleMode Name 2 CommonDialog1
Perubahan picBright True True 3-Pixel cdlSave
Gambar 16.16. Desain form. Dengan Menu Editor, buatlah menu dan sub menu sesuai ketentuan table di bawah ini: Caption &File &Open &Save &Edit &Brightness
Name mnuFile mnuFileOpen mnuFileSaveAs mnuEdit mnuEdit Brightness
ShortCut Ctrl + O Ctrl + S Ctrl + B
CheckBox
Indentasi 0 1 1 0 1
b. Baris Kode Baris Kode Baris kode pada: Form1 1 Option Explicit Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
33
2
Private Declare Function _ SetPixelV Lib "gdi32" ( _ ByVal hDC As Long, ByVal X&, ByVal Y&, _ ByVal crColor As Long) As Byte
3
Private Declare Function _ GetPixel Lib "gdi32" (ByVal hDC As Long, _ ByVal X As Long, ByVal Y As Long) As Long
4
Const NilaTajam = 110
5 6 7
Private Sub mnuEditBrightness_Click() Dim Brightness As Single Dim WarnaBaru&, X%, Y%, R%, G%, B%
8 9 10 11
15 16 17 18 19 20 21 22 23
Brightness = NilaTajam / 100 For X = 0 To picBright.ScaleWidth For Y = 0 To picBright.ScaleHeight WarnaBaru = GetPixel( _ picBright.hDC, X, Y) R = (WarnaBaru Mod 256) B = (Int(WarnaBaru / 65536)) G = ((WarnaBaru - (B * 65536) _ - R) / 256) R = R * Brightness B = B * Brightness G = G * Brightness If R > 255 Then R = 255 If R < 0 Then R = 0 If B > 255 Then B = 255 If B < 0 Then B = 0 If G > 255 Then G = 255 If G < 0 Then G = 0
24 25 26 27 28 29
SetPixelV picBright.hDC, X, Y, RGB(R, G, B) Next Y If X Mod 10 = 0 Then picBright.Refresh Next X picBright.Refresh End Sub
30 31 32 33 34 35 36 37
Private Sub mnuFileOpen_Click() With Me.cdlSave .DialogTitle = "Open" .Filter = "Gambar|*.bmp;*jpg;*gif" .CancelError = False .ShowOpen If Len(.FileName) <> 0 Then Me.picBright.Picture = _ LoadPicture(.FileName) End If End With End Sub
12 13 14
38 39 40 41 42 43 44 45 46 47 48 49 50 51
Private Sub mnuFileSaveAs_Click() With Me.cdlSave .DialogTitle = "Save As" .Filter = "Bmp|*.bmp" .CancelError = False .ShowSave If Len(.FileName) <> 0 Then SavePicture Me.picBright.Image, _ .FileName End If End With End Sub
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
34
c. Tes Program Jalankan program, klik menu FileOpen, cari sebuah file gambar bitmap (bmp), klik menu EditBrightness. Efek brightness gambar akan bertambah. Klik kembali menu EditBrightness atau tekan Ctrl + B pada keyboard untuk menambah efek brightness.
16.8. Jaringan MLM Contoh program berikut ini adalah kutipan dari program aplikasi pengolah data MLM (Multi Level Marketing). Program ini menampilkan data jaringan seorang mitra suatu MLM. Dimana MLM ini menerapkan menggunakan sistem dua bawahan, artinya seorang mitra harus mempunyai dua orang mitra baru sebagai ‘bawahan’. Program berikut ini juga mengimplementasikan penggunaan variable array dinamis multidimensi, khusunya variable array dengan dimesi tiga. Buatlah sebuah folder di alamat: “C:\Menggali VB\Bab 16” dengan nama “MLM”.
a. Desain Database Sebelum memulai project, Anda harus membuat sebuah database. Dengan Ms. Access, buatlah sebuah file database dengan nama: “Data.mdb”, simpan database Anda di: “C:\Menggali VB\Bab 16\MLM”. Berikut ini struktur database yang harus Anda buat: Nama Tabel tblMitra Nama Field NO MITRA ID1 ID2 NAMA MITRA Primary Index pada:
Tipe Text Number Number Text NO MITRA
Ukuran 10 Long Integer Long Integer 50
Isikan sebanyak 20 (dua puluh) data ke dalam tblMitra tersebut, data seperti pada table di bawah ini. Nama Tabel NO MITRA 070510001 070510002 070510003 070510004 070510005 070510006 070510007 070510008 070510009 070510010 070510011 070510012 070510013 070510014 070510015 070510016 070510017 070510018 070510019 070510020
tblMitra ID1 0 1 1 2 2 2 2 3 3 3 3 3 3 3 3 4 4 4 4 4
ID2 1 1 2 1 2 3 4 1 2 3 4 5 6 7 8 1 2 3 4 5
NAMA MITRA AGUNG VIANSASTRA NOVIAN SYAIFULAH AJAT JATNIKA PURBADI SAEPUL MIKDAR ARIF PERMANA YUDI ARMAN SANTOSO ABE HARIS A. SUBANA RITA ROSITA AYU DEWI SUHARYANTO FANNY PRATIWI R. RUDI PRAWIRANEGARA RETNO OKTAVIANI IRMA IRMAYANTI RUSMANJAYA RADEN ZAKARIA MOH. SANAJI
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
35
Gambar 16.17. Desain database dengan Ms. Access.
b. Desain Form Jalankan Visual Basic pada template VB Enterprise Edition Control. Tambahkan sebuah module. Namai degan mdlJaringan. Pada form tambahkan objek kontrol-objek kontrol dan atur propertinya, seperti pada table di bawah ini. Pengaturan Properti Pengaturan pada: Form1 No Objek Kontrol Properti 1 Label1 Caption 2 Combo1 Name Name 3 Command1 Caption Name Indentation 4 TreeView1 FullRowSelect HotTracking LabelEdit Name FullRowSelect 5 ListView1 GridLines LabelEdit View Name 6 Adodc1 Align Name 7 ImageList1 ImageHeight ImageWidth
Perubahan No. Mitra cboNoMitra cmdNama &Baca Nama trvAdo 100 True True 1-tvwManual lvwMitra True True 1-lvwManual 3-lvwReport adoData 2-vbAlignBottom imlIkon 16 16
Pada imlIkon, klik kanan, pilih Properties. Pada dialog yang ditampilkan, klik tab Images, klik tombol Insert Pictures…, masukkan setidaknya tiga buah gambar dengan format ikon (.ico). Tampilan akhir desain seperti gambar di bawah ini.
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
36
Gambar 16.18. Desain form.
c. Baris Kode Baris Kode Baris kode pada: Module1 1 Option Explicit 2 Public NoMitraLv(10, 100, 100) As String 3 Public NamaMitraLv(10, 100, 100) As String 4 Public DS$(100, 100) 5 Public NDL$(10, 100, 100) 6 Public Const iJumDs As Integer = 2 ' 7 Function TentukanIDDSAll(iID As String _ ) As String 8 On Error Resume Next 9 Dim nID(100) As String, nID1$, nID2$ 10 Dim i&, r&, s&, t&, J%, iSpr% 11 iSpr = InStr(iID, "-") 12 nID1 = Mid(iID, 1, Val(iSpr) - 1) 13 nID2 = Mid(iID, (iSpr + 1)) 14 r = nID2 - 1 15 s = r * iJumDs + 1 16 t = s + iJumDs - 1 17 For i = s To t 18 TentukanIDDSAll = TentukanIDDSAll & _ CStr(CLng(nID1 + 1)) & "-" & CStr(i) & "%" 19 Next 20 End Function ' 21 Function TentukanID_DS(iID As String, _ Optional N As Integer = 0) As String 22 On Error Resume Next 23 Dim nID(100) As String 24 Dim i&, J%, iSpr%, IDAll As String 25 IDAll = TentukanIDDSAll(iID) 26 J = 1 27 For i = 1 To Len(IDAll) 28 iSpr = InStr(i, IDAll, "%") 29 If iSpr <> 0 Then 30 nID(J) = Mid(IDAll, i, iSpr - i) 31 i = iSpr 32 J = J + 1 33 Else 34 Exit For 35 End If 36 Next 37 TentukanID_DS = nID(N) 38 End Function ' 39 Function NoMitratoID$(NoMitra As String) 40 On Error Resume Next 41 If NoMitra <> "" Then 42 With FTreeView.adoData 43 .RecordSource = _ "SELECT * FROM " & _ "tblMitra WHERE [NO MITRA]='" _ & NoMitra & "'" 44 .Refresh 45 With .Recordset 46 If .RecordCount <> 0 Then 47 NoMitratoID = ![ID1] _ & "-" & ![ID2] 48 Else 49 NoMitratoID = "" 50 End If 51 End With 52 End With Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
37
53 54 55 56 57 58 59
60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
81 82 83 84 85 86 87 88 89 90 91 92
End If End Function ' Function NamaMitra$(NoMitra$) On Error Resume Next If NoMitra$ <> "" Then With FTreeView.adoData .RecordSource = "SELECT * FROM " & _ "tblMitra WHERE [NO MITRA]='" & _ NoMitra$ & "'" & _ " OR Right([NO MITRA],4) ='" & _ Right(NoMitra, 4) & "'" .Refresh With .Recordset If .RecordCount <> 0 Then NamaMitra = ![NAMA MITRA] Else NamaMitra$ = "" End If End With End With End If End Function ' Function IDtoNoMitra$(iID As String) On Error Resume Next Dim nID1$, nID2$, iSpr% If iID <> "" Then If Len(iID) > 1 Then iSpr = InStr(iID, "-") nID1 = Mid(iID, 1, Val(iSpr) - 1) nID2 = Mid(iID, (iSpr + 1)) With FTreeView.adoData .RecordSource = _ "SELECT * FROM " & _ "tblMitra WHERE [ID1]=" & _ nID1 & " AND [ID2]=" & nID2 & "" .Refresh With .Recordset If .RecordCount <> 0 Then IDtoNoMitra = ![NO MITRA] Else IDtoNoMitra = "" End If End With End With End If End If End Function
Baris kode pada: Form1 1 Option Explicit ' 2 Dim myList As ListItem ' 3 Private Sub cboNoMitra_Click() 4 On Error Resume Next 5 Call BuatTreeLevel(Me.cboNoMitra.Text) 6 Set myList = Me.lvwMitra.FindItem( _ 7 Me.cboNoMitra.Text, 1, , 1) myList.EnsureVisible myList.Selected = True 8 Me.lvwMitra.SetFocus 9 End Sub ' 10 Private Sub cmdNama_Click() 11 Me.LihatNama 12 End Sub Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
38
13 14 15 16 17 18 19 20 21
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
' Private Sub Form_Load() Set Me.trvAdo.ImageList = Me.imlIkon Set Me.lvwMitra.Icons = Me.imlIkon Set Me.lvwMitra.ColumnHeaderIcons = Me.imlIkon Set Me.lvwMitra.SmallIcons = Me.imlIkon Call BuatKolom Me.Show With Me.adoData .ConnectionString = _ "Provider=Microsoft" & _ ".Jet.OLEDB.4.0;Data Source=" & _ App.Path & "\data.mdb;" & _ "Persist Security Info=False" .RecordSource = _ "Select * From tblMitra Order" & _ " By RIGHT([NO MITRA],4)" .Refresh With .Recordset While Not .EOF Me.cboNoMitra.AddItem _ CStr(![NO MITRA]) Set myList = Me.lvwMitra.ListItems _ .Add(, , Format( _ .AbsolutePosition, "000") , 1, 1) myList.SubItems(1) = _ CStr(![NO MITRA]) myList.SubItems(2) = _ CStr(![NAMA MITRA]) .MoveNext DoEvents Wend End With End With Me.cboNoMitra.ListIndex = 0 End Sub ' Sub TambahNode(X%, i%, A%, B%) On Error Resume Next DS$(B, i) = TentukanID_DS(NoMitratoID( _ NDL$(A - 1, X, i)), B) NDL$(A, B, i) = IDtoNoMitra(DS(B, i)) NoMitraLv(A, B, i) = NDL$(A, B, i) With Me.trvAdo.Nodes .Add "M-" & NoMitraLv(A - 1, X, i), _ tvwChild, "M-" & NoMitraLv(A, B, i), _ NoMitraLv(A, B, i), 1, 2 NamaMitraLv(A, B, i) = _ NamaMitra(NoMitraLv(A, B, i)) End With End Sub ' Sub BuatTreeLevel(NoMitra$) Dim nID$, i%, J%, K%, L%, M%, N%, O%, X% On Error Resume Next nID = NoMitratoID(NoMitra$) With Me.trvAdo.Nodes .Clear .Add , , "M-" & NoMitra, NoMitra, 1, 2 For X = 1 To 1 For i = 1 To iJumDs DS$(X, i) = TentukanID_DS(nID, i) NDL$(1, X, i) = _ IDtoNoMitra(DS(X, i)) NoMitraLv(1, X, i) = NDL$(1, X, i) .Add "M-" & NoMitra, tvwChild, _ "M-" & NoMitraLv(1, X, i), _ NoMitraLv(1, X, i), 1, 1 Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
39
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
If DS$(X, i) <> "" Then For J = 1 To iJumDs TambahNode X, i, 2, J If DS$(J, i) <> "" Then For K = 1 To iJumDs TambahNode J, i, 3, K If DS$(K, J) <> "" Then For L = 1 To iJumDs TambahNode K, J, 4, L If DS$(L, K) <> "" Then For M = 1 To iJumDs TambahNode L, K, 4, M Next End If Next End If Next End If Next End If Next Next End With Call SimpanTag End Sub ' Sub SimpanTag() Dim i As Integer With Me.trvAdo For i = 1 To .Nodes.Count .Nodes(i).Tag = .Nodes(i).Text .Nodes(i).Selected = True Next End With End Sub ' Sub LihatNama() Dim i As Integer With Me.trvAdo If .Nodes(1).Tag = "" Then Me.SimpanTag End If For i = 1 To .Nodes.Count .Nodes(i).Text = .Nodes(i).Text & _ " -=> " & NamaMitra(.Nodes(i).Tag) Next End With End Sub ' Sub BuatKolom() With Me.lvwMitra.ColumnHeaders .Add , , "No", 800, , 1 .Add , , "No Mitra", 1500, , 2 .Add , , "Nama Mitra", 2800, , 3 End With End Sub
d. Tes Program Jalankan program! Tunggu beberapa saat, pada treeview akan tergambar jaringan seorang mitra dengan nomor mitra: “070510001”. Klik tombol Baca Nama, untuk menampilkan nama-nama mitra. Cobalah pilih nomor mitra lainnya dari kombo No Mitra.
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
40
Gambar 16.19. Program sedang berjalan.
16.9. HTML Maker Berikut ini contoh program untuk membuat dan mengedit file web atau HTML. Bagi Anda yang biasa menggunakan Notepad untuk membuat HTML, sekarang saatnya beralih ke program buatan Anda sendiri. Seperti biasa, buatlah sebuah folder baru, di alamat: “C:\Menggali VB\Bab 16”, namai dengan: “HTMLMaker”.
a. Desain Form Namai form dengan frmHTML. Buatlah menu-menu dengan ketentuan seperti pata tabel berikut ini: Name mnuFile mnuFileNew mnuFileOpen Spr11 mnuFileSave mnuFileSaveAs mnuFileExit mnuEdit mnuEditUndo mnuEditRedo Spr21 mnuEditCut mnuEditCopy mnuEditPaste mnuView mnuViewWeb
Caption &File &New &Open &Save Save &As... E&xit &Edit &Undo &Redo C&ut &Copy &Paste &View &Web Page
Shortcut Ctrl+N Ctrl+O Ctrl+S F12 Ctrl+Q Ctrl+Z Ctrl+Y Ctrl+X Ctrl+C Ctrl+V Ctrl+W
Indentasi 0 1 1 1 1 1 1 0 1 1 1 1 1 1 0 1
Masukkan objek kontrol-objek kontrol berikut ini, dan atur properti-propertinya: Pengaturan Properti Pengaturan pada: Form1 No Objek Kontrol Properti Name Align 1 Picture1 BorderStyle Height Name 2 RichTextBox1 Appearance ScrollBar 3 CommonDialog1 Name Name 4 ImageList1 ImageHeight ImageWidth
Perubahan picTop 1-Align Top 0-Nono 855 rtbHTML 1-Flat 3-Both cdlHTML imlHTML 16 16
Pada kontrol ImageList, masukkan picture sebanyak 9 (sembilan) buah. Picture-picture ini bisa Anda dapatkan pada CD. Pada picTop, gambarkan objek kontrol-objek kontrol berikut ini dan atur properti-propertinya. Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
41
Pengaturan Properti Pengaturan pada: Form1 No Objek Kontrol Properti Name 5 ToolBar1 BorderStyle Style Name 6 Combo1 Style Sorted Name 7 Combo2 Style Sorted Name 8 Combo1 Style Sorted Name Index Max 9 HScrollBar1 LargeChange SmallChange Value Name Index Max 10 HScrollBar2 LargeChange SmallChange Value Name Index Max 11 HScrollBar3 LargeChange SmallChange Value Name 12 Picture1 BackColor
Perubahan tblHTML 0-ccNone 1-tbrFlat cboFormat 2-DropDownList True cboProperti 2-DropDownList True cboInsert 2-DropDownList True hscRGB 0 255 1 1 90 hscRGB 1 255 1 1 110 hscRGB 2 255 1 1 140 picWarna Putih
Klik kanan pada ToolBar: tlbHTML, pilih Properties. Kaitkan properti ImageList dengan imlHTML. Tambahkan tombol-tombol pada tlbHTML sebanyak 12 (dua belas), kemudian atur properti dari tombol-tombol tersebut seperti pada tabel di bawah ini: Properti pada: Index Style 1 0-tbrDefault 2 0-tbrDefault 3 0-tbrDefault 4 3-tbrSeparator 5 0-tbrDefault 6 0-tbrDefault 7 0-tbrDefault 8 3-tbrSeparator 9 0-tbrDefault 10 0-tbrDefault 11 3-tbrSeparator 12 0-tbrDefault
Button tlbHTML ToolTipText New (Ctrl+N) Open (Ctrl+O) Save (Ctrl+S)
Image 1 2 3
Cut (Ctrl+X) Copy (Ctrl+C) Paste (Ctrl+V)
4 5 6
Undo (Ctrl+Z) Redo (Ctrl+Y)
7 8
Bowse (Ctrl+W)
9
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
42
Gambar 16.20. Desain Form. Tambahkan dua buah Module pada project Anda, namai dengan: mdlHTML dan mdlUndo.
b. Baris Kode Baris Kode Baris kode pada: mdlHTML 1 Option Explicit 2
Public Declare Function ShellExecute _ Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As Long, _ ByVal lpOperation As String, _ ByVal lpFile As String, _ ByVal lpParameters As String, _ ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long
3
Function MyShell(PathAndFile As String, _ Optional Parameters As String = "", _ Optional ShowCmd As Long _ = vbNormalNoFocus) As Long Dim Path As String, File As String On Error Resume Next Path = Left(PathAndFile, _ InStrRev(PathAndFile, "\")) While (Right$(Path, 1) = "\") Path = Left(Path, Len(Path) - 1) Wend File = Mid$(PathAndFile, _ InStrRev(PathAndFile, "\") + 1) MyShell = ShellExecute(0, vbNullString, _ File, Parameters, Path, ShowCmd) If MyShell < 32 Then Shell PathAndFile, _ ShowCmd End Function
4 5 6 7 8 9 10 11 12 13 14 15 16
17
Function StrukturAwal() As String StrukturAwal = "" & vbCrLf & _ vbCrLf & vbCrLf & " " & vbCrLf & "<TITLE> " & ".:. My Web .:. " vbCrLf & vbCrLf & " " & _ vbCrLf & " " & vbCrLf & vbCrLf & " " & vbCrLf & _ "" & vbCrLf & "" End Function
18 19 20
Sub fFormat(FRM As Form, sFormat As String) Dim xClip As String, xHasil As String On Error Resume Next
_ & _ _ _
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
43
21 22 23 24 25 26 27 28 29 30 31 32 33
xClip = FRM!rtbHTML.SelText xHasil = "<" & sFormat & ">" & _ xClip & "" FRM!rtbHTML.SelRTF = Replace( _ FRM!rtbHTML.SelText, xClip, xHasil, , 2) End Sub Sub fTAG(FRM As Form, sFormat As String) Dim Awal%, xHasil As String On Error Resume Next Awal% = FRM!rtbHTML.SelStart xHasil = "<" & sFormat & ">" & _ " " & "" FRM!rtbHTML.SelRTF = xHasil FRM!rtbHTML.SelStart = Awal + (Len(xHasil)\ 2) End Sub
Baris kode pada: mdlUndo 1 Option Explicit 2 3 4 5 6
Private vItem As Variant Private UniqueNum& Public Dirty As Boolean Public ColUndo As New Collection Public ColRedo As New Collection
7 8 9 10 11 12 13 14 15 16
Public Sub DeleteCollections() On Error Resume Next For Each vItem In ColUndo ColUndo.Remove 1 Next For Each vItem In ColRedo ColRedo.Remove 1 Next UniqueNum = 0 End Sub
17 18 19 20 21 22 23
Public Sub UpdateUndo() On Error Resume Next UniqueNum = UniqueNum + 1 ColUndo.Add frmHTML.rtbHTML.Text, _ CStr(UniqueNum) If Dirty = False Then Exit Sub Dirty = True End Sub
24 25 26 27 28 29 30 31 32 33 34
Public Sub DoUnDo() On Error Resume Next With frmHTML.rtbHTML .Text = ColUndo.Item(ColUndo.Count) .Refresh ColRedo.Add ColUndo.Item(ColUndo.Count) ColUndo.Remove ColUndo.Count .Text = ColUndo.Item(ColUndo.Count) .Refresh End With End Sub
35 36 37 38 39 40 41 42 43 44
Public Sub DoReDo() On Error Resume Next With frmHTML.rtbHTML .Text = ColUndo.Item(ColUndo.Count) .Refresh ColUndo.Add ColRedo.Item(ColRedo.Count) ColRedo.Remove ColRedo.Count .Text = ColUndo.Item(ColUndo.Count) .Refresh End With Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
44
45
End Sub
46 47 48 49 50 51
Public Sub ClearRedo() On Error Resume Next For Each vItem In ColRedo ColRedo.Remove 1 Next End Sub
Baris kode pada: frmHTML 1 Option Explicit 2 3
Dim BukaAlamat$, KonstWarna$ Dim SudahSimpan As Boolean
4 5 6 7 8
Private Sub cboProperti_Click() On Error Resume Next rtbHTML.SelText = " " & Me.cboProperti & "=" Me.rtbHTML.SetFocus End Sub
9
14 15 16 17 18 19 20 21 22
Private Sub Form_QueryUnload( _ Cancel As Integer, UnloadMode As Integer) Dim Pesan$ If Not (SudahSimpan) Then Cancel = 1 Pesan = MsgBox( _ "Akhir perubahan belum tersimpan" & _ "Klik Yes untuk menyimpan.", _ vbQuestion + vbYesNoCancel) If Pesan = vbYes Then mnuFileSave_Click: Cancel = 0 ElseIf Pesan = vbNo Then Cancel = 0 Else: Cancel = 1 Me.rtbHTML.SetFocus End If End If End Sub
23 24 25 26 27
Private Sub mnuEditCopy_Click() With Me.rtbHTML Clipboard.SetText .SelText End With End Sub
28 29 30 31 32 33 34 35
Private Sub mnuEditCut_Click() UpdateUndo With Me.rtbHTML Clipboard.SetText .SelText .SelText = vbNullString UpdateUndo End With End Sub
36 37 38 39 40 41 42
Private Sub mnuEditPaste_Click() UpdateUndo With Me.rtbHTML .SelText = Clipboard.GetText UpdateUndo End With End Sub
43 44 45
Private Sub mnuEditRedo_Click() DoReDo End Sub
46
Private Sub mnuEditUndo_Click()
10 11 12 13
Menggali Lebih Dalam Ms. Visual Basic 6.0 – Agung Novian
45
47 48
DoUnDo End Sub
49 50 51
Private Sub mnuFileExit_Click() Unload Me End Sub
52 53 54 55 56 57 58 59 60
Private Sub mnuFileNew_Click() With Me.rtbHTML .Text = StrukturAwal .SelStart = InStr(UCase(.Text), _ "
