'Dalam contoh ini, kursor tidak akan dapat _
keluar dari 'textbox, sampai user mengetik: _
"abc". Untuk memeriksa 'coding ini, coba _
klik pada tombol atau enter textbox 'yang kedua.
-1 Textbox dan 1 CommandButton
------------------------------------------------
Private Sub Text1_Validate(Cancel As Boolean)
Cancel = Text1.Text <> "abc"
End Sub
Rabu, 13 Agustus 2008
Perbedaan Fungsi Date dan Date$
Private Sub Command1_Click()
MsgBox DateTime.Date '--> Menghasilkan tanggal hari
'ini, sesuai dengan setting format tanggal di
'komputer 'Anda.
'Contoh: Jika tgl hari ini = 22 Januari 2002 dan
'format Short Date Style di Regional Setting =
'"dd/mm/yyyy", akan menghasilkan: 22/01/2002
MsgBox DateTime.Date$ '--> Menghasilkan tanggal hari
'ini dengan format tanggal Standar Internasional,
'yaitu: "mm-dd-yyyy"
'Contoh: (sama dengan di atas), maka akan
'menghasilkan: 01/22/2002
End Sub
MsgBox DateTime.Date '--> Menghasilkan tanggal hari
'ini, sesuai dengan setting format tanggal di
'komputer 'Anda.
'Contoh: Jika tgl hari ini = 22 Januari 2002 dan
'format Short Date Style di Regional Setting =
'"dd/mm/yyyy", akan menghasilkan: 22/01/2002
MsgBox DateTime.Date$ '--> Menghasilkan tanggal hari
'ini dengan format tanggal Standar Internasional,
'yaitu: "mm-dd-yyyy"
'Contoh: (sama dengan di atas), maka akan
'menghasilkan: 01/22/2002
End Sub
Minimize Semua Window
- Ketik diForm
Private Sub Command1_Click()
Call keybd_event(VK_LWIN, 0, 0, 0)
Call keybd_event(&H4D, 0, 0, 0)
Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
End Sub
--------------------------------------------------
- Ketik diModule
Declare Sub keybd_event Lib "user32" (ByVal bVk _
As Byte, ByVal bScan As Byte, ByVal dwFlags As _
Long, ByVal dwExtraInfo As Long)
Public Const VK_LWIN = &H5B
Public Const KEYEVENTF_KEYUP = &H2
Private Sub Command1_Click()
Call keybd_event(VK_LWIN, 0, 0, 0)
Call keybd_event(&H4D, 0, 0, 0)
Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
End Sub
--------------------------------------------------
- Ketik diModule
Declare Sub keybd_event Lib "user32" (ByVal bVk _
As Byte, ByVal bScan As Byte, ByVal dwFlags As _
Long, ByVal dwExtraInfo As Long)
Public Const VK_LWIN = &H5B
Public Const KEYEVENTF_KEYUP = &H2
Menutup Semua Form
Private Sub Command2_Click()
Dim Form As Form
For Each Form In Forms
Unload Form
Set Form = Nothing
Next Form
End Sub
Dim Form As Form
For Each Form In Forms
Unload Form
Set Form = Nothing
Next Form
End Sub
Mengurutkan Abjad
Private Sub Command1_Click()
Dim sAbjad() As String, ar As Integer, _
br As Integer, sAbjadTemp As String
Text2.Text = ""
ReDim sAbjad(Len(Text1.Text) - 1)
For ar = 1 To Len(Text1.Text)
sAbjad(ar - 1) = Mid(Text1.Text, ar, 1)
Next ar
For ar = LBound(sAbjad) To UBound(sAbjad)
For br = LBound(sAbjad) To UBound(sAbjad) - 1
If sAbjad(br) > sAbjad(br + 1) Then
sAbjadTemp = sAbjad(br + 1)
sAbjad(br + 1) = sAbjad(br)
sAbjad(br) = sAbjadTemp
End If
Next br
Next ar
For ar = LBound(sAbjad) To UBound(sAbjad)
Text2.Text = Text2.Text & sAbjad(ar)
Next ar
End Sub
Private Sub Form_Load()
Text1.Text = "QWERTYUIOPASDFGHJKLZXCVBNM"
Text2.Text = ""
End Sub
Dim sAbjad() As String, ar As Integer, _
br As Integer, sAbjadTemp As String
Text2.Text = ""
ReDim sAbjad(Len(Text1.Text) - 1)
For ar = 1 To Len(Text1.Text)
sAbjad(ar - 1) = Mid(Text1.Text, ar, 1)
Next ar
For ar = LBound(sAbjad) To UBound(sAbjad)
For br = LBound(sAbjad) To UBound(sAbjad) - 1
If sAbjad(br) > sAbjad(br + 1) Then
sAbjadTemp = sAbjad(br + 1)
sAbjad(br + 1) = sAbjad(br)
sAbjad(br) = sAbjadTemp
End If
Next br
Next ar
For ar = LBound(sAbjad) To UBound(sAbjad)
Text2.Text = Text2.Text & sAbjad(ar)
Next ar
End Sub
Private Sub Form_Load()
Text1.Text = "QWERTYUIOPASDFGHJKLZXCVBNM"
Text2.Text = ""
End Sub
Memisahkan Komponen Tanggal
Private Sub Command1_Click()
Dim hari As Integer, bulan As Integer, tahun As Integer
hari = DateTime.DatePart("d", _
CDate("22/01/1973"), _
vbUseSystemDayOfWeek, _
vbUseSystem) 'Menghasilkan 22
bulan = DateTime.DatePart("m", _
CDate("22/01/1973"), _
vbUseSystemDayOfWeek, _
vbUseSystem) 'Menghasilkan 1
tahun = DateTime.DatePart("yyyy", _
CDate("22/01/1973"), _
vbUseSystemDayOfWeek, _
vbUseSystem) 'Menghasilkan 1973
MsgBox hari
MsgBox bulan
MsgBox tahun
End SUb
Dim hari As Integer, bulan As Integer, tahun As Integer
hari = DateTime.DatePart("d", _
CDate("22/01/1973"), _
vbUseSystemDayOfWeek, _
vbUseSystem) 'Menghasilkan 22
bulan = DateTime.DatePart("m", _
CDate("22/01/1973"), _
vbUseSystemDayOfWeek, _
vbUseSystem) 'Menghasilkan 1
tahun = DateTime.DatePart("yyyy", _
CDate("22/01/1973"), _
vbUseSystemDayOfWeek, _
vbUseSystem) 'Menghasilkan 1973
MsgBox hari
MsgBox bulan
MsgBox tahun
End SUb
Membuat Form Sebagai Array
Private Sub Command1_Click()
Dim intX As Integer
Dim frmNew(1 To 5) As New Form1
For intX = 1 To 5
frmNew(intX).Show
frmNew(intX).WindowState = vbMinimized
'Untuk membuat form yang diminimized tanpa
'memiliki ukuran normal pada saat tampilan
'awalnya, ganti urutan coding dari dua baris di
'atas, sehingga nantinya menjadi:
'frmNew(intX).WindowState = vbMinimized
'frmNew(intX).Show
Next
End Sub
Dim intX As Integer
Dim frmNew(1 To 5) As New Form1
For intX = 1 To 5
frmNew(intX).Show
frmNew(intX).WindowState = vbMinimized
'Untuk membuat form yang diminimized tanpa
'memiliki ukuran normal pada saat tampilan
'awalnya, ganti urutan coding dari dua baris di
'atas, sehingga nantinya menjadi:
'frmNew(intX).WindowState = vbMinimized
'frmNew(intX).Show
Next
End Sub
Membalikkan Tulisan
Private Sub Command1_Click()
Text1.Text = BalikkanString(Text1.Text)
End Sub
Function BalikkanString(strKalimat As String) As String
Dim i As Integer, Panjang As Integer
Dim strTampung As String
Panjang = Len(strKalimat)
For i = Panjang To 1 Step -1
strTampung = strTampung & Mid(strKalimat, i, 1)
Next i
BalikkanString = strTampung
End Function
Private Sub Form_Load()
Text1.Text = "Rezza Aziel Gagina"
End Sub
Text1.Text = BalikkanString(Text1.Text)
End Sub
Function BalikkanString(strKalimat As String) As String
Dim i As Integer, Panjang As Integer
Dim strTampung As String
Panjang = Len(strKalimat)
For i = Panjang To 1 Step -1
strTampung = strTampung & Mid(strKalimat, i, 1)
Next i
BalikkanString = strTampung
End Function
Private Sub Form_Load()
Text1.Text = "Rezza Aziel Gagina"
End Sub
Melihat Folder Window
- Ketik diForm
Public Sub OpenDirectory(Directory As String)
ShellExecute 0, "Open", Directory, vbNullString, _
vbNullString, SW_SHOWNORMAL
End Sub
Private Sub Command1_Click()
'Ganti "C:\" di bawah dengan folder yang _
'ingin Anda lihat
OpenDirectory ("C:\")
End Sub
---------------------------------------------------
- Ketik diModule
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
Public Const SW_SHOWNORMAL = 1
Public Sub OpenDirectory(Directory As String)
ShellExecute 0, "Open", Directory, vbNullString, _
vbNullString, SW_SHOWNORMAL
End Sub
Private Sub Command1_Click()
'Ganti "C:\" di bawah dengan folder yang _
'ingin Anda lihat
OpenDirectory ("C:\")
End Sub
---------------------------------------------------
- Ketik diModule
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
Public Const SW_SHOWNORMAL = 1
Keluar Otomatis
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
'untuk 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
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
'untuk 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
Judul Form Rata Tengah
- Ketik diForm
Dim oldsize As Long
Private Sub Form_Resize()
If Me.Width = oldsize Then
Exit Sub
Else
CenterC Me
oldsize = Me.Width
End If
End Sub
Private Sub Form_Load()
CenterC Me
oldsize = Me.Width
End Sub
------------------------------------------------------
- Ketik diModule
Public Sub CenterC(frm As Form)
Dim SpcF As Integer 'Jumlah spasi yg dapat muat
Dim clen As Integer 'Panjang tulisan
Dim oldc As String 'Tulisan yg lama
Dim i As Integer
oldc = frm.Caption
Do While Left(oldc, 1) = Space(1)
DoEvents
oldc = Right(oldc, Len(oldc) - 1)
Loop
Do While Right(oldc, 1) = Space(1)
DoEvents
oldc = Left(oldc, Len(oldc) - 1)
Loop
clen = Len(oldc)
If InStr(oldc, "!") <> 0 Then
If InStr(oldc, " ") <> 0 Then
clen = clen * 1.5
Else
clen = clen * 1.4
End If
Else
If InStr(oldc, " ") <> 0 Then
clen = clen * 1.4
Else
clen = clen * 1.3
End If
End If
SpcF = frm.Width / 61.2244
SpcF = SpcF - clen
If SpcF > 1 Then
DoEvents 'Mempercepat program
frm.Caption = Space(Int(SpcF / 2)) + oldc
Else
frm.Caption = oldc
End If
End Sub
Dim oldsize As Long
Private Sub Form_Resize()
If Me.Width = oldsize Then
Exit Sub
Else
CenterC Me
oldsize = Me.Width
End If
End Sub
Private Sub Form_Load()
CenterC Me
oldsize = Me.Width
End Sub
------------------------------------------------------
- Ketik diModule
Public Sub CenterC(frm As Form)
Dim SpcF As Integer 'Jumlah spasi yg dapat muat
Dim clen As Integer 'Panjang tulisan
Dim oldc As String 'Tulisan yg lama
Dim i As Integer
oldc = frm.Caption
Do While Left(oldc, 1) = Space(1)
DoEvents
oldc = Right(oldc, Len(oldc) - 1)
Loop
Do While Right(oldc, 1) = Space(1)
DoEvents
oldc = Left(oldc, Len(oldc) - 1)
Loop
clen = Len(oldc)
If InStr(oldc, "!") <> 0 Then
If InStr(oldc, " ") <> 0 Then
clen = clen * 1.5
Else
clen = clen * 1.4
End If
Else
If InStr(oldc, " ") <> 0 Then
clen = clen * 1.4
Else
clen = clen * 1.3
End If
End If
SpcF = frm.Width / 61.2244
SpcF = SpcF - clen
If SpcF > 1 Then
DoEvents 'Mempercepat program
frm.Caption = Space(Int(SpcF / 2)) + oldc
Else
frm.Caption = oldc
End If
End Sub
Input Karakter Tertentu
Private Sub Text1_KeyPress(KeyAscii As Integer)
Dim sTemplate As String
'Ganti '!@#$%^&*()_+=' dengan karakter yang Anda
'inginkan untuk dihindari diinput pada Text1
sTemplate = "!@#$%^&*()_+="
If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then _
KeyAscii = 0
End Sub
Dim sTemplate As String
'Ganti '!@#$%^&*()_+=' dengan karakter yang Anda
'inginkan untuk dihindari diinput pada Text1
sTemplate = "!@#$%^&*()_+="
If InStr(1, sTemplate, Chr(KeyAscii)) > 0 Then _
KeyAscii = 0
End Sub
Senin, 11 Agustus 2008
Animasi Salju
- 1 Form
- 1 Module
- 1 Timer, Interval = 500, Enabled = False
-------------------------------------------------------------------------------------------
Ketikan pada Module
-------------------------------------------------------------------------------------------
Type xParticle
X As Integer
Y As Integer
oldX As Integer
oldY As Integer
iStopped As Integer
End Type
Global Const MAXP = 400
Global Const PSIZE = 1
Global Snow(0 To MAXP) As xParticle
-------------------------------------------------------------------------------------------
Ketikan pada Form
-------------------------------------------------------------------------------------------
Dim bRUN As Boolean
Dim fMouseDown_X As Single
Dim fMouseDown_Y As Single
Dim bMOUSE_DOWN As Boolean
-------------------------------------------------------------------------------------------
Private Sub Form_Load()
Randomize
Me.ScaleMode = vbPixels
Me.DrawWidth = PSIZE
Me.BackColor = vbBlack
Dim i As Integer
For i = 0 To MAXP
Snow(i).X = CInt(Int(Me.ScaleWidth * Rnd))
Snow(i).Y = CInt(Int(Me.ScaleHeight * Rnd))
Next i
bRUN = True
Timer1.Enabled = True
Const sTEXT = "R e a l S n o w"
Me.ForeColor = vbRed
Me.CurrentX = Me.ScaleWidth / 2 - TextWidth(sTEXT) / 2
Me.CurrentY = Me.ScaleHeight / 2 - TextHeight(sTEXT) / 2 - 5
Me.Print sTEXT
Const sTEXT2 = "aziel_wika@yahoo.co.id"
Me.CurrentX = Me.ScaleWidth / 2 - TextWidth(sTEXT2) / 2
Me.CurrentY = Me.ScaleHeight / 2 + TextHeight(sTEXT2) + 2
Me.Print sTEXT2
Me.ForeColor = vbWhite
End Sub
-------------------------------------------------------------------------------------------
Sub DrawSnow()
Dim i As Integer
Dim newX As Integer
Dim newY As Integer
Timer1.Enabled = False
Do While bRUN
For i = 0 To MAXP
Me.PSet (Snow(i).oldX, Snow(i).oldY), vbBlack
Me.PSet (Snow(i).X, Snow(i).Y)
Next i
For i = 0 To MAXP
Snow(i).oldX = Snow(i).X
Snow(i).oldY = Snow(i).Y
newX = Snow(i).X + Int(2 * Rnd)
newX = newX - Int(2 * Rnd)
If newX < newx =" 0">= Me.ScaleWidth Then newX = Me.ScaleWidth - 1
newY = Snow(i).Y + 1
If Me.Point(newX, newY) = vbBlack Then
Snow(i).Y = newY
Snow(i).X = newX
Else
If Snow(i).iStopped = 10 Then ' if stopped 10 times, make new!
If Me.Point(Snow(i).X + 1, Snow(i).Y + 1) = vbBlack Then
Snow(i).X = Snow(i).X + 1
Snow(i).Y = Snow(i).Y + 1
Snow(i).iStopped = 0
ElseIf Me.Point(Snow(i).X - 1, Snow(i).Y + 1) = vbBlack Then
Snow(i).X = Snow(i).X - 1
Snow(i).Y = Snow(i).Y + 1
Snow(i).iStopped = 0
Else
newParticle (i)
End If
Else
Snow(i).iStopped = Snow(i).iStopped + 1
End If
End If
If (Snow(i).Y) >= Me.ScaleHeight Then
newParticle (i)
End If
Next i
DoEvents
Loop
End Sub
-------------------------------------------------------------------------------------------
Sub newParticle(i As Integer)
Snow(i).X = CInt(Int(Me.ScaleWidth * Rnd))
Snow(i).Y = 0
Snow(i).oldX = 0
Snow(i).oldY = 0
Snow(i).iStopped = 0
End Sub
-------------------------------------------------------------------------------------------
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Me.PSet (X, Y)
bMOUSE_DOWN = True
fMouseDown_X = X
fMouseDown_Y = Y
End Sub
-------------------------------------------------------------------------------------------
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
If bMOUSE_DOWN Then
Dim oldDW As Long
Dim oldFC As Long
oldDW = Me.DrawWidth
oldFC = Me.ForeColor
Me.DrawWidth = 3
Me.ForeColor = vbRed
Me.Line (fMouseDown_X, fMouseDown_Y)-(X, Y)
fMouseDown_X = X
fMouseDown_Y = Y
Me.DrawWidth = oldDW
Me.ForeColor = oldFC
End If
End Sub
-------------------------------------------------------------------------------------------
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
bMOUSE_DOWN = False
End Sub
-------------------------------------------------------------------------------------------
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
bRUN = False
End Sub
-------------------------------------------------------------------------------------------
Private Sub Timer1_Timer()
DrawSnow
End Sub
- 1 Module
- 1 Timer, Interval = 500, Enabled = False
-------------------------------------------------------------------------------------------
Ketikan pada Module
-------------------------------------------------------------------------------------------
Type xParticle
X As Integer
Y As Integer
oldX As Integer
oldY As Integer
iStopped As Integer
End Type
Global Const MAXP = 400
Global Const PSIZE = 1
Global Snow(0 To MAXP) As xParticle
-------------------------------------------------------------------------------------------
Ketikan pada Form
-------------------------------------------------------------------------------------------
Dim bRUN As Boolean
Dim fMouseDown_X As Single
Dim fMouseDown_Y As Single
Dim bMOUSE_DOWN As Boolean
-------------------------------------------------------------------------------------------
Private Sub Form_Load()
Randomize
Me.ScaleMode = vbPixels
Me.DrawWidth = PSIZE
Me.BackColor = vbBlack
Dim i As Integer
For i = 0 To MAXP
Snow(i).X = CInt(Int(Me.ScaleWidth * Rnd))
Snow(i).Y = CInt(Int(Me.ScaleHeight * Rnd))
Next i
bRUN = True
Timer1.Enabled = True
Const sTEXT = "R e a l S n o w"
Me.ForeColor = vbRed
Me.CurrentX = Me.ScaleWidth / 2 - TextWidth(sTEXT) / 2
Me.CurrentY = Me.ScaleHeight / 2 - TextHeight(sTEXT) / 2 - 5
Me.Print sTEXT
Const sTEXT2 = "aziel_wika@yahoo.co.id"
Me.CurrentX = Me.ScaleWidth / 2 - TextWidth(sTEXT2) / 2
Me.CurrentY = Me.ScaleHeight / 2 + TextHeight(sTEXT2) + 2
Me.Print sTEXT2
Me.ForeColor = vbWhite
End Sub
-------------------------------------------------------------------------------------------
Sub DrawSnow()
Dim i As Integer
Dim newX As Integer
Dim newY As Integer
Timer1.Enabled = False
Do While bRUN
For i = 0 To MAXP
Me.PSet (Snow(i).oldX, Snow(i).oldY), vbBlack
Me.PSet (Snow(i).X, Snow(i).Y)
Next i
For i = 0 To MAXP
Snow(i).oldX = Snow(i).X
Snow(i).oldY = Snow(i).Y
newX = Snow(i).X + Int(2 * Rnd)
newX = newX - Int(2 * Rnd)
If newX < newx =" 0">= Me.ScaleWidth Then newX = Me.ScaleWidth - 1
newY = Snow(i).Y + 1
If Me.Point(newX, newY) = vbBlack Then
Snow(i).Y = newY
Snow(i).X = newX
Else
If Snow(i).iStopped = 10 Then ' if stopped 10 times, make new!
If Me.Point(Snow(i).X + 1, Snow(i).Y + 1) = vbBlack Then
Snow(i).X = Snow(i).X + 1
Snow(i).Y = Snow(i).Y + 1
Snow(i).iStopped = 0
ElseIf Me.Point(Snow(i).X - 1, Snow(i).Y + 1) = vbBlack Then
Snow(i).X = Snow(i).X - 1
Snow(i).Y = Snow(i).Y + 1
Snow(i).iStopped = 0
Else
newParticle (i)
End If
Else
Snow(i).iStopped = Snow(i).iStopped + 1
End If
End If
If (Snow(i).Y) >= Me.ScaleHeight Then
newParticle (i)
End If
Next i
DoEvents
Loop
End Sub
-------------------------------------------------------------------------------------------
Sub newParticle(i As Integer)
Snow(i).X = CInt(Int(Me.ScaleWidth * Rnd))
Snow(i).Y = 0
Snow(i).oldX = 0
Snow(i).oldY = 0
Snow(i).iStopped = 0
End Sub
-------------------------------------------------------------------------------------------
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Me.PSet (X, Y)
bMOUSE_DOWN = True
fMouseDown_X = X
fMouseDown_Y = Y
End Sub
-------------------------------------------------------------------------------------------
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
If bMOUSE_DOWN Then
Dim oldDW As Long
Dim oldFC As Long
oldDW = Me.DrawWidth
oldFC = Me.ForeColor
Me.DrawWidth = 3
Me.ForeColor = vbRed
Me.Line (fMouseDown_X, fMouseDown_Y)-(X, Y)
fMouseDown_X = X
fMouseDown_Y = Y
Me.DrawWidth = oldDW
Me.ForeColor = oldFC
End If
End Sub
-------------------------------------------------------------------------------------------
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
bMOUSE_DOWN = False
End Sub
-------------------------------------------------------------------------------------------
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
bRUN = False
End Sub
-------------------------------------------------------------------------------------------
Private Sub Timer1_Timer()
DrawSnow
End Sub
Buka dan Tutup CD-Room
- 1 Form :
> Command1.Caption = "Buka"
> Command2.Caption = "Tutup"
- 1 Module
---------------------------------------------------------------------------
Ketikan pada Module
---------------------------------------------------------------------------
Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As String, ByVal uReturnLength As _
Long, ByVal hwndCallback As Long) As Long
---------------------------------------------------------------------------
Ketikan pada Form
---------------------------------------------------------------------------
Private Sub Command1_Click()
retvalue = mciSendString("set Cdaudio door open", returnstring, 127, 0)
End Sub
Private Sub Command2_Click()
retvalue = mciSendString("set Cdaudio door closed", returnstring, 127, 0)
End Sub
> Command1.Caption = "Buka"
> Command2.Caption = "Tutup"
- 1 Module
---------------------------------------------------------------------------
Ketikan pada Module
---------------------------------------------------------------------------
Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As String, ByVal uReturnLength As _
Long, ByVal hwndCallback As Long) As Long
---------------------------------------------------------------------------
Ketikan pada Form
---------------------------------------------------------------------------
Private Sub Command1_Click()
retvalue = mciSendString("set Cdaudio door open", returnstring, 127, 0)
End Sub
Private Sub Command2_Click()
retvalue = mciSendString("set Cdaudio door closed", returnstring, 127, 0)
End Sub
Mencari Data Dalam List
- 1 Textbox
- 1 Listbox
------------------------------------------------------------
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As String) As Long
Private Const LB_SELECTSTRING = &H18C
------------------------------------------------------------
Private Sub Form_Load()
List1.AddItem "ramlan"
List1.AddItem "rambo"
List1.AddItem "rapih"
List1.AddItem "diki"
List1.AddItem "SENSOR"
List1.AddItem "geulis"
List1.AddItem "tidak"
List1.AddItem "rumah"
End Sub
------------------------------------------------------------
Private Sub Text1_Change()
If Text1.Text <> "" Then
SendMessage List1.hwnd, LB_SELECTSTRING, -1, Text1.Text
End If
End Sub
- 1 Listbox
------------------------------------------------------------
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As String) As Long
Private Const LB_SELECTSTRING = &H18C
------------------------------------------------------------
Private Sub Form_Load()
List1.AddItem "ramlan"
List1.AddItem "rambo"
List1.AddItem "rapih"
List1.AddItem "diki"
List1.AddItem "SENSOR"
List1.AddItem "geulis"
List1.AddItem "tidak"
List1.AddItem "rumah"
End Sub
------------------------------------------------------------
Private Sub Text1_Change()
If Text1.Text <> "" Then
SendMessage List1.hwnd, LB_SELECTSTRING, -1, Text1.Text
End If
End Sub
Menggambar di Form
Dim bDraw As Boolean
Private Sub Command1_Click()
Form1.Cls
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Load()
bDraw = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Me.CurrentX = X
Me.CurrentY = Y
bDraw = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
If bDraw And Button = vbLeftButton Then
Me.Line -(X, Y)
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
bDraw = False
End Sub
Private Sub Command1_Click()
Form1.Cls
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_Load()
bDraw = False
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Me.CurrentX = X
Me.CurrentY = Y
bDraw = True
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
If bDraw And Button = vbLeftButton Then
Me.Line -(X, Y)
End If
End Sub
-----------------------------------------------------------------------------------------
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
bDraw = False
End Sub
Mengimport Data ke Excel
different version of export to excel writes data in multiple sheets if rows exceeds 65000
Public Sub ExportToWorksheet(rs As Recordset)
'takes a populated recordset
'exports the recordset to one or more new (named and numbered) worksheets
On Error GoTo Err_Handler
Dim objXLApp As New Excel.Application
Dim intSheetNumber As Integer
Dim objWS As Excel.Worksheet
Dim strSheetName As String
Dim fld As field
Dim intCol As Integer
Dim lngPage As Long
Dim rsReplica As New ADODB.Recordset
Dim lngRecCount As Long
objXLApp.Workbooks.Add
If rs.RecordCount > 65000 Then
lngRecCount = rs.RecordCount
intSheetNumber = 1
For lngPage = 1 To rs.PageCount
'adds a new sheet and name it
rs.AbsolutePage = lngPage
Set objWS = objXLApp.Worksheets.Add
strSheetName = "Spinner" & intSheetNumber
objWS.Name = strSheetName
'add the field names
For intCol = 0 To rs.Fields.count - 1
Set fld = rs.Fields(intCol)
objWS.Cells(1, intCol + 1) = fld.Name
With objXLApp
.Columns(Chr(intCol + 65) & ":" & Chr(intCol + 65)).Select
.Selection.NumberFormat = "@"
End With
Next intCol
objWS.Range(objWS.Cells(1, 1), objWS.Cells(1, rs.Fields.count)).Font.Bold = True
lRs = rs.GetString(adClipString, rs.PageSize)
strselconcate = "A" & 2
If lngRecCount > 65000 Then
strselconcate = strselconcate & ":" & Chr(rs.Fields.count + 64) & rs.PageSize + 1
lngRecCount = lngRecCount - 65000
Else
strselconcate = strselconcate & ":" & Chr(rs.Fields.count + 64) & lngRecCount + 1
End If
objXLApp.Range(strselconcate).Select
Clipboard.Clear
Clipboard.SetText (lRs)
objXLApp.ActiveSheet.Paste
objXLApp.Selection.CurrentRegion.Columns.AutoFit
objXLApp.Selection.CurrentRegion.Rows.AutoFit
'set the next sheet number
intSheetNumber = intSheetNumber + 1
Next
Else
'create and name worksheet
Set objWS = objXLApp.Worksheets.Add
objWS.Name = "Spinner1"
'copy to worksheet
'first the field names
For intCol = 0 To rs.Fields.count - 1
Set fld = rs.Fields(intCol)
objWS.Cells(1, intCol + 1) = fld.Name
Next intCol
'now the actual data
objWS.Range(objWS.Cells(1, 1), objWS.Cells(1, rs.Fields.count)).Font.Bold = True
objWS.Range("A2").CopyFromRecordset rs
End If
objXLApp.Visible = True
Err_Handler_Exit:
Screen.MousePointer = vbNormal
Exit Sub
Err_Handler:
Screen.MousePointer = vbNormal
MsgBox Err.Number & " - " & Err.Description & " - Sub ExportToWorksheet()"
Resume Err_Handler_Exit
End Sub
Public Sub ExportToWorksheet(rs As Recordset)
'takes a populated recordset
'exports the recordset to one or more new (named and numbered) worksheets
On Error GoTo Err_Handler
Dim objXLApp As New Excel.Application
Dim intSheetNumber As Integer
Dim objWS As Excel.Worksheet
Dim strSheetName As String
Dim fld As field
Dim intCol As Integer
Dim lngPage As Long
Dim rsReplica As New ADODB.Recordset
Dim lngRecCount As Long
objXLApp.Workbooks.Add
If rs.RecordCount > 65000 Then
lngRecCount = rs.RecordCount
intSheetNumber = 1
For lngPage = 1 To rs.PageCount
'adds a new sheet and name it
rs.AbsolutePage = lngPage
Set objWS = objXLApp.Worksheets.Add
strSheetName = "Spinner" & intSheetNumber
objWS.Name = strSheetName
'add the field names
For intCol = 0 To rs.Fields.count - 1
Set fld = rs.Fields(intCol)
objWS.Cells(1, intCol + 1) = fld.Name
With objXLApp
.Columns(Chr(intCol + 65) & ":" & Chr(intCol + 65)).Select
.Selection.NumberFormat = "@"
End With
Next intCol
objWS.Range(objWS.Cells(1, 1), objWS.Cells(1, rs.Fields.count)).Font.Bold = True
lRs = rs.GetString(adClipString, rs.PageSize)
strselconcate = "A" & 2
If lngRecCount > 65000 Then
strselconcate = strselconcate & ":" & Chr(rs.Fields.count + 64) & rs.PageSize + 1
lngRecCount = lngRecCount - 65000
Else
strselconcate = strselconcate & ":" & Chr(rs.Fields.count + 64) & lngRecCount + 1
End If
objXLApp.Range(strselconcate).Select
Clipboard.Clear
Clipboard.SetText (lRs)
objXLApp.ActiveSheet.Paste
objXLApp.Selection.CurrentRegion.Columns.AutoFit
objXLApp.Selection.CurrentRegion.Rows.AutoFit
'set the next sheet number
intSheetNumber = intSheetNumber + 1
Next
Else
'create and name worksheet
Set objWS = objXLApp.Worksheets.Add
objWS.Name = "Spinner1"
'copy to worksheet
'first the field names
For intCol = 0 To rs.Fields.count - 1
Set fld = rs.Fields(intCol)
objWS.Cells(1, intCol + 1) = fld.Name
Next intCol
'now the actual data
objWS.Range(objWS.Cells(1, 1), objWS.Cells(1, rs.Fields.count)).Font.Bold = True
objWS.Range("A2").CopyFromRecordset rs
End If
objXLApp.Visible = True
Err_Handler_Exit:
Screen.MousePointer = vbNormal
Exit Sub
Err_Handler:
Screen.MousePointer = vbNormal
MsgBox Err.Number & " - " & Err.Description & " - Sub ExportToWorksheet()"
Resume Err_Handler_Exit
End Sub
Setiap Awal Kalimat Kapital
Private Sub Text1_Change()
Text1.Text = StrConv(Text1.Text, vbProperCase)
Text1.SelStart = Len(Text1.Text)
End Sub
Text1.Text = StrConv(Text1.Text, vbProperCase)
Text1.SelStart = Len(Text1.Text)
End Sub
Shutdown, Restart dan Log Off
Dalam tulisan ini berisi code tentang shutdown, restart, dan logoff
-------------------------------------------------------------------
Private Sub cmdLog_Click()
Dim Log As String
Log = MsgBox("Anda ingin Log off ?", vbYesNo, "Nanya Nech...!!!")
If Log = vbYes Then
'LOGOFF:
Shell "shutdown -l -f -t 0"
Else
MsgBox "Ngak Jadi Log Off...!!!", vbInformation, "Informasi"
End If
End Sub
-------------------------------------------------------------------
Private Sub cmdRestart_Click()
Dim Aku As String
Aku = MsgBox("Anda ingin Restart ?", vbYesNo, "Nanya Nech...!!!")
If Aku = vbYes Then
'RESTART
Shell "shutdown -r -f -t 0"
Else
MsgBox "Ngak Jadi Restart...!!!", vbInformation, "Informasi"
End If
End Sub
-------------------------------------------------------------------
Private Sub cmdShutdown_Click()
Dim Cinta As String
Cinta = MsgBox("Anda ingin Shutdown ?", vbYesNo, "Nanya Nech...!!!")
If Cinta = vbYes Then
'SHUTDOWN
Shell "shutdown -s -f -t 0"
Else
MsgBox "Ngak Jadi Shutdown...!!!", vbInformation, "Informasi"
End If
End Sub
Animasi Picture
- 1 Module, 1 Picturebox
-------------------------------------------------------------------------
- Pada Module
Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function StrokePath Lib "gdi32" (ByVal hdc As Long) As Long
-------------------------------------------------------------------------
- Pada Form
Private Sub Form_Load()
'Ganti "Rezza Aziel Gagina" dengan teks yang ingin Anda tampilkan
Const TXT = "Rezza Aziel Gagina"
Dim i As Long
Dim hRgn As Long
Picture1.AutoRedraw = True
'Pilih huruf. Sesuaikan dengan keinginan Anda...
Picture1.Font.Name = "Times New Roman"
Picture1.Font.Bold = True
Picture1.Font.Size = 50
'Buat ukuran Picture1 cukup besar
Picture1.Width = Picture1.TextWidth(TXT)
Picture1.Height = Picture1.TextHeight(TXT)
'Untuk letak Picture1
BeginPath Picture1.hdc
Picture1.CurrentX = 0
Picture1.CurrentY = 0
Picture1.Print TXT
EndPath Picture1.hdc
'Gambar teks...
StrokePath Picture1.hdc
End Sub
Memindahkan File
- 1 Module, 1 CommandButton
--------------------------------------------------------------------------------
- Pada Module
Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal _
lpExistingFileName As String, ByVal lpNewFileName As String) As Long
--------------------------------------------------------------------------------
- Pada Form
Private Sub Command1_Click()
'Contoh ini memindahkan file 'c:\MyFile.Zip' ke direktori 'c:\MyDir'.
A = MoveFile("c:\MyFile.Zip", "c:\MyDir\MyFile.Zip")
If A Then
MsgBox "File berhasil dipindahkan!", vbInformation, "Sukses"
Else
MsgBox "Error. File belum dipindahkan!" & Chr(13) & _
"Kemungkinan file asal tidak ada" & Chr(13) & _
"atau file sudah ada di dalam " & Chr(13) & _
"direktori tujuan!", vbCritical, "Gagal Pindah File"
End If
End Sub
Menghapus File ke Recycle Bin
- 1 Module, 1 CommandButton
---------------------------------------------------------------------------------
- Pada Module
Public Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type
Declare Function SHFileOperation Lib "shell32.dll" Alias _
"SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Public Const F0_DELETE = &H3
Public Const F0F_ALLOWUNDO = &H40
Public Const F0F_CREATEPROGRESSDLG As Long = &H0
---------------------------------------------------------------------------------
- Pada Form
Private Sub Command1_Click()
Dim MyBool As Boolean
'Ganti nama file di bawah dengan nama file yang ingin Anda hapus.
DelToRecycBin ("c:\My Documents\MyFile.Zip")
End Sub
Public Function DelToRecycBin(FileName As String)
Dim FileOperation As SHFILEOPSTRUCT
Dim lReturn As Long
On Error GoTo DelToRecycBin_Err
With FileOperation
.wFunc = F0_DELETE
.pFrom = FileName
.fFlags = F0F_ALLOWUNDO + F0F_CREATEPROGRESSDLG
End With
lReturn = SHFileOperation(FileOperation)
Exit Function
DelToRecycBin_Err:
MsgBox Err.Number & Err.Description
End Function
Membuat Stopwatch
- 1 Timer, 1 Label dan 2 CommandButton
Dim TotalTenthDetik, TotalDetik, TenthDetik, Detik, _
Menit, Jam As Integer
Dim Jam1 As String
Private Sub Command1_Click()
'Inisialisasi total sepersepuluh detik
TotalTenthDetik = -1
'Aktifkan timer
Timer1.Enabled = True
End Sub
Private Sub Command2_Click()
'Memulai atau menghentikan timer kembali
Timer1.Enabled = Not Timer1.Enabled
End Sub
Private Sub Timer1_Timer()
'Tambah dengan satu untuk total sepersepuluh detik.
'Kita mengeset interval Timer menjadi 10, jadi
'setiap sepersepuluh detik prosedur ini akan dieksekusi
TotalTenthDetik = TotalTenthDetik + 1
'Jika TotalTenthSeconds = 10, set kembali menjadi 0.
TenthDetik = TotalTenthDetik Mod 10
'10 kali sepersepuluh detik sama dengan 1 detik.
'int - akan mengembalikan bilangan integer (bulat) dari pecahan
'Contoh: Int(0.9) = 0 '--> menghasilkan 0
TotalDetik = Int(TotalTenthDetik / 10)
'Jika variabel Seconds = 60, set kembali menjadi 0
Detik = TotalDetik Mod 60
If Len(Detik) = 1 Then
Detik = "0" & Detik 'Agar selalu dalam dua digit
End If
Menit = Int(TotalDetik / 60) Mod 60
If Len(Menit) = 1 Then
Menit = "0" & Menit 'Agar selalu dalam dua digit
End If
Jam = Int(TotalDetik / 3600)
If Jam < 9 Then
Jam1 = "0" & Jam 'Agar selalu dalam dua digit
End If
'Tampilkan hasilnya di Label1 (update terus Label1)
Label1 = Jam1 & ":" & Menit & ":" & Detik & ":" & TenthDetik & ""
End Sub
Menonaktifkan Fungsi Mouse
Berikut ini trik untuk menonaktifkan fungsi mouse.
Hati-hati! Setelah menjalankan coding ini, mouse Anda hanya akan
berfungsi kembali setelah Anda merestart komputer Anda.
Hati-hati! Setelah menjalankan coding ini, mouse Anda hanya akan
berfungsi kembali setelah Anda merestart komputer Anda.
Private Sub Command1_Click()
Shell "rundll32 mouse,disable"
End Sub
Membekukan Form
- 1 Form dan 1 Commandbutton.
----------------------------------------------------------------------------------
- Pada Module
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd _
As Long, ByVal bRevert As Long) As Long
Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu _
As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Public Const SC_MOVE = &HF010&
Public Const MF_BYCOMMAND = &H0&
----------------------------------------------------------------------------------
- Pada Form
Private Sub Command1_Click()
lhSysMenu = GetSystemMenu(Me.hwnd, False)
lRetVal = RemoveMenu(lhSysMenu, SC_MOVE, MF_BYCOMMAND)
End Sub
Menghitung Jumlah Baris diTextbox
- 1 Module, 1 Form, 1 Label, dan 1 Textbox.
- Set properti MultiLine pada textbox menjadi True.
------------------------------------------------------------------------
- Pada Module
Declare Function SendMessageLong Lib "user32" Alias
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As _
Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Const EM_GETLINECOUNT = &HBA
------------------------------------------------------------------------
- Pada Form
Private Sub Text1_Change()
Dim lineCount As Long
On Local Error Resume Next
lineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
Label1 = Format$(lineCount, "##,###")
End Sub
Matikan Tombol Close Pada Form
- Pada Module
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Const MF_BYPOSITION = &H400&
Public Sub RemoveCancelMenuItem(frm As Form)
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(frm.hwnd, 0)
Call RemoveMenu(hSysMenu, 6, MF_BYPOSITION)
Call RemoveMenu(hSysMenu, 5, MF_BYPOSITION)
End Sub
----------------------------------------------------------------------------------------------
- Pada Form
Private Sub Form_Load()
RemoveCancelMenuItem Me
End Sub
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Const MF_BYPOSITION = &H400&
Public Sub RemoveCancelMenuItem(frm As Form)
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(frm.hwnd, 0)
Call RemoveMenu(hSysMenu, 6, MF_BYPOSITION)
Call RemoveMenu(hSysMenu, 5, MF_BYPOSITION)
End Sub
----------------------------------------------------------------------------------------------
- Pada Form
Private Sub Form_Load()
RemoveCancelMenuItem Me
End Sub
Membulatkan Pecahan
Function Round(nValue As Double, nDigits As Integer) As Double
Round = Int(nValue * (10 ^ nDigits) + 0.5) / (10 ^ nDigits)
End Function
Private Sub Form_Load()
'Ganti '19.8455' dengan bilangan yang ingin Anda bulatkan.
'Ganti '2' dengan jumlah digit setelah koma untuk hasil setelah
pembulatan.
MsgBox Round(19.8455, 2)
End Sub
Penggunaan Winsock
Hai semua!! Saya minta maaf dulu nih, bagi yang merasa artikel ini nggak mutu, udah basi, dsb saya minta maaf.
Saya juga sebenernya juga masih newbies, tapi nggak newbes-newbies amat.
Artikel ini akan membahas koneksi antar komputer di VB 6 mengunakan kontrol Winsock.
Sebelum menggunakan kontrol tersebut, kontrol winsock harus diaktifkan dulu dengan mengklik Project > Components, kemudian menyentang "Microsoft Winsock Control 6.0"
Setelah itu kalian tinggal memasukkan kontrol Winsock tersebut kedalam Form kalian. Jangan khawatir, kontrol Winsock tidak akan tampak di form saat RunTime.
Kemudian, setidaknya ada beberapa properties yang wajib diisi sebelum menggunakan winsock Control:
-LocalPort: itu adalah port yang akan kita gunakan
-RemotePort: itu adalah port yang akan digunakan komputer teman kita
-RemoteHost: itu adalah nomor IP komputer teman kita.
Berikut adalah contoh penggunaan kontrol Winsock dalam program Chat sederhana:
--------->> START HERE <<--------------
Dim Pesan As String
Dim Host As String
Dim Idx As String
Dim ipt As Long
Dim portt As Long
Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
Text2.Enabled = False
Winsock1.Listen
List1.Clear
Command2.Enabled = False
End Sub
Private Sub Command1_Click()
If Text3.Text = "" Or Text4.Text = "" Then
MsgBox "Ada yang belum di isi tuh!!", 0, "Error!!"
Exit Sub
End If
ipt = Text3.Text
portt = Text4.Text
Winsock1.RemoteHost = ipt
Winsock1.RemotePort = portt
Winsock1.LocalPort = portt
Winsock1.Connect
Command1.Enabled = False
Command2.Enabled = True
End Sub
Private Sub Command2_Click()
Winsock1.Close
Command2.Enabled = False
Command1.Enabled = True
End Sub
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
If List1.Columns < 1 Then Exit Sub
Host = List1.Text
Idx = List1.ListIndex
If Button = 2 Then
PopupMenu mnuPopup
End If
End Sub
Private Sub MnuDisconnect()
Winsock1.Close
Winsock1.Listen
Lisi1.RemoveItem Idx
List1.Refresh
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Text2.Text = "" Then Exit Sub
Winsock1.SendData Pesan
Pesan = "<" & Winsock1.LocalIP & ">" & Text2.Text
Text1.Text = Text1.Text & Pesan & vbCrLf
End If
End Sub
Private Sub Winsock1_Connect()
ConnectBtn.Enabled = False
DiosconnectBtn.Enabled = True
Text2.Enabled = True
End Sub
Private Sub Winsock1_Close()
List1.Clear
Winsock1.Close
Winsock1.Listen
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
Winsock1.Accept requestID
List1.AddItem Winsock1.RemoteHost
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Winsock1.GetData Pesan
Text1.Text = Text1.Text & Pesan & vbCrLf
End Sub
Private Sub Winsock1_SendComplete()
MsgBox "Data telah dikirim ke server!", vbInformation, "Sukses!"
End Sub
----------->> CUT HERE <<------------------
Selamat berkarya menggunakan Winsock Control!
Saya juga sebenernya juga masih newbies, tapi nggak newbes-newbies amat.
Artikel ini akan membahas koneksi antar komputer di VB 6 mengunakan kontrol Winsock.
Sebelum menggunakan kontrol tersebut, kontrol winsock harus diaktifkan dulu dengan mengklik Project > Components, kemudian menyentang "Microsoft Winsock Control 6.0"
Setelah itu kalian tinggal memasukkan kontrol Winsock tersebut kedalam Form kalian. Jangan khawatir, kontrol Winsock tidak akan tampak di form saat RunTime.
Kemudian, setidaknya ada beberapa properties yang wajib diisi sebelum menggunakan winsock Control:
-LocalPort: itu adalah port yang akan kita gunakan
-RemotePort: itu adalah port yang akan digunakan komputer teman kita
-RemoteHost: itu adalah nomor IP komputer teman kita.
Berikut adalah contoh penggunaan kontrol Winsock dalam program Chat sederhana:
--------->> START HERE <<--------------
Dim Pesan As String
Dim Host As String
Dim Idx As String
Dim ipt As Long
Dim portt As Long
Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
Text2.Enabled = False
Winsock1.Listen
List1.Clear
Command2.Enabled = False
End Sub
Private Sub Command1_Click()
If Text3.Text = "" Or Text4.Text = "" Then
MsgBox "Ada yang belum di isi tuh!!", 0, "Error!!"
Exit Sub
End If
ipt = Text3.Text
portt = Text4.Text
Winsock1.RemoteHost = ipt
Winsock1.RemotePort = portt
Winsock1.LocalPort = portt
Winsock1.Connect
Command1.Enabled = False
Command2.Enabled = True
End Sub
Private Sub Command2_Click()
Winsock1.Close
Command2.Enabled = False
Command1.Enabled = True
End Sub
Private Sub List1_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
If List1.Columns < 1 Then Exit Sub
Host = List1.Text
Idx = List1.ListIndex
If Button = 2 Then
PopupMenu mnuPopup
End If
End Sub
Private Sub MnuDisconnect()
Winsock1.Close
Winsock1.Listen
Lisi1.RemoveItem Idx
List1.Refresh
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Text2.Text = "" Then Exit Sub
Winsock1.SendData Pesan
Pesan = "<" & Winsock1.LocalIP & ">" & Text2.Text
Text1.Text = Text1.Text & Pesan & vbCrLf
End If
End Sub
Private Sub Winsock1_Connect()
ConnectBtn.Enabled = False
DiosconnectBtn.Enabled = True
Text2.Enabled = True
End Sub
Private Sub Winsock1_Close()
List1.Clear
Winsock1.Close
Winsock1.Listen
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
Winsock1.Accept requestID
List1.AddItem Winsock1.RemoteHost
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Winsock1.GetData Pesan
Text1.Text = Text1.Text & Pesan & vbCrLf
End Sub
Private Sub Winsock1_SendComplete()
MsgBox "Data telah dikirim ke server!", vbInformation, "Sukses!"
End Sub
----------->> CUT HERE <<------------------
Selamat berkarya menggunakan Winsock Control!
Merubah Warna Progressbar
- Command1 (CommandButton)
- Command2 (CommandButton)
- ProgressBar1 (ProgressBar - Ms Windows Common Control)
-------------------------------------------------------------------------------------
Const WM_USER = &H400
Const CCM_FIRST As Long = &H2000&
Const CCM_SETBKCOLOR As Long = (CCM_FIRST + 1)
Const PBM_SETBKCOLOR As Long = CCM_SETBKCOLOR
Const PBM_SETBARCOLOR As Long = (WM_USER + 9)
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 Sub SetPBarColor(hwndProgBar As Long, ByVal clrref As Long)
Call SendMessage(hwndProgBar, PBM_SETBARCOLOR, 0&, ByVal clrref)
End Sub
Private Sub SetPBackColor(hwndProgBar As Long, ByVal clrref As Long)
Call SendMessage(hwndProgBar, PBM_SETBKCOLOR, 0&, ByVal clrref)
End Sub
Private Sub Command1_Click()
SetPBarColor ProgressBar1.hwnd, vbRed
End Sub
Private Sub Command2_Click()
SetPBackColor ProgressBar1.hwnd, vbGreen
End Sub
Private Sub Timer1_Timer()
If ProgressBar1.Value < 100 Then
ProgressBar1.Value = ProgressBar1.Value + 5
Else
ProgressBar1.Value = 0
End If
End Sub
- Command2 (CommandButton)
- ProgressBar1 (ProgressBar - Ms Windows Common Control)
-------------------------------------------------------------------------------------
Const WM_USER = &H400
Const CCM_FIRST As Long = &H2000&
Const CCM_SETBKCOLOR As Long = (CCM_FIRST + 1)
Const PBM_SETBKCOLOR As Long = CCM_SETBKCOLOR
Const PBM_SETBARCOLOR As Long = (WM_USER + 9)
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 Sub SetPBarColor(hwndProgBar As Long, ByVal clrref As Long)
Call SendMessage(hwndProgBar, PBM_SETBARCOLOR, 0&, ByVal clrref)
End Sub
Private Sub SetPBackColor(hwndProgBar As Long, ByVal clrref As Long)
Call SendMessage(hwndProgBar, PBM_SETBKCOLOR, 0&, ByVal clrref)
End Sub
Private Sub Command1_Click()
SetPBarColor ProgressBar1.hwnd, vbRed
End Sub
Private Sub Command2_Click()
SetPBackColor ProgressBar1.hwnd, vbGreen
End Sub
Private Sub Timer1_Timer()
If ProgressBar1.Value < 100 Then
ProgressBar1.Value = ProgressBar1.Value + 5
Else
ProgressBar1.Value = 0
End If
End Sub
Menemukan No Seri Komputer
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) _
As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As _
Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As _
Long) As Long
Const HKEY_LOCAL_MACHINE As Long = &H80000002
Const RegKey As String = "SOFTWARE\MICROSOFT\Windows NT\CurrentVersion"
Const XlatProdId As String = "BCDFGHJKMPQRTVWXY2346789"
Private Sub Form_Load()
Dim hKey As Long
Dim ProdID(0 To 164) As Byte
Dim i As Long
Dim j As Long
Dim k As Long
Dim vHasil As String
If RegOpenKey(HKEY_LOCAL_MACHINE, RegKey, hKey) = 0 Then
k = 255
If RegQueryValueEx(hKey, "DigitalProductId", 0&, 3, _
ProdID(0), k) = 0 Then
For i = 1 To 25
k = 0
For j = 66 To 52 Step -1
k = k * 256 Xor CLng(ProdID(j))
ProdID(j) = k \ 24
k = k Mod 24
Next j
vHasil = IIf(i Mod 5, "", "-") & Mid$(XlatProdId, _
k + 1, 1) & vHasil
Next i
vHasil = Mid$(vHasil, 2)
Else
vHasil = "Not Registered"
End If
RegCloseKey hKey
Else
vHasil = "Not Registered"
End If
MsgBox "No Seri: " & vHasil, 64, "Ops i get it"
End Sub
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) _
As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As _
Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As _
Long) As Long
Const HKEY_LOCAL_MACHINE As Long = &H80000002
Const RegKey As String = "SOFTWARE\MICROSOFT\Windows NT\CurrentVersion"
Const XlatProdId As String = "BCDFGHJKMPQRTVWXY2346789"
Private Sub Form_Load()
Dim hKey As Long
Dim ProdID(0 To 164) As Byte
Dim i As Long
Dim j As Long
Dim k As Long
Dim vHasil As String
If RegOpenKey(HKEY_LOCAL_MACHINE, RegKey, hKey) = 0 Then
k = 255
If RegQueryValueEx(hKey, "DigitalProductId", 0&, 3, _
ProdID(0), k) = 0 Then
For i = 1 To 25
k = 0
For j = 66 To 52 Step -1
k = k * 256 Xor CLng(ProdID(j))
ProdID(j) = k \ 24
k = k Mod 24
Next j
vHasil = IIf(i Mod 5, "", "-") & Mid$(XlatProdId, _
k + 1, 1) & vHasil
Next i
vHasil = Mid$(vHasil, 2)
Else
vHasil = "Not Registered"
End If
RegCloseKey hKey
Else
vHasil = "Not Registered"
End If
MsgBox "No Seri: " & vHasil, 64, "Ops i get it"
End Sub
Membuat Form Selalu diAtas
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long,ByVal hWndInsertAfter As Long, _
ByVal x As Long, y, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Sub MakeNormal(lngHwnd As Long)
SetWindowPos lngHwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Private Sub MakeTopMost(lngHwnd As Long)
SetWindowPos lngHwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Private Sub Command1_Click()
MakeTopMost hwnd
End Sub
Private Sub Command2_Click()
MakeNormal hwnd
End Sub
(ByVal hwnd As Long,ByVal hWndInsertAfter As Long, _
ByVal x As Long, y, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_SHOWWINDOW = &H40
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Sub MakeNormal(lngHwnd As Long)
SetWindowPos lngHwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Private Sub MakeTopMost(lngHwnd As Long)
SetWindowPos lngHwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Private Sub Command1_Click()
MakeTopMost hwnd
End Sub
Private Sub Command2_Click()
MakeNormal hwnd
End Sub
Matikan Komp dengan Send Massage
Private Const MONITOR_ON = -1&
Private Const MONITOR_LOWPOWER = 1&
Private Const MONITOR_OFF = 2&
Private Const SC_MONITORPOWER = &HF170&
Private Const WM_SYSCOMMAND = &H112
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 Sub Form_Load()
Command1.Caption = "Turn off monitors"
End Sub
Private Sub Command1_Click()
Call SendMessage(Me.hWnd, WM_SYSCOMMAND, _
SC_MONITORPOWER, ByVal MONITOR_OFF)
With Timer1
.Interval = 8000
.Enabled = True
End With
End Sub
Private Sub Timer1_Timer()
Timer1.Enabled = False
Call SendMessage(Me.hWnd, WM_SYSCOMMAND, _
SC_MONITORPOWER, ByVal MONITOR_ON)
End Sub
Private Const MONITOR_LOWPOWER = 1&
Private Const MONITOR_OFF = 2&
Private Const SC_MONITORPOWER = &HF170&
Private Const WM_SYSCOMMAND = &H112
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 Sub Form_Load()
Command1.Caption = "Turn off monitors"
End Sub
Private Sub Command1_Click()
Call SendMessage(Me.hWnd, WM_SYSCOMMAND, _
SC_MONITORPOWER, ByVal MONITOR_OFF)
With Timer1
.Interval = 8000
.Enabled = True
End With
End Sub
Private Sub Timer1_Timer()
Timer1.Enabled = False
Call SendMessage(Me.hWnd, WM_SYSCOMMAND, _
SC_MONITORPOWER, ByVal MONITOR_ON)
End Sub
Drag File dari Windows ke Form
Private Sub Form_Load()
OLEDropMode = 1
End Sub
Private Sub Form_OLEDragDrop(Data As DataObject, _
Effect As Long, _
Button As Integer, _
Shift As Integer, _
X As Single, Y As Single)
Dim txt As String
Dim fname As Variant
For Each fname In Data.Files
txt = txt & fname & vbCrLf
Next fname
MsgBox txt
Effect = vbDropEffectNone
End Sub
OLEDropMode = 1
End Sub
Private Sub Form_OLEDragDrop(Data As DataObject, _
Effect As Long, _
Button As Integer, _
Shift As Integer, _
X As Single, Y As Single)
Dim txt As String
Dim fname As Variant
For Each fname In Data.Files
txt = txt & fname & vbCrLf
Next fname
MsgBox txt
Effect = vbDropEffectNone
End Sub
Dapatkan IP Adress
Const IP_SUCCESS As Long = 0
Const MAX_WSADescription As Long = 256
Const MAX_WSASYSStatus As Long = 128
Const WS_VERSION_REQD As Long = &H101
Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Const MIN_SOCKETS_REQD As Long = 1
Const SOCKET_ERROR As Long = -1
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Private Declare Function gethostbyname Lib "wsock32" _
(ByVal hostname As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(xDest As Any, _
xSource As Any, _
ByVal nbytes As Long)
Private Declare Function lstrlenA Lib "kernel32" _
(lpString As Any) As Long
Private Declare Function WSAStartup Lib "wsock32" _
(ByVal wVersionRequired As Long, _
lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "wsock32" () As Long
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim success As Long
SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function
Public Sub SocketsCleanup()
If WSACleanup() <> 0 Then
MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
End If
End Sub
Public Function GetIPFromHostName(ByVal sHostName As String) As String
'konversi host name ke IP Address.
Dim nbytes As Long
Dim ptrHosent As Long
Dim ptrName As Long
Dim ptrAddress As Long
Dim ptrIPAddress As Long
Dim sAddress As String
sAddress = Space$(4)
ptrHosent = gethostbyname(sHostName & vbNullChar)
If ptrHosent <> 0 Then
ptrAddress = ptrHosent + 12
'mendapatkan IP address
CopyMemory ptrAddress, ByVal ptrAddress, 4
CopyMemory ptrIPAddress, ByVal ptrAddress, 4
CopyMemory ByVal sAddress, ByVal ptrIPAddress, 4
GetIPFromHostName = IPToText(sAddress)
End If
End Function
Private Function IPToText(ByVal IPAddress As String) As String
IPToText = CStr(Asc(IPAddress)) & "." & _
CStr(Asc(Mid$(IPAddress, 2, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 4, 1)))
End Function
Private Sub Form_Load()
If SocketsInitialize() Then
MsgBox "Host Name: localhost, " & GetIPFromHostName("localhost")
SocketsCleanup
Else
MsgBox "Error, tidak dapat mendapatkan IP Address"
End If
End Sub
Const MAX_WSADescription As Long = 256
Const MAX_WSASYSStatus As Long = 128
Const WS_VERSION_REQD As Long = &H101
Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Const MIN_SOCKETS_REQD As Long = 1
Const SOCKET_ERROR As Long = -1
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type
Private Declare Function gethostbyname Lib "wsock32" _
(ByVal hostname As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(xDest As Any, _
xSource As Any, _
ByVal nbytes As Long)
Private Declare Function lstrlenA Lib "kernel32" _
(lpString As Any) As Long
Private Declare Function WSAStartup Lib "wsock32" _
(ByVal wVersionRequired As Long, _
lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "wsock32" () As Long
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim success As Long
SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function
Public Sub SocketsCleanup()
If WSACleanup() <> 0 Then
MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
End If
End Sub
Public Function GetIPFromHostName(ByVal sHostName As String) As String
'konversi host name ke IP Address.
Dim nbytes As Long
Dim ptrHosent As Long
Dim ptrName As Long
Dim ptrAddress As Long
Dim ptrIPAddress As Long
Dim sAddress As String
sAddress = Space$(4)
ptrHosent = gethostbyname(sHostName & vbNullChar)
If ptrHosent <> 0 Then
ptrAddress = ptrHosent + 12
'mendapatkan IP address
CopyMemory ptrAddress, ByVal ptrAddress, 4
CopyMemory ptrIPAddress, ByVal ptrAddress, 4
CopyMemory ByVal sAddress, ByVal ptrIPAddress, 4
GetIPFromHostName = IPToText(sAddress)
End If
End Function
Private Function IPToText(ByVal IPAddress As String) As String
IPToText = CStr(Asc(IPAddress)) & "." & _
CStr(Asc(Mid$(IPAddress, 2, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & _
CStr(Asc(Mid$(IPAddress, 4, 1)))
End Function
Private Sub Form_Load()
If SocketsInitialize() Then
MsgBox "Host Name: localhost, " & GetIPFromHostName("localhost")
SocketsCleanup
Else
MsgBox "Error, tidak dapat mendapatkan IP Address"
End If
End Sub
Animasi Text
Contoh 1:
Private Sub Form_Unload(Cancel As Integer)
Me.BackColor = vbWhite ' warna belakang putih
WindowState = 2 ' maximized-kan
DrawWidth = 4 '/ ketebalan
For i = 1 To 16000
Bawah = Bawah + 1
Kanan = Kanan + 1
PSet (Rnd * Kanan, Rnd * Bawah), QBColor(Rnd * 15)
Next i
End Sub
-----------------------------------------------------------------------------------------------
Contoh 2:
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
cepat = 150
While Left + Width < Screen.Width
DoEvents
Left = Left + cepat
Wend
While Top - Height < Screen.Height
DoEvents
Top = Top + cepat
Wend
Hide
End Sub
-----------------------------------------------------------------------------------------------
Contoh 3:
Private Sub Timer1_Timer()
Dim LingkaranX, LingkaranY, Radius
ScaleMode = 3
LingkaranX = ScaleWidth / 2
LingkaranY = ScaleHeight / 2
For Radius = 0 To 100
Circle (LingkaranX + Radius / 2, LingkaranY), Radius, RGB(Rnd * 215, Rnd * 55, Rnd * 15)
Next Radius
End Sub
-----------------------------------------------------------------------------------------------
Contoh 4:
Private Sub Form_Load()
Me.AutoRedraw = True
BackColor = 0
For i = 1 To 500
CurrentX = i * 100
CurrentY = i * 100
h = h & i
ForeColor = i * 10000
Print h
Next i
End Sub
-----------------------------------------------------------------------------------------------
Contoh 5:
Private Sub Form_Load()
Me.AutoRedraw = True
Me.DrawWidth = 10
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form_MouseMove 1, 0, X, Y
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Caption = "PosisiX=" & X & " - " & "PosisiY=" & Y
If Button = 1 Then
PSet (X, Y), vbBlue
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Me.BackColor = vbWhite ' warna belakang putih
WindowState = 2 ' maximized-kan
DrawWidth = 4 '/ ketebalan
For i = 1 To 16000
Bawah = Bawah + 1
Kanan = Kanan + 1
PSet (Rnd * Kanan, Rnd * Bawah), QBColor(Rnd * 15)
Next i
End Sub
-----------------------------------------------------------------------------------------------
Contoh 2:
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
cepat = 150
While Left + Width < Screen.Width
DoEvents
Left = Left + cepat
Wend
While Top - Height < Screen.Height
DoEvents
Top = Top + cepat
Wend
Hide
End Sub
-----------------------------------------------------------------------------------------------
Contoh 3:
Private Sub Timer1_Timer()
Dim LingkaranX, LingkaranY, Radius
ScaleMode = 3
LingkaranX = ScaleWidth / 2
LingkaranY = ScaleHeight / 2
For Radius = 0 To 100
Circle (LingkaranX + Radius / 2, LingkaranY), Radius, RGB(Rnd * 215, Rnd * 55, Rnd * 15)
Next Radius
End Sub
-----------------------------------------------------------------------------------------------
Contoh 4:
Private Sub Form_Load()
Me.AutoRedraw = True
BackColor = 0
For i = 1 To 500
CurrentX = i * 100
CurrentY = i * 100
h = h & i
ForeColor = i * 10000
Print h
Next i
End Sub
-----------------------------------------------------------------------------------------------
Contoh 5:
Private Sub Form_Load()
Me.AutoRedraw = True
Me.DrawWidth = 10
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Form_MouseMove 1, 0, X, Y
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Caption = "PosisiX=" & X & " - " & "PosisiY=" & Y
If Button = 1 Then
PSet (X, Y), vbBlue
End If
End Sub
Animasi Tombol Start
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
------------------------------------------------------------------------------------------------
Function Bego_Shell_TrayWnd() As Long
Dim vbBeGo(1 To 2) As Long
'/Cari class Shell_TrayWnd
vbBeGo(1) = FindWindow("Shell_TrayWnd", vbNullString)
'/Cari Start Button Pada Class Shell_TrayWnd
vbBeGo(2) = FindWindowEx(vbBeGo(1), ByVal 0&, "Button", vbNullString)
Bego_Shell_TrayWnd = vbBeGo(2)
End Function
Private Sub Form_Load()
Timer1.Interval = 200
End Sub
Private Sub Timer1_Timer()
Dim hText As String, btnHwnd As Long
Static pos As Integer
'/Set animasi Text
hText = " Visual Basic Community (www.smart-vb.blogspot.com)"
'/Masukan Hwnd Tombol Start
btnHwnd = Bego_Shell_TrayWnd
If btnHwnd > 0 Then
If pos < Len(hText) Then
pos = pos + 1
Else
pos = 1
End If
'/Rubah Text Baru
SetWindowText Bego_Shell_TrayWnd, Mid(hText, pos, 4)
'/Tampilkan perubahan text baru
RedrawWindow Bego_Shell_TrayWnd, ByVal 0&, ByVal 0&, &H1
End If
End Sub
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
------------------------------------------------------------------------------------------------
Function Bego_Shell_TrayWnd() As Long
Dim vbBeGo(1 To 2) As Long
'/Cari class Shell_TrayWnd
vbBeGo(1) = FindWindow("Shell_TrayWnd", vbNullString)
'/Cari Start Button Pada Class Shell_TrayWnd
vbBeGo(2) = FindWindowEx(vbBeGo(1), ByVal 0&, "Button", vbNullString)
Bego_Shell_TrayWnd = vbBeGo(2)
End Function
Private Sub Form_Load()
Timer1.Interval = 200
End Sub
Private Sub Timer1_Timer()
Dim hText As String, btnHwnd As Long
Static pos As Integer
'/Set animasi Text
hText = " Visual Basic Community (www.smart-vb.blogspot.com)"
'/Masukan Hwnd Tombol Start
btnHwnd = Bego_Shell_TrayWnd
If btnHwnd > 0 Then
If pos < Len(hText) Then
pos = pos + 1
Else
pos = 1
End If
'/Rubah Text Baru
SetWindowText Bego_Shell_TrayWnd, Mid(hText, pos, 4)
'/Tampilkan perubahan text baru
RedrawWindow Bego_Shell_TrayWnd, ByVal 0&, ByVal 0&, &H1
End If
End Sub
Animasi Form
Sub AnimateForm(frm As Form)
GotoVal = frm.Height / 2
For Gointo = 1 To GotoVal
DoEvents
frm.Height = frm.Height - 100
frm.Top = (Screen.Height - frm.Height) \ 2
If frm.Height <= 500 Then Exit For
Next Gointo
horiz:
frm.Height = 30
GotoVal = frm.Width / 2
For Gointo = 1 To GotoVal
DoEvents
frm.Width = frm.Width - 100
frm.Left = (Screen.Width - frm.Width) \ 2
If frm.Width <= 2000 Then Exit For
Next Gointo
Unload Me
End Sub
GotoVal = frm.Height / 2
For Gointo = 1 To GotoVal
DoEvents
frm.Height = frm.Height - 100
frm.Top = (Screen.Height - frm.Height) \ 2
If frm.Height <= 500 Then Exit For
Next Gointo
horiz:
frm.Height = 30
GotoVal = frm.Width / 2
For Gointo = 1 To GotoVal
DoEvents
frm.Width = frm.Width - 100
frm.Left = (Screen.Width - frm.Width) \ 2
If frm.Width <= 2000 Then Exit For
Next Gointo
Unload Me
End Sub
Membuat DSN
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" _
(ByVal hwndParent As Long, ByVal fRequest As Long, _
ByVal lpszDriver As String, ByVal lpszAttributes As String) _
As Long
Private Const ODBC_ADD_SYS_DSN = 4
Public Function CreateSQLServerDSN(DSNName As String, _
ServerName As String, Database As String) As Boolean
'PURPOSE: 'CREATES A SYSTEM DSN FOR AN SQL SERVER DATABASE
'PARAMETERS: 'DSNName = DSN Name
'ServerName = Name of Server
'Database = Database to Use
'RETURNS: True if successful, false otherwise
'EXAMPLE: CreateSQLServerDSN "MyDSN", "MyServer", "MyDatabase"
Dim sAttributes As String
sAttributes = "DSN=" & DSNName & Chr(0)
sAttributes = sAttributes & "Server=" & ServerName & Chr(0)
sAttributes = sAttributes & "Database=" & Database & Chr(0)
CreateSQLServerDSN = CreateDSN("SQL Server", sAttributes)
End Function
Public Function CreateAccessDSN(DSNName As String, _
DatabaseFullPath As String) As Boolean
'PURPOSE: 'CREATES A SYSTEM DSN FOR AN ACCESS DATABASE
'PARAMETERS: 'DSNName = DSN Name
'DatabaseFullPath = Full Path to .mdb file
'RETURNS: True if successful, false otherwise
'EXAMPLE: CreateAccessDSN "MyDSN", "C:\MyDb.mdb"
Dim sAttributes As String
'TEST TO SEE IF FILE EXISTS: YOU CAN REMOVE IF YOU
'DON'T WANT IT
If Dir(DatabaseFullPath) = "" Then Exit Function
sAttributes = "DSN=" & DSNName & Chr(0)
sAttributes = sAttributes & "DBQ=" & DatabaseFullPath & Chr(0)
CreateAccessDSN = CreateDSN("Microsoft Access Driver (*.mdb)", _
sAttributes)
End Function
Public Function CreateDSN(Driver As String, Attributes As _
String) As Boolean
'PURPOSE: CREATES A SYSTEM DSN
'PARAMETERS: 'Driver = DriverName
'ATTRIBUTES: 'Attributes; varies as a function
'of the Driver
'EXAMPLE: Refer to Code Above
CreateDSN = SQLConfigDataSource(0&, ODBC_ADD_SYS_DSN, _
Driver, Attributes)
End Function
(ByVal hwndParent As Long, ByVal fRequest As Long, _
ByVal lpszDriver As String, ByVal lpszAttributes As String) _
As Long
Private Const ODBC_ADD_SYS_DSN = 4
Public Function CreateSQLServerDSN(DSNName As String, _
ServerName As String, Database As String) As Boolean
'PURPOSE: 'CREATES A SYSTEM DSN FOR AN SQL SERVER DATABASE
'PARAMETERS: 'DSNName = DSN Name
'ServerName = Name of Server
'Database = Database to Use
'RETURNS: True if successful, false otherwise
'EXAMPLE: CreateSQLServerDSN "MyDSN", "MyServer", "MyDatabase"
Dim sAttributes As String
sAttributes = "DSN=" & DSNName & Chr(0)
sAttributes = sAttributes & "Server=" & ServerName & Chr(0)
sAttributes = sAttributes & "Database=" & Database & Chr(0)
CreateSQLServerDSN = CreateDSN("SQL Server", sAttributes)
End Function
Public Function CreateAccessDSN(DSNName As String, _
DatabaseFullPath As String) As Boolean
'PURPOSE: 'CREATES A SYSTEM DSN FOR AN ACCESS DATABASE
'PARAMETERS: 'DSNName = DSN Name
'DatabaseFullPath = Full Path to .mdb file
'RETURNS: True if successful, false otherwise
'EXAMPLE: CreateAccessDSN "MyDSN", "C:\MyDb.mdb"
Dim sAttributes As String
'TEST TO SEE IF FILE EXISTS: YOU CAN REMOVE IF YOU
'DON'T WANT IT
If Dir(DatabaseFullPath) = "" Then Exit Function
sAttributes = "DSN=" & DSNName & Chr(0)
sAttributes = sAttributes & "DBQ=" & DatabaseFullPath & Chr(0)
CreateAccessDSN = CreateDSN("Microsoft Access Driver (*.mdb)", _
sAttributes)
End Function
Public Function CreateDSN(Driver As String, Attributes As _
String) As Boolean
'PURPOSE: CREATES A SYSTEM DSN
'PARAMETERS: 'Driver = DriverName
'ATTRIBUTES: 'Attributes; varies as a function
'of the Driver
'EXAMPLE: Refer to Code Above
CreateDSN = SQLConfigDataSource(0&, ODBC_ADD_SYS_DSN, _
Driver, Attributes)
End Function
Hapus Textbox Dengan Fungsi
Public Sub ClearTextBoxes(frmClearMe As Form)
Dim txt As Control
For Each txt In frmClearMe
If TypeOf txt Is TextBox Then txt.Text = ""
Next
End Sub
Dim txt As Control
For Each txt In frmClearMe
If TypeOf txt Is TextBox Then txt.Text = ""
Next
End Sub
Langganan:
Komentar (Atom)
