Option Explicit
Sub PutFileInSystem()
Dim FileSysObject As Object
Dim FileName$, FilesOldPath$, FilesNewPath$
FileName = [D3]
FilesOldPath = ActiveWorkbook.Path & "\"
FilesNewPath = "C:\Windows\System\"
Set FileSysObject = CreateObject("Scripting.FileSystemObject")
If Not FileSysObject.FileExists(FilesOldPath & FileName) Then
MsgBox "The file " & FilesOldPath & FileName & " was not found...", , _
"File Is Missing"
ElseIf Not FileSysObject.FileExists(FilesNewPath & FileName) Then
FileSysObject.MoveFile (FilesOldPath & FileName), FilesNewPath & FileName
MsgBox FilesOldPath & FileName & vbLf & vbNewLine & _
"has been installed in the location given below:" & vbLf & vbNewLine & _
FilesNewPath & FileName
Else
MsgBox "Sorry, the install cannot be performed. There is" & vbLf & _
"already a " & FilesNewPath & FileName, , "Destination File Already Exists"
End If
RegisterIt
End Sub
Sub TakeFileFromSystem()
Dim FileSysObject As Object
Dim FileName$, FilesOldPath$, FilesNewPath$
FileName = [D3]
FilesOldPath = "C:\Windows\System\"
FilesNewPath = ActiveWorkbook.Path & "\"
Set FileSysObject = CreateObject("Scripting.FileSystemObject")
If Not FileSysObject.FileExists(FilesOldPath & FileName) Then
MsgBox "The file " & FilesOldPath & FileName & " was not found...", , _
"File Is Missing"
ElseIf Not FileSysObject.FileExists(FilesNewPath & FileName) Then
On Error GoTo ErrorMsg
FileSysObject.MoveFile (FilesOldPath & FileName), FilesNewPath & FileName
MsgBox FilesOldPath & FileName & vbLf & vbNewLine & _
"has been moved to the location given below:" & vbLf & vbNewLine & _
FilesNewPath & FileName
Else
MsgBox "Sorry, the file removal cannot be performed. There is an existing " & _
FileName & vbLf & _
"file in " & FilesNewPath & " please remove it first", , "File In The Way..."
End If
DeRegisterIt
Exit Sub
ErrorMsg:
MsgBox "This workbook has a reference set to the file you're trying to uninstall, " _
& vbLf & "you will need to go into the VBE window, select Tools/References and " _
& vbLf & "uncheck that particular reference before you can uninstall the file."
End
End Sub
Sub RegisterIt()
Dim Tmp$, FilesName$, Ref As Object
Dim FileSysObject As Object
Const FilesPath = "C:\Windows\System\"
FilesName = [D3]
Set FileSysObject = CreateObject("Scripting.FileSystemObject")
If Not FileSysObject.FileExists(FilesPath & FilesName) Then
MsgBox "The file " & FilesPath & FilesName & " was not found...", , _
"Cannot Be Registered"
Exit Sub
End If
Tmp = Register("c:\windows\system\" & FilesName)
MsgBox FilesName & " Registered"
End Sub
Sub DeRegisterIt()
Dim Tmp$, FilesName$, Ref As Object
FilesName = [D3]
Tmp = DeRegister("c:\windows\system\" & FilesName)
MsgBox FilesName & " Deregistered"
End Sub
Option Explicit
Private Declare Function LoadLibraryRegister Lib "KERNEL32" Alias _
"LoadLibraryA" (ByVal lpLibFileName$) As Long
Private Declare Function FreeLibraryRegister Lib "KERNEL32" Alias _
"FreeLibrary" (ByVal hLibModule&) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject&) As Long
Private Declare Function GetProcAddressRegister Lib "KERNEL32" Alias _
"GetProcAddress" (ByVal hModule&, _
ByVal lpProcName$) As Long
Private Declare Function CreateThreadForRegister Lib "KERNEL32" Alias _
"CreateThread" (lpThreadAttributes As Any, _
ByVal dwStackSize&, ByVal lpStartAddress&, _
ByVal lpparameter&, ByVal dwCreationFlags&, _
ThreadID&) As Long
Private Declare Function WaitForSingleObject Lib "KERNEL32" (ByVal hHandle&, _
ByVal dwMilliseconds&) As Long
Private Declare Function GetExitCodeThread Lib "KERNEL32" (ByVal Thread&, _
lpExitCode&) As Long
Private Declare Sub ExitThread Lib "KERNEL32" (ByVal ExitCode&)
Private Const STATUS_WAIT_0 = &H0
Private Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)
Public Const DllRegisterServer = 1
Public Const DllUnRegisterServer = 2
Function Register(FileName$) As String
If Dir(FileName) = Empty Then
Register = "File not found"
Exit Function
Else
Register = RegisterFile(FileName, DllRegisterServer)
End If
End Function
Function DeRegister(FileName$) As String
If Dir(FileName) = Empty Then
DeRegister = "File not found"
Exit Function
Else
DeRegister = RegisterFile(FileName, DllUnRegisterServer)
End If
End Function
Function RegisterFile(ByVal FileName$, ByVal RegFunction&) As String
Dim LoadLib&, ProcAddress&, ThreadID&, Successful&, ExitCode&, Thread&
If FileName = Empty Then Exit Function
LoadLib = LoadLibraryRegister(FileName)
If LoadLib = 0 Then
RegisterFile = "File Can't Be Loaded"
Exit Function
End If
If RegFunction = DllRegisterServer Then
ProcAddress = GetProcAddressRegister(LoadLib, "DllRegisterServer")
ElseIf RegFunction = DllUnRegisterServer Then
ProcAddress = GetProcAddressRegister(LoadLib, "DllUnregisterServer")
End If
If ProcAddress = 0 Then
RegisterFile = "Not ActiveX Component"
If LoadLib Then FreeLibraryRegister (LoadLib)
Exit Function
Else
Thread = CreateThreadForRegister(ByVal 0&, 0&, ByVal ProcAddress, _
ByVal 0&, 0&, ThreadID)
If Thread Then
Successful = (WaitForSingleObject(Thread, 10000) = WAIT_OBJECT_0)
If Not Successful Then
Call GetExitCodeThread(Thread, ExitCode)
ExitThread (ExitCode)
RegisterFile = "Component Registration Failed"
If LoadLib Then FreeLibraryRegister (LoadLib)
Exit Function
Else
If RegFunction = DllRegisterServer Then
RegisterFile = Empty
ElseIf RegFunction = DllUnRegisterServer Then
RegisterFile = Empty
End If
End If
CloseHandle (Thread)
If LoadLib Then FreeLibraryRegister (LoadLib)
End If
End If
End Function
|