19 January 2008

Simple Stopwatch Application from VB 6.0

Untuk membuat sebuah aplikasi yang menggunakan control timer satu hal yang perlu diperhatiin atau diketahui yaitu interval yang digunakan. Pada visual basic untuk satu detik nilai interval timernya adalah 1000.

Code program ini bisa kalian coba buat dengan metode perulangan atau looping. Namun pada code ini saya menggunakan "if bersarang". dan saya mencoba membuat sebuah logika yang sederhana yang semoga saja bisa dimengerti.
Berikut tampilan design dan name dari tiap control nya aplikasinya:


Dan berikut adalah coding yang digunakan :

Dim jam, menit, detik, milisec

Private Sub cmdExit_Click()

Timer1.Enabled = False
Timer2.Enabled = False
End

End Sub

Private Sub cmdreset_Click()

'membuat tampilan menjadi 00:00:00:00

lblSecon.Caption = "00"
lblMinute.Caption = "00"
lblHour.Caption = "00"

'pengaturan nilai variabel

jam = "0"
menit = "0"
detik = "0"

End Sub

Private Sub cmdStart_Click()

Timer1.Enabled = True
Timer2.Enabled = True
cmdreset.Enabled = False
cmdStart.Enabled = False
cmdStop.Enabled = True

jam = lblHour.Caption
menit = lblMinute.Caption
detik = lblSecon.Caption

End Sub

Private Sub cmdStop_Click()

Timer1.Enabled = False
Timer2.Enabled = False
cmdreset.Enabled = True
cmdStart.Enabled = True
cmdStop.Enabled = False

End Sub

Private Sub Form_Load()

'pemberian nilai properti interval timer
' interval untuk satu detik sama dengan kuranglebih 1000

Timer1.Interval = 1000
Timer2.Interval = 500

End Sub

Private Sub Timer1_Timer()

detik = detik + 1
If Val(detik) > 59 Then 'fungsi "val" untuk menggubah karakter menjadi angka atau number

detik = "00"
menit = Val(menit) + 1

If Val(menit) > 59 Then

menit = "00"
jam = Val(jam) + 1

If Val(jam) > 23 Then
jam = "00"

End If
End If
End If

d = Len(detik) 'fungsi "len" berguna untuk mengetahui banyak/panjang karakter
If d = 1 Then
lblSecon.Caption = "0" & detik 'membuat tampilan menjadi "0X"
'tanda "&" berfungsi untuk penggabungan karakter
Else
lblSecon.Caption = detik
End If

m = Len(menit)
If m = 1 Then
lblMinute.Caption = "0" & menit
Else
lblMinute.Caption = menit
End If

j = Len(jam)
If j = 1 Then
lblHour.Caption = "0" & jam
Else
lblHour.Caption = jam
End If

End Sub

Private Sub Timer2_Timer()

'Untuk membuat karakter titik dua ( : ) berkedip

Label1.Visible = Not Label1.Visible
Label2.Visible = Not Label2.Visible

End Sub

Untk pengembangannya bisa dicoba menambahkan fasilitas milisecon nya.

Read more ...

03 January 2008

Mengubah atribut file dengan Ms. VB 6.0

Kalo gak salah satu tahun 2006 yang lalu aku dapet komputer yang kena sebuah virus, aku gak tau apa namanya tapi aku dan teman-teman menyebutnya virus 463 karena besar file yang dihasilkan sebesar 463 Kb. Virus ini menghiden semua folder yang ada dan mengantinya dengan file bentukan yang baru namun berekstensi aplikasi atau (.exe). Si virus berhasil aku lumpuhkan dan file bentukannya sudah aku bersihkan, namun karena semua folder di hidden sama si virus mau gak mau aku harus mengembaliinnya seperti semula lagi. Aku coba klik kanan foldernya lalu propertis dengan harapan bisa aku hilangin centang pada hidden-nya, tapi ternyata si virus bukan cuma meng-hidden-nya tapi meng-superhidden atau hidden system. cara satu-satunya dengan cara menghilangkan attribut filenya melalui command promt dengan mengetikkan " attrib -S -H nama_file ", ko cuma satu file seh gak masalah, tapi klo semua folder tentu butuh waktu yang sangat lama dan capek banget.

Akhirnya aku mencoba membuat sebuah aplikasi untuk mengubah attribut filenya menggunakan microsoft visual basic 6.0 , dan berhasil. neh aku bagiin sebuah aplikasi sederhana untuk membuka file yang ke superhidden.

Tampilan aplikasinya sbb:


Berikut adalah coding buat modulnya :



Public Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Public Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Public Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Public Const MAX_PATH = 260
Public Const MAXWORD = &HFFFF
Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100

Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Public Function StripNulls(OriginalStr As String) As String
If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If

StripNulls = OriginalStr
End Function


Dan ini coding pada formnya :

Option Explicit

Function FindFilesAPI(path As String, SearchStr As String, FileCount As Integer, DirCount As Integer)

Dim FileName As String
Dim DirName As String
Dim SearchPath As String, FindStr As String
Dim dirNames() As String
Dim nDir As Integer
Dim i As Integer
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Integer
Dim x As Long
Dim xx As Long

If Right(path, 1) <> "\" Then path = path & "\"
nDir = 0
ReDim dirNames(nDir)
Cont = True
hSearch = FindFirstFile(path & "*", WFD)

If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont

DirName = StripNulls(WFD.cFileName)

If (DirName <> ".") And (DirName <> "..") Then
If GetFileAttributes(path & DirName) Or FILE_ATTRIBUTE_DIRECTORY Then

dirNames(nDir) = DirName
DirCount = DirCount + 1

nDir = nDir + 1
ReDim Preserve dirNames(nDir)

End If
End If
If (DirName <> ".") And (DirName <> "..") And (DirName <> "RECYCLER") And (DirName <> "System Volume Information") And (DirName <> "Thumbs.db") And (DirName <> "Desktop.ini") And (DirName <> "desktop.ini") Then
x = SetFileAttributes(path & DirName, FILE_ATTRIBUTE_NORMAL)
xx = CloseHandle(x)

List1.AddItem path & DirName
End If
Cont = FindNextFile(hSearch, WFD)

Loop
Cont = FindClose(hSearch)

End If


If nDir > 0 Then
For i = 0 To nDir - 1
FindFilesAPI = FindFilesAPI(path & dirNames(i) & "\", SearchStr, FileCount, DirCount)
Next i
End If

End Function

Private Sub Command1_Click()
Dim SearchPath As String, FindStr As String
Dim FileSize As Long
Dim NumFiles As Integer, NumDirs As Integer
Dim msg

If Trim(UCase(Text1.Text)) = "C:\" Then
msg = MsgBox("Any Directories System will be show " & Chr(13) & " Are you sure to continue ?", vbQuestion + vbYesNo, ":: Confirmation ::")
If msg = vbYes Then
GoTo scan_acc
End If
Else
GoTo scan_acc
End If
Exit Sub

scan_acc:
Screen.MousePointer = vbHourglass
Command2.Enabled = False
Command1.Caption = "Please....wait"
List1.Clear
Label4.Caption = ""
SearchPath = Text1.Text
FindStr = Label1.Caption
FileSize = FindFilesAPI(SearchPath, FindStr, NumFiles, NumDirs)
Label4.Caption = NumDirs & " Directories found in ' " & SearchPath & "'"
Screen.MousePointer = vbDefault
Command2.Enabled = True
Command1.Caption = "&Scan"
End Sub

Private Sub Command2_Click()
End
End Sub

Private Sub Dir1_Change()
Text1.Text = Dir1.path
End Sub

Private Sub Drive1_Change()
On Error GoTo err
Dir1.path = Drive1.Drive
Exit Sub

err:
MsgBox "Device not ready", vbExclamation, ":: Device ::"
Drive1.Drive = "D:\"
Exit Sub
End Sub

Private Sub Form_Load()
Drive1.Drive = "D:\"
End Sub

Semoga aplikasi ini bisa membantu dan bisa memberikan ide baru buat kamu yang pengen belajar bareng aku.




Read more ...
 
>