Create file Cab dan Expand with VB6

jika kita akan merubah file setup windows jika file themeui.dll dibuat menjadi themeui.dl_
Program ini saya buat guna menyingkat waktu dalam mengekstrak file windows yang berektensi *.dl_ , *.cp_, *.ex_ dan lain-lainnya kemudian mengembalikan file tersebut ke bentuk semula.
Kenapa kog harus di ekstrak padahal file tersebut kan sudah ada di file windows yang sudah terinstall tinggal pakai ambil aja di c:\windows\system32 kan ga repot. He..he..
Tapi kalau anda pengin membuat modifikasi file windows tersebut dari file setup pada CD windows pasti anda akan kebingungan. Sebenarnya bisa pakai command prompt yang disediakan oleh windows tapi akan memperlama anda dalam mengetik di command prompt.
Kemudian karena aku terinspirasi dengan perintah-perintah di command prompt sehingga aku membuat program ini. Mungkin aja para master akan tertawa melihat source code yang saya kirim ini maklum newbie dalam penulisan bahasa program.

File terdiri dari
frmMain (4 label, 4 commandbutton)
modMakeFolder
CommonDialog (User Control)
Langsung aja ya. Kita tuliskan codenya
Untuk frmMain.frm
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Const SYNCHRONIZE = &H100000
Private Const INFINITE = -1&
Dim FileNama As String
Private Sub ShellAndWait(ByVal program_name As String)
Dim process_id As Long
Dim process_handle As Long

process_id = Shell(program_name, vbHide)
DoEvents
' tunggu sampai program selesai
process_handle = OpenProcess(SYNCHRONIZE, 0, process_id)
If process_handle <> 0 Then
WaitForSingleObject process_handle, INFINITE
CloseHandle process_handle
End If
End Sub

Private Sub cmdAbout_Click()
MsgBox "Program dibuat oleh Sodikin" + Chr(13) + _
"Email : hack.chin@gmail.com" + Chr(13) + _
"Site :http://s0dikin.blogspot.com" + Chr(13) + _
"Thank for :" + Chr(13) + _
"------------------------------------------" + Chr(13) + _
"Allah SWT" + Chr(13) + _
"Bokap n Nyokap" + Chr(13) + _
"Istri Tercinta" + Chr(13) + _
"All Frinds" + Chr(13) + _
"------------------------------------------" + Chr(13) + _
"Forum : www.xcode.co.id; www.vb-bego.net", vbInformation + vbOKOnly, "About Me?"

End Sub

Private Sub cmdExit_Click()
End
End Sub

Private Sub cmdExpand_Click()
With CD
.Filter = "*.sy_, *.dl_, *.ex_, *.cp_|*.sy_;*.dl_;*.ex_;*.cp_|"
.DialogTitle = "Buka File Xwaja"
.ShowOpen
End With
txtSource.Text = CD.FileName
Label2.Caption = CD.FileTitle
txtHasil.Text = Left(CD.FileName, Len(txtSource.Text) - Len(Label2.Caption)) + "HasilExpand"
CreateDirectory txtHasil.Text, Keamanan
'buat file BAT untuk melakukan Expand
FileNama = GetSystemPath + "chungchin.bat"
Open FileNama For Output As #1
Print #1, Tab(1); "expand.exe -r " + txtSource.Text + " " + txtHasil.Text
Close #1
'Jalankan file BAT yang telah dibuat
ShellAndWait FileNama
'Hapus file BAT yang telah dibuat
Kill FileNama
MsgBox "expand file : " + txtSource.Text + Chr(13) + _
"silahkan di lihat di " + txtHasil.Text
End Sub

Private Sub cmdMakeCab_Click()
With CD
.Filter = "*.sys, *.dll, *.exe|*.sys;*.dll;*.exe|"
.DialogTitle = "Buka File BM@"
.ShowOpen
End With
txtSource.Text = CD.FileName
Label2.Caption = CD.FileTitle
Label3.Caption = Left(CD.FileName, Len(txtSource.Text) - Len(Label2.Caption)) + "HasilCab"
txtHasil.Text = Label3.Caption + "\" + Left(CD.FileTitle, Len(Label2.Caption) - 1) + "_"
CreateDirectory Label3.Caption, Keamanan
'buat file BAT untuk melakukan MakeCAB
FileNama = GetSystemPath + "chungchin.bat"
Open FileNama For Output As #1
Print #1, Tab(1); "makecab.exe " + txtSource.Text + " " + txtHasil.Text
Close #1
'Jalankan file BAT yang telah dibuat
ShellAndWait FileNama
'Hapus file BAT yang telah dibuat
Kill FileNama
MsgBox "MakeCAB file : " + txtSource.Text + Chr(13) + _
"silahkan di lihat di " + txtHasil.Text

End Sub

Kemudian anda ketikkan code ini untuk Module (modMakeFolder)
Option Explicit
Public Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Public Declare Function NdamelAnak Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Public Declare Function GetSystemDirectory Lib "kernel32.dll" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Public Keamanan As SECURITY_ATTRIBUTES
Public Sub GaweAnakManeh(Ibu As String, Anak As String)
NdamelAnak Ibu, Anak, 0
End Sub


Public Function GetSystemPath() As String

On Error Resume Next
Dim Buffer As String * 255
Dim x As Long
x = GetSystemDirectory(Buffer, 255)
GetSystemPath = Left(Buffer, x) & "\"

End Function

Yang terakhir anda buat Usercontrol kemudian beri nama CommonDialog (sebernarnya bisa pakai comdlg.ocx yang sudah terinstall, tapi program ga akan portable karena harus menyertakan comdlg.ocx. tapi kalau kita buat sendiri maka program yang kita buat bisa di jalankan di semua komputer (tapi yang berbasis windows tentunya)
Langsung aja setelah buat UserControl langsung tuliskan code berikut:

Option Explicit
Private Declare Function GetOpenFileName Lib _
"COMDLG32.DLL" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib _
"COMDLG32.DLL" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long

Private cdlg As OPENFILENAME
Private LastFileName As String

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_EXPLORER = &H80000
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_LONGNAMES = &H200000
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_NOLONGNAMES = &H40000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_READONLY = &H1
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
Private Const OFN_SHOWHELP = &H10

Public Enum DialogFlags
ALLOWMULTISELECT = OFN_ALLOWMULTISELECT
CREATEPROMPT = OFN_CREATEPROMPT
ENABLEHOOK = OFN_ENABLEHOOK
ENABLETEMPLATE = OFN_ENABLETEMPLATE
ENABLETEMPLATEHANDLE = OFN_ENABLETEMPLATEHANDLE
EXPLORER = OFN_EXPLORER
EXTENSIONDIFFERENT = OFN_EXTENSIONDIFFERENT
FILEMUSTEXIST = OFN_FILEMUSTEXIST
HIDEREADONLY = OFN_HIDEREADONLY
LONGNAMES = OFN_LONGNAMES
NOCHANGEDIR = OFN_NOCHANGEDIR
NODEREFERENCELINKS = OFN_NODEREFERENCELINKS
NOLONGNAMES = OFN_NOLONGNAMES
NONETWORKBUTTON = OFN_NONETWORKBUTTON
NOREADONLYRETURN = OFN_NOREADONLYRETURN
NOTESTFILECREATE = OFN_NOTESTFILECREATE
NOVALIDATE = OFN_NOVALIDATE
OVERWRITEPROMPT = OFN_OVERWRITEPROMPT
PATHMUSTEXIST = OFN_PATHMUSTEXIST
ReadOnly = OFN_READONLY
SHAREAWARE = OFN_SHAREAWARE
SHAREFALLTHROUGH = OFN_SHAREFALLTHROUGH
SHARENOWARN = OFN_SHARENOWARN
SHAREWARN = OFN_SHAREWARN
ShowHelp = OFN_SHOWHELP
End Enum

Private CFm_CancelError As Boolean
Private CFm_DialogTitle As String
Private CFm_DefaultExt As String
Private CFm_FileName As String
Private CFm_FileTitle As String
Private CFm_Filter As String
Private CFm_Flags As DialogFlags
Private CFm_InitDir As String

Public Property Get CancelError() As Boolean
CancelError = CFm_CancelError
End Property

Public Property Let CancelError(PropVal As Boolean)
CFm_CancelError = PropVal
End Property

Public Property Get DialogTitle() As String
DialogTitle = CFm_DialogTitle
End Property

Public Property Let DialogTitle(PropVal As String)
CFm_DialogTitle = PropVal
End Property

Public Property Get DefaultExt() As String
DefaultExt = CFm_DefaultExt
End Property

Public Property Let DefaultExt(PropVal As String)
CFm_DefaultExt = PropVal
End Property

Public Property Get FileName() As String
FileName = CFm_FileName
End Property

Public Property Let FileName(PropVal As String)
CFm_FileName = PropVal
End Property

Public Property Get FileTitle() As String
FileTitle = CFm_FileTitle
End Property

Public Property Let FileTitle(PropVal As String)
CFm_FileTitle = PropVal
End Property

Public Property Get Filter() As String
Filter = CFm_Filter
End Property

Public Property Let Filter(PropVal As String)
CFm_Filter = PropVal
End Property

Public Property Get Flags() As DialogFlags
Flags = CFm_Flags
End Property

Public Property Let Flags(PropVal As DialogFlags)
CFm_Flags = PropVal
End Property

Public Property Get InitDir() As String
InitDir = CFm_InitDir
End Property

Public Property Let InitDir(PropVal As String)
CFm_InitDir = PropVal
End Property


Private Sub UserControl_Initialize()
UserControl.Height = 32 * 15
UserControl.Width = 32 * 15
End Sub

Private Sub UserControl_Resize()
UserControl.Height = 32 * 15
UserControl.Width = 32 * 15
End Sub

Public Sub ShowOpen()
Dim i As Integer
Dim flt As String, idir As String, trez As String
On Error Resume Next
flt = Replace(Filter, "|", Chr(0))

If Len(flt) = 0 Then flt = Replace("All Files (*.*)|*.*|", _
"|", Chr(0))
If Right(flt, 1) <> Chr(0) Then flt = flt & Chr(0)
If Len(InitDir) = 0 Then idir = FileName Else idir = InitDir

cdlg.hwndOwner = UserControl.Parent.hWnd
cdlg.hInstance = App.hInstance
cdlg.lpstrFilter = flt
cdlg.lpstrFile = FileName & String(255 - Len(FileName), _
Chr(0))
cdlg.nMaxFile = 256
cdlg.lpstrFileTitle = String(255, Chr(0))
cdlg.nMaxFileTitle = 256
cdlg.lpstrInitialDir = idir
cdlg.lpstrTitle = DialogTitle
cdlg.Flags = Flags
cdlg.lStructSize = Len(cdlg)
trez = IIf(GetOpenFileName(cdlg), Trim(cdlg.lpstrFile), "")

If Len(trez) > 0 Then FileName = trez: FileTitle = _
cdlg.lpstrFileTitle Else If CancelError Then _
Err.Raise -1, "CDL control", "Cancel"

End Sub

Public Sub ShowSave()

Dim i As Integer
Dim flt As String, idir As String, trez As String
On Error Resume Next
flt = Replace(Filter, "|", Chr(0))

If Len(flt) = 0 Then flt = Replace("All Files (*.*)|*.*|", _
"|", Chr(0))
If Right(flt, 1) <> Chr(0) Then flt = flt & Chr(0)
If Len(InitDir) = 0 Then idir = FileName Else idir = InitDir

cdlg.hwndOwner = UserControl.Parent.hWnd
cdlg.hInstance = App.hInstance
cdlg.lpstrFilter = flt
cdlg.lpstrFile = FileName & String(255 - Len(FileName), _
Chr(0))
cdlg.nMaxFile = 256
cdlg.lpstrFileTitle = String(255, Chr(0))
cdlg.nMaxFileTitle = 256
cdlg.lpstrInitialDir = idir
cdlg.lpstrTitle = DialogTitle
cdlg.Flags = Flags
cdlg.lStructSize = Len(cdlg)
trez = IIf(GetSaveFileName(cdlg), Trim(cdlg.lpstrFile), "")

If Len(trez) > 0 Then FileName = trez: FileTitle = _
cdlg.lpstrFileTitle Else If CancelError Then _
Err.Raise -1, "CDL control", "Cancel"

End Sub

Sudah selesai dalam penulisan silahkan aja di jalankan.
'|<<<<<<<<<<<<<..:: Programmer ::..>>>>>>>>>>>>>>|
'| Name : Sodikin |
'| site : http://s0dikin.blogspot.com |
'| email : hack.chin@gmail.com |
'| mr_hack77@yahoo.com |
'| chung_chin@joomlaku.info |
'| forum : www.xcode.or.id |
'| www.vb-bego.net |
'|<<<<<<<<<<<<<..:: End of File ::..>>>>>>>>>>>>>|