Seperti yang kita ketahui, walaupun komponen ocx yang kita gunakan telah teregister dalam registry, akan tetapi file ocx-ocx tersebut tidak selalu berada pada folder %systemroot%\system32\, dan hal tersebut diperparah dengan seringnya kita meregister melalui contect menu (klik kanan melalui Windows Explorer) atau menggunakan tools-tools kecil tanpa mengkopi terlebih dahulu file-file ocx-nya ke dalam folder %systemroot%\system32\.
Kode utamanya adalah milik Waty Thierry, selanjutnya saya memodifikasinya sehingga menjadi Smart OCX Dependencies Finder.
'simpan kode di bawah dalam module, atau Anda buat menu Add-Ins agar mudah diaksesContoh penggunaan module diatas:
' ---------------------------------------------------------------------------
' Programmer Name : Waty Thierry
' Web Site : www.geocities.com/ResearchTriangle/6311/
' E-Mail : waty.thierry@usa.net
' Date : 03/10/1999
' Time : 10:30
' ---------------------------------------------------------------------------
' Comments : List all DLL and OCX dependencies a
' process has
' Put declarations and function into a .bas module
' Call the function by passing an empty string array
' Then read back the answer from the same array:
' e.g., dim sArray() as string, iCtr as integer
' GetProcessModules sArray
' For ictr = 0 to ubound(sArray)
' Debug.print sArray(ictr)
' Next
' ---------------------------------------------------------------------------
Option Explicit
Private Const MAX_MODULE_NAME32 = 255
Private Const MAX_PATH = 260
Private Const TH32CS_SNAPMODULE = &H8
Private Type MODULEENTRY32
dwSize As Long
th32ModuleID As Long
th32ProcessID As Long
GlblcntUsage As Long
ProccntUsage As Long
modBaseAddr As Long
modBaseSize As Long
hModule As Long
szModule As String * 256
szExePath As String * MAX_PATH
End Type
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Module32First Lib "kernel32" ByVal hSnapShot As Long, lpMe32 As MODULEENTRY32) As Long
Private Declare Function Module32Next Lib "kernel32" ByVal hSnapShot As Long, lpMe32 As MODULEENTRY32) As Long
Private Declare Sub CloseHandle Lib "kernel32" ByVal hPass As Long)
Private Declare Function RtlMoveMemory Lib "kernel32" ByVal pDest As Any, ByVal pSource As Any, ByVal ByteLen As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" ) As Long
Public Function GetProcessModules(DependencyList() As String) As Boolean
Dim Me32 As MODULEENTRY32
Dim lRet As Long
Dim lhSnapShot As Long
Dim pID As Long
Dim iLen As Integer
Dim sModule As String
pID = GetCurrentProcessId
ReDim DependencyList(0) As String
lhSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPMODULE, CLng(pID))
If lhSnapShot = 0 Then
GetProcessModules = False
Exit Function
End If
Me32.dwSize = Len(Me32)
lRet = Module32First(lhSnapShot, Me32)
Do While lRet
If Me32.th32ProcessID = CLng(pID) Then
With Me32
iLen = InStr(.szExePath, Chr(0))
If iLen = 0 Then
sModule = CStr(.szExePath)
Else
sModule = Left(.szExePath, iLen - 1)
End If
If DependencyList(0) = "" Then
DependencyList(0) = sModule
Else
ReDim Preserve _
DependencyList(UBound(DependencyList) + 1)
DependencyList(UBound(DependencyList)) = sModule
End If
End With
End If
lRet = Module32Next(lhSnapShot, Me32)
Loop
CloseHandle lhSnapShot
GetProcessModules = True
Exit Function
TheErr:
GetProcessModules = False
End Function
' === End modul milik Waty Thierry ===
'----------------------------------------------------------------------------
'Kode di bawah merupakan kode yang saya buat, Anda dapat memodifikasinya
'agar sesuai dengan kebutuhan Anda.
'kode ini akan membuat tiga file dan satu folder, secara berturut-turut
'file Install.bat, UnInstall.bat, Readme.txt dan terakhir folder ActiveX
'---------------------------------------------------------------------------
'Cek keberadaan file dan folder, kedua fungsi di bawah bisa dimodif dan dijadikan
'satu buah fungsi
Public Function IsFolderExist(FolderName As String) As Boolean
IsFolderExist = Dir$(FolderName, vbDirectory + vbHidden) <> "")
End Function
Public Function IsFileExist(FileName As String) As Boolean
IsFileExist = Dir$(FileName, vbHidden + vbSystem + vbNormal) <> ""
End Function
'Fungsi untuk mendapatkan file dari path lengkap:
Public Function GetFileName(FileName As String) As String
Dim str() As String
str = Split(FileName, "\")
GetFileName = str(UBound(str))
End Function
'Cek apakah masih dalam IDE VB6
Public Function IsInIDE() As Boolean
On Error GoTo ErrHandler
Debug.Print 1 / 0
ErrHandler:
IsInIDE = Err
End Function
'------------------------------------------------------------------------------
'Buat tiga file Install.bat, UnInstall.bat, Readme.txt, dan folder ActiveX
'disini saya hanya memperbolehkan/memfilter ocx saja
'------------------------------------------------------------------------------
Public Sub CreateOCXDependencies()
If Not IsInIDE Then Exit Sub
Dim sArray() As String, iCtr As Integer, strMsg As String
GetProcessModules sArray
If Not IsFolderExist(App.Path & "\ActiveX") Then
MkDir App.Path & "\ActiveX"
End If
If IsFileExist(App.Path & "\Install.bat") Then
Kill App.Path & "\Install.bat"
End If
If IsFileExist(App.Path & "\UnInstall.bat") Then
Kill App.Path & "\UnInstall.bat"
End If
Open App.Path & "\Install.bat" For Append As #1
Print #1, "Copy ActiveX\-.- %systemroot%\system32\"
For iCtr = 0 To UBound(sArray)
If InStr(1, LCase(sArray(iCtr)), "ocx") > 0 Then 'just ocx
FileCopy sArray(iCtr), App.Path & "\ActiveX\" & GetFileName(sArray(iCtr))
Print #1, "RegSvr32.exe " & Chr(34) & "%systemroot%\system32\" & GetFileName(sArray(iCtr)) & Chr(34) & " /s"
End If
Next
Print #1, "cmd.exe"
Close #1
Open App.Path & "\UnInstall.bat" For Append As #1
For iCtr = 0 To UBound(sArray)
If InStr(1, LCase(sArray(iCtr)), "ocx") > 0 Then 'just ocx
Print #1, "RegSvr32.exe " & Chr(34) & "%systemroot%\system32\" & GetFileName(sArray(iCtr)) & Chr(34) & " /s /u"
End If
Next
Print #1, "cmd.exe"
Close #1
strMsg = "Sebelum menjalankan project ini, dobel klik file Install.bat terlebih dahulu, untuk meregister komponen-kompenen yang dibutuhkan"
If Not IsFileExist(App.Path & "\Readme.txt") Then
Open App.Path & "\Readme.txt" For Append As #1
Print #1, strMsg
Close #1
End If
End Sub
Private Sub Form_Load()
CreateOCXDependencies 'hanya satu jajar kode saja untuk memanggilnya prosedur di atas
'kode selanjutnya ...
End Sub
