Selasa, 24 Agustus 2010

Tips dan Trik Penanganan File dan Direktori Pada Visual Basic 6.0

Ada kalanya program yang kita buat membutuhkan interaksi dengan file dan direktori yang ada di komputer kita, misalkan jika anda membuat program yang dapat mengexport data yang ada kedalam file Excel, atau program anda dapat merestore database nya dari hasil backup-an yang telah dibuat sebelumnya.

Berikut ini beberapa contoh project yang menangani permasalahan file dan direktori

T&T#1) MELIHAT PROPERTI FILE

Buka project baru Standard.Exe, tempatkan 1 buah CommandButton dan ubah caption nya menjadi Properti, double click commandbutton dan masukkan kode berikut :

Private Sub Command1_Click()
  'Ganti 'c:\autoexec.bat' dengan nama file yang Anda
  'ingin lihat kotak dialog property-nya...
  Call ShowProps("c:\autoexec.bat", Me.hwnd)
End Sub

Public Sub ShowProps(FileName As String, OwnerhWnd _
As Long)
Dim SEI As SHELLEXECUTEINFO
Dim r As Long
With SEI
  .cbSize = Len(SEI)
  .fMask = SEE_MASK_NOCLOSEPROCESS Or _
  SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
  .hwnd = OwnerhWnd
  .lpVerb = "properties"
  .lpFile = FileName
  .lpParameters = vbNullChar
  .lpDirectory = vbNullChar
  .nShow = 0
  .hInstApp = 0
  .lpIDList = 0
End With
r = ShellExecuteEX(SEI)
End Sub

Lalu klik Project -> Add Module, double klik module1 dan masukkan kode berikut :
Type SHELLEXECUTEINFO
  cbSize As Long
  fMask As Long
  hwnd As Long
  lpVerb As String
  lpFile As String
  lpParameters As String
  lpDirectory As String
  nShow As Long
  hInstApp As Long
  lpIDList As Long
  lpClass As String
  hkeyClass As Long
  dwHotKey As Long
  hIcon As Long
  hProcess As Long
End Type

Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_FLAG_NO_UI = &H400
Declare Function ShellExecuteEX Lib "shell32.dll" Alias _
"ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long
 Tekan F5 dan jalankan project

Klik tombol Properties, maka akan ditampilkan properties dari file autoexec.bat yang kita gunakan sebagai contoh

T&T#2) MEMBUAT FILE EXCEL DARI PROGRAM

Buka project baru Standard.Exe, masukkan 1 buah CommandButton ke dalam form, double klik commandbutton dan masukkan kode berikut :
Private Sub Command1_Click()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet

Set xlApp = New Excel.Application
Set xlWB = xlApp.Workbooks.Add
Set xlWS = xlWB.Worksheets.Add

'Baris berikut ini akan mengisi cell (2,2) dengan
'tulisan "hello"dan akan mengisi cell (1,3) dengan
'tulisan "World"

xlWS.Cells(2, 2).Value = "hello"
xlWS.Cells(1, 3).Value = "World"

'Baris berikut ini menyimpan spreadsheet menjadi
'file "c:\mysheet.xls".

xlWS.SaveAs "c:\mysheet.xls"
xlApp.Quit

'Bebaskan memory...

Set xlWS = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub

Tekan F5 dan jalankan project

T&T#3) MEMBUKA KOTAK DIALOG “BROWSE FOR FOLDER”

Buka project baru Standard.Exe, masukkan 1 buah CommandButton ke dalam form, dan ubah caption menjadi Browse double klik commandbutton, dan masukkan kode berikut :

Private Sub Command1_Click()
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo

'Ganti 'This Is My Title' dengan judul yang ingin Anda
'letakkan pada kotak dialog "Browse For Folders" 'tersebut.

szTitle = "This Is My Title"
With tBrowseInfo
  .hWndOwner = Me.hWnd
  .lpszTitle = lstrcat(szTitle, "")
  .ulFlags = BIF_RETURNONLYFSDIRS + _
  BIF_DONTGOBELOWDOMAIN
End With

lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer

'Nilai sBuffer adalah directori yang dipilih oleh
'user pada kotak dialog.

sBuffer = Left(sBuffer, InStr(sBuffer, _
vbNullChar) - 1)

MsgBox sBuffer
End If
End Sub
Klik Project -> Add Module, double klik Module1, dan masukkan kode berikut :
'Setelah Anda menjalankan program ini, pilih direktori 
'yang Anda inginkan pada kotak dialog tersebut. 
'Anda akan melihat sebuah kotak pesan yang menampilkan 
'nama direktori yang Anda pilih tadi.

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_DONTGOBELOWDOMAIN = 2
Public Const MAX_PATH = 260
Declare Function SHBrowseForFolder Lib _
"shell32" (lpbi As BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Declare Function lstrcat Lib "kernel32" _
Alias "lstrcatA" (ByVal lpString1 As String, ByVal _
lpString2 As String) As Long

Public Type BrowseInfo
   hWndOwner As Long
   pIDLRoot As Long
   pszDisplayName As Long
   lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Tekan F5 dan jalankan project

T&T#4) MEMBUKA WINDOWS EXPLORER DENGAN DIREKTORI TERTENTU

Buka project baru Standard.Exe, masukkan 1 buah CommandButton ke dalam form, double klik commandbutton, dan masukkan kode berikut :
Private Sub Command1_Click()
'Tentukan nama direktori yang akan Anda buka dengan
'windows explorer
   OpenExplorer ("C:\Program Files\")
End Sub

Public Sub OpenExplorer(Optional InitialDirectory As String)
     ShellExecute 0, "Explore", InitialDirectory, vbNullString, _
     vbNullString, SW_SHOWNORMAL
End Sub
Klik Project -> Add Module, double klik Module1, dan masukkan kode berikut :
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
Tekan F5 dan jalankan project

T&T#5) MEMERIKSA KEBERADAAN SUATU DIREKTORI

Buka project baru Standard.Exe, double klik Form1 dan masukkan kode berikut :
'Contoh direktori yang diperiksa adalah "C:\Windows"
Private Sub Form_Load()
Const ATTR_DIRECTORY = 16
If Dir$("c:\windows", ATTR_DIRECTORY) <> "" Then
MsgBox "Direktori ada!", vbInformation, "Ada"
Else MsgBox "Direktori tidak ada!", vbCritical, "Tidak Ada" 
End If 
End Sub 
Tekan F5 dan jalankan project

T&T#6) MEMERIKSA KEBERADAAN SUATU FILE

Buka project baru Standard.Exe, double klik Form1 dan masukkan kode berikut :
'Contoh file yang diperiksa adalah "C:\autoexec.bat"
Private Sub Form_Load()
'Ganti "c:\autoexec.bat" dengan nama file (lengkap dengan path-nya)
'yang Anda inginkan, untuk memeriksa keberadaan file tersebut.
If Dir$("c:\autoexec.bat") <> "" Then
   MsgBox "File ada!", vbInformation, "Ada"
Else
   MsgBox "File tidak ada!", vbCritical, "Tidak Ada"
End If
End Sub
Tekan F5 dan jalankan project

T&T#7) MEMINDAHKAN FILE

Buka project baru Standard.Exe, masukkan 1 buah CommandButton ke dalam form, double klik commandbutton, dan masukkan kode berikut :
'Contoh ini memindahkan file 'c:\MyFile.Zip' ke 'direktori 'c:\MyDir'.
Private Sub Command1_Click()
A = MoveFile("c:\MyFile.Zip", "c:\MyDir\MyFile.Zip")
If A Then
       MsgBox "File berhasil dipindahkan!", _
              vbInformation, "Sukses Pindah File"
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
Klik Project -> Add Module, double klik Module1, dan masukkan kode berikut : 
Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" _ 
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String) _
As Long
Tekan F5 dan jalankan project

T&T#8) MENGAMBIL DATA NAMA FILE

Buka project baru Standard.Exe, double klik Form1 dan masukkan kode berikut :
Private Sub Form_Load()
'Ganti dengan nama lengkap file (beserta path-nya)
'yang ingin Anda ambil nama file-nya.
MsgBox StripPath("c:\folderku\fileku.exe") 'Contoh ini
'menghasilkan: 'myfile.exe'
End Sub

Function StripPath(T$) As String
Dim x%, ct%
StripPath$ = T$
x% = InStr(T$, "\")
Do While x%
  ct% = x%
  x% = InStr(ct% + 1, T$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function

Tekan F5 dan jalankan project

T&T#9) MENGAMBIL EKSTENSI FILE

Buka project baru Standard.Exe, double klik Form1 dan masukkan kode berikut :
Private Sub Form_Load()
    'Ganti nama file di bawah dengan nama file yang
    'ingin Anda ambil data ekstensinya...
    MsgBox GetExtension("c:\folderku\fileku.exe")
    'Contoh ini menghasilkan 'exe'
End Sub

'Fungsi ini juga akan memeriksa jika yang diberikan
'hanya nama direktori...
Function GetExtension(FileName As String)
    Dim PthPos, ExtPos As Integer
    For i = Len(FileName) To 1 Step -1
        If Mid(FileName, i, 1) = "." Then
            ExtPos = i
            For j = Len(FileName) To 1 Step -1
                If Mid(FileName, j, 1) = "\" Then
                    PthPos = j
                    Exit For
                End If
            Next j
            Exit For
        End If
    Next i
    If PthPos > ExtPos Then
        Exit Function
    Else
        If ExtPos = 0 Then Exit Function
        GetExtension = Mid(FileName, ExtPos + 1, _
                       Len(FileName) - ExtPos)
    End If
End Function
Tekan F5 dan jalankan project

T&T#10) MENGETAHUI UKURAN SUATU DIREKTORI

Buka project baru Standard.Exe, masukkan 1 buah CommandButton ke dalam form, double klik commandbutton, dan masukkan kode berikut :
Private Sub Command1_Click()
  'Ganti 'C:\Windows' di bawah dengan nama direktori
  'yang ingin Anda ketahui ukurannya.
  MsgBox "Ukuran direktori C:\Windows = " & _
  Format(SizeOf("C:\Windows"), "#,#") & _
  " bytes", vbInformation, "Ukuran Direktori"
End Sub

Public Function SizeOf(ByVal DirPath As String) As Double
Dim hFind As Long
Dim fdata As WIN32_FIND_DATA
Dim dblSize As Double
Dim sName As String
Dim x As Long
On Error Resume Next
  x = GetAttr(DirPath)
  If Err Then SizeOf = 0: Exit Function
  If (x And vbDirectory) = vbDirectory Then
     dblSize = 0
     Err.Clear
     sName = Dir$(EndSlash(DirPath) & "*.*", vbSystem _
            Or vbHidden Or vbDirectory)
     If Err.Number = 0 Then
        hFind = FindFirstFile(EndSlash(DirPath) & _
                "*.*", fdata)
       If hFind = 0 Then Exit Function
        Do
        If (fdata.dwFileAttributes And vbDirectory) = _
           vbDirectory Then
           sName = Left$(fdata.cFileName, _
                InStr(fdata.cFileName, vbNullChar) - 1)
           If sName <> "." And sName <> ".." Then
              dblSize = dblSize + _
                      SizeOf(EndSlash(DirPath) & sName)
            End If
          Else
            dblSize = dblSize + fdata.nFileSizeHigh * _
                      65536 + fdata.nFileSizeLow
          End If
          DoEvents
        Loop While FindNextFile(hFind, fdata) <> 0
        hFind = FindClose(hFind)
     End If
  Else
     On Error Resume Next
     dblSize = FileLen(DirPath)
  End If
  SizeOf = dblSize
End Function

Private Function EndSlash(ByVal PathIn As String) As String
  If Right$(PathIn, 1) = "\" Then
     EndSlash = PathIn
  Else
     EndSlash = PathIn & "\"
  End If
End Function
Klik Project -> Add Module, double klik Module1 dan masukkan kode berikut :
Public Const MAX_PATH = 260
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

Declare Function FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
  
Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
  
Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long
Tekan F5 dan jalankan project

T&T#11) MENGHAPUS FILE KE RECYCLE BIN

Buka project baru Standard.Exe, masukkan 1 buah CommandButton ke dalam form, double klik commandbutton, dan masukkan kode berikut :
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
Klik Project -> Add Module, double klik Module1, dan masukkan kode berikut :
'Jika pilihan 'delete to recycle bin
'Windows di-'nonaktif-kan, file akan
'langsung dihapus secara 'permanen (?)... hati-hati!

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
 Tekan F5 dan jalankan project


Jika anda mengalami kesulitan dalam mengikuti pembahasan kita diatas, silahkan klik disini untuk mendownload semua contoh project yang disajikan pada tutorial kali ini. Selamat mencoba.

Be My Friend On Facebook

1 komentar: