Jumat, 05 September 2008

Modul VB 3 Lanjutan



Lnjutan Modul 3

Source Code



Option Explicit
Public appexcel As Excel.Application
Public wbexcel As Excel.Workbook

Sub Setup()
On Error Resume Next
Set appexcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set appexcel = CreateObject("Excel.Application")
End If
Err.Clear
On Error GoTo 0
Set wbexcel = appexcel.Workbooks.Open(App.Path & "\data2.xls")
End Sub

Sub Bersih()
Set appexcel = Nothing
Set wbexcel = Nothing
End Sub
Sub IsiWSheet()
Dim shtMahasiswa As Excel.Worksheet
For Each shtMahasiswa In wbexcel.Sheets
FBukaExcel.cmbSheet.AddItem shtMahasiswa.Name
Next
FBukaExcel.cmbSheet.Text = FBukaExcel.cmbSheet.List(0)
Set shtMahasiswa = Nothing
End Sub


Sub TAmpilpitur()
Dim shtexcel As Excel.Worksheet
Dim Rangefitur As Excel.Range
Dim kolompertama As Integer
Dim loop1 As Integer

FBukaExcel.LstExcel.Visible = True

Set shtexcel = wbexcel.Sheets(FBukaExcel.cmbSheet.Text)
Set Rangefitur = shtexcel.Rows(1)

If (Rangefitur.Cells(1, 1) = "") Then
kolompertama = 0
Else
kolompertama = Rangefitur.Find("").Column
End If

FBukaExcel.cmbKolom.Clear

For loop1 = 1 To kolompertama
FBukaExcel.cmbKolom.AddItem Rangefitur.Cells(1, loop1)
Next

FBukaExcel.cmbKolom.Text = FBukaExcel.cmbKolom.List(0)

Set shtexcel = Nothing
Set Rangefitur = Nothing
End Sub

Sub Listmaster()
Dim shtexcel As Excel.Worksheet
Dim Integerkolom As Integer
Dim rangeexcel As Excel.Range
Dim kolompertama As Integer
Dim loop1 As Integer

Set shtexcel = wbexcel.Sheets(FBukaExcel.cmbSheet.Text)
FBukaExcel.LstExcel.Clear
If (FBukaExcel.cmbKolom <> "") Then
Integerkolom = shtexcel.Rows(1).Find(FBukaExcel.cmbKolom.Text).Column
Set rangeexcel = shtexcel.Columns(Integerkolom)
If (rangeexcel.Cells(1, 1) = "") Then
kolompertama = 0
Else
kolompertama = rangeexcel.Find("").Row
End If
For loop1 = 2 To kolompertama
FBukaExcel.LstExcel.AddItem rangeexcel.Cells(loop1, 1)
Next
FBukaExcel.LstExcel.Visible = True

End If

Set shtexcel = Nothing
Set rangeexcel = Nothing
End Sub


Private Sub CMDKELUAR_Click()
End
End Sub

Sub Form_Load()
Setup
IsiWSheet
End Sub

Sub Form_Unload(Cancel As Integer)
Bersih
End Sub

Private Sub cmbSheet_Change()
FillFeaturesList
End Sub

Private Sub cmbKolom_Change()
Listmaster
End Sub

Sub cmbkolom_Click()
Listmaster
End Sub

Sub cmbsheet_Click()
TAmpilpitur
End Sub

Modul VB 3


Modul 3

Komponen yang dibutuhkan :
3 tombol Command

Rancanglah seperti tampilan Form berikut:
Properti yang diubah:
a.command1
Name : CMDBukaWord
Caption : &Buka m_i_crosoft word
b.command2
Name : CMDPutusWord
Caption : &Putus Koneksi
c.command3
Name : CMDKeluar
Caption : &Keluar


Source Code :

Option Explicit
Public appword As Word.Application
Public halword As Word.Document

Private Sub CMDKELUAR_Click()
End
End Sub

Private Sub CmdBukaWord_Click()
On Error Resume Next
Set appword = GetObject(, "word.Application")
If Err.Number <> 0 Then
Set appword = CreateObject("word.Application")
End If
Err.Clear
On Error GoTo 0
Set halword = appword.Documents.Open(App.Path & "\data.doc")
End Sub

Private Sub CmdPutusWord_Click()
Set appword = Nothing
Set halword = Nothing

End Sub

Sub Form_Unload(Cancel As Integer)
Set appword = Nothing
Set halword = Nothing
End Sub

modul VB 2



Modul 2

Component yang dibutuhkan :
- 5 Image
- 1 commandButton
- 1 shape
- 1 label
- 1 PictureBox


Source Code:

Option Explicit
Private Sub cmdKeluar_Click()
Unload Me
End Sub

Private Sub Form_Load()
shpkotak.Left = -500
End Sub

Private Sub img1_Click()
shpkotak.Left = img1.Left
StatusGB.Cls
StatusGB.Print "Anda memilih : Gambar 1"
End Sub

Private Sub img2_Click()
shpkotak.Left = img2.Left
StatusGB.Cls
StatusGB.Print "Anda memilih : Gambar2"
End Sub


Private Sub img3_Click()
shpkotak.Left = img3.Left
StatusGB.Cls
StatusGB.Print "Anda memilih : Gambar 3 "
End Sub


Private Sub img4_Click()
shpkotak.Left = img4.Left
StatusGB.Cls
StatusGB.Print "Anda memilih : Gambar 4"
End Sub

Private Sub img5_Click()
shpkotak.Left = img5.Left
StatusGB.Cls
StatusGB.Print "Anda memilih : Gambar 5"
End Sub

Modul Hitung



Private Sub cmdproses_Click()

Dim TanggalA, tanggalB As Date

Dim hr, bl As Double

Dim UsiaTH, usiabl, usiahr, pesan

TanggalA = DTPicker1.Value

tanggalB = DTPicker2.Value

If (tanggalB <= TanggalA) Then

pesan = MsgBox("batas perhitungan tanggal harus lebih besar dari tanggal lahir", vbCritical, "PERINGATAN")

Else

UsiaTH = DateDiff("yyyy", TanggalA, tanggalB)

Textth.Text = UsiaTH

usiabl = DateDiff("m", TanggalA, tanggalB)

bl = usiabl Mod 12

Textbl.Text = bl

usiahr = DateDiff("d", TanggalA, tanggalB)

hr = usiahr Mod 31

Texthr.Text = hr

End If

End Sub

Private Sub cmdtutup_Click()

Unload Me

End Sub

Private Sub DTPicker1_Change()

Dim Tanggal As Date

Dim Angkahari

Dim hari

nhari = Array("", "MINGGU", "SENIN", "SELASA", "RABU", "KAMIS", "JUMAT", "SABTU")

Tanggal = DTPicker1.Value

Angkahari = DatePart("w", Tanggal, vbSunday)

hari = nhari(Angkahari)

lbllahir.Caption = hari

End Sub