VBS to register macros

From MetaSharp
Jump to: navigation, search

Article Author(s): Audric Thevenet
All Rights Reserved.

Download the Excel Addin Registerer

We often need to register a macro in excel. I made a VBS script to do it. In order to run it, you need to have process.exe file in order to kill clean and fast processes (provided in the zip file). I chose this one because the SysInternals pskill.exe is detected as a malware by some crappy antivirus like McAfee.

You should have for example 5 files: 

foo1.xla
foo2.xla
install.cmd
process.exe
regaddins.vbs

The install.cmd should look like this: 

@echo off
cscript //nologo regmacro.vbs foo1.xla foo2.xla
pause

This will unregister both addins if presents, then register them in the order you pass them to the vbs script. If foo1.xla was relying on foo2.xla, you should have done: 

cscript //nologo regmacro.vbs foo2.xla foo1.xla

Here's the VBS file (regaddins.vbs) that you can use in order to register a macro file (xla or xll) in excel. Additionnaly, it will clean older versions of the macros file from registry and hard drive: 

'------------------------------------------------------------------------------
' XLA/XLL ADDIN FILES REGISTERER
' MetaSharp.NET - Audric Thevenet
'------------------------------------------------------------------------------
Option Explicit

'------------------------------------------------------------------------------
' MAIN
'------------------------------------------------------------------------------
Dim args               ' command line arguments
Dim fso                ' global FileSystem Object
Dim shell              ' global Shell Object
Dim macroFile          ' target macro file
Dim macroFileName      ' target macro filename, ex: foo.xla
Dim macroFilePath      ' target macro filepath, ex: c:\foo.xla
Dim macrosLibDirectory ' C:\Program Files\Microsoft Office\Office10\Macrolib\ 

Set fso = CreateObject("Scripting.FileSystemObject")
Set shell = CreateObject("WScript.Shell")

' quit if no argument provided
Set args = WScript.Arguments
If args.Count = 0 Then
	Wscript.Echo("Syntax: cscript installmacro.vbs c:\file1.xla file2.xla")
	WScript.Quit
End If

' NEVER CREATE A VBS EXCEL OBJECT BEFORE THIS !!!
Call ShutdownExcel()

macrosLibDirectory = GetMacrosLibDirectory()

' uninstall addins
Dim key

' clean the add-in manager key
key = GetExcelAddinManagerKey()
On Error Resume Next
Call shell.RegDelete(key & "\")
On Error Resume Next
Call shell.RegWrite(key & "\", , "REG_SZ")

Dim macroLibGhost
Dim i
i = 0
While i < args.Count
	On Error Resume Next
	macroFile = fso.GetFile(args(i))
	If IsEmpty(macroFile) Then
		WScript.Echo("[" & args(i) & "] file not found! uninstall skipped")
	Else
		macroFileName = fso.GetFileName(macroFile)
		macroFilePath = fso.GetAbsolutePathName(macroFile)
		
		' clean the registry from previous occurences of the macro
		Call UnregisterAndCleanAddin(macroFileName, macroFilePath)
		' we delete eventual old macro lib ghosts of our macro
		macroLibGhost = fso.GetAbsolutePathName(fso.BuildPath(macrosLibDirectory, macroFileName))
		If fso.FileExists(macroLibGhost) Then
			If macroLibGhost <> macroFilePath Then
				WScript.Echo("[" & args(i) & "] delete " + macroLibGhost)
				Call fso.DeleteFile(macroLibGhost, True)
			End If
		End If
	End If
	i = i + 1
Wend

' install addins
i = 0
While i < args.Count
	' get the target file infos
	On Error Resume Next
	macroFile = fso.GetFile(args(i))
	If IsEmpty(macroFile) Then
		WScript.Echo("[" & args(i) & "] file not found! install skipped")
	Else
		macroFileName = fso.GetFileName(macroFile)
		macroFilePath = fso.GetAbsolutePathName(macroFile)
		'register the macro in the clean registry
		Call RegisterAddin(macroFileName, macroFilePath)
	End If
	i = i + 1
Wend

'------------------------------------------------------------------------------
' SHUTDOWN EXCEL IF IT IS RUNNING
'------------------------------------------------------------------------------
Private Sub ShutdownExcel()
	Dim excel

	On Error Resume Next
	Set excel = GetObject(, "Excel.Application")
	' if excel is running
	If Not IsEmpty(excel) Then
		Dim ret
		ret = MsgBox("Kill Excel? No will cancel the installation.", 308, "WARNING")
		If ret = vbNo Then
			Exit Sub
		End If
		' kill excel
		shell.Exec("process.exe -k excel.exe")
		WScript.Sleep(2000)
	End If
End Sub

'------------------------------------------------------------------------------
' GET EXCEL MACROLIB DIRECTORY
'------------------------------------------------------------------------------
Private Function GetMacrosLibDirectory()
	Dim excel
	Set excel = CreateObject("Excel.Application")
	GetMacrosLibDirectory = excel.LibraryPath & "\"
	excel.Quit
	Set excel = Nothing
End Function

'------------------------------------------------------------------------------
' UNREGISTER AND DELETE OLD OCCURENCES OF THE ADDIN
'------------------------------------------------------------------------------
Private Sub UnregisterAndCleanAddin(name, path)
	Dim key      ' registry key
	Dim i        ' iteration counter
	Dim filename ' file name from registry
	Dim filepath ' file path from registry

	' get the correct registry key to inspect
	key = GetExcelOpenKey()
	On Error Resume Next
	' read the filepath from the registry
	filepath = shell.RegRead(key)
	If Err <> 0 Then
		Err.Clear
		Exit Sub
	End If
	filepath = CustomTrim(filepath, Chr(34))
	filename = fso.GetFileName(filepath)
	' if the registry key is our macro
	If LCase(filename) = LCase(name) Then
		WScript.Echo("[" & name & "] macro already registered")
		' if we have old copies elsewhere, we delete them
		If LCase(filepath) <> LCase(path) Then
			WScript.Echo("delete " & filepath)
			Call fso.DeleteFile(filepath, True)
		End If
		' and anyway we delete the registry key
		WScript.Echo("unregister " & filepath)
		Call shell.RegWrite(key, "")
	End If 
	' else, we look for it
	i = 1
	Do
		On Error Resume Next
		filepath = shell.RegRead(key & i)
		If Err = 0 Then
			filepath = CustomTrim(filepath, Chr(34))
			filename = fso.GetFileName(filepath)
			' if the registry key is our macro
			If LCase(filename) = LCase(name) Then
				WScript.Echo("[" & name & "] macro already registered")
				' if we have old copies elsewhere, we delete them
				If LCase(filepath) <> LCase(path) Then
					WScript.Echo("[" & name & "] delete macro: " & filepath)
					Call fso.DeleteFile(filepath, True)
				End If
				' and anyway we delete the registry key
				WScript.Echo("[" & name & "] unregister macro: " & filepath)
				Call shell.RegWrite(key & i, "")
			End If 
		End If
		i = i + 1
	Loop While (i < 100) Or (Err = 0)
	Err.Clear
End Sub

'------------------------------------------------------------------------------
' REGISTER THE ADDIN IN THE REGISTRY
'------------------------------------------------------------------------------
Private Sub RegisterAddin(name, path)
	Dim key    ' registry key

	' get the key number to assign
	key = GetExcelOpenKey()
	If GetOpenFreeSlotNumber() <> 0 Then
		key = key & GetOpenFreeSlotNumber()
	End If
	If UCase(Right(path, 1)) = "L" Then
		' XLL installation
		WScript.Echo("[" & name & "] register the XLL: " & path)
		Call shell.RegWrite(key, "/R " & """" & path & """")
	Else
		' XLA installation
		WScript.Echo("[" & name & "] register the XLA: " & path)
		Call shell.RegWrite(key, """" & path & """")
	End If
End Sub

'------------------------------------------------------------------------------
' GET THE NEXT FREE NUMBER TO ASSIGN TO OPEN KEY
'------------------------------------------------------------------------------
Private Function GetOpenFreeSlotNumber()
	Dim key    ' registry key
	Dim i      ' iteration counter
	Dim val    ' registry value

	' open the registry key
	key = GetExcelOpenKey()
	On Error Resume Next
	val = shell.RegRead(key)
	If Err <> 0 Then
		' if there is no key, we assign 0 as being the first open slot
		GetOpenFreeSlotNumber = 0
		Err.Clear
	Exit Function
	Else
		' else, we assign the number of the first free slot encountered
		i = 1
		Do
			val = shell.RegRead(key & i)
			If val = "" Then
				GetOpenFreeSlotNumber = i
				Exit Function
			End If
			If Err = 0 Then
				i = i + 1
			End If
		Loop While Err = 0
		Err.Clear
		GetOpenFreeSlotNumber = i
	End If
End Function

'------------------------------------------------------------------------------
' GET THE EXCEL REGISTRY KEY STORING ADD-IN MANAGER
'------------------------------------------------------------------------------
Private Function GetExcelAddinManagerKey()
	Dim excel
	Set excel = CreateObject("excel.application")
	' depending on the version of excel we get the appropriate registry key
	Select Case Eval(excel.Version)
		Case 8
			GetExcelAddinManagerKey = "HKCU\Software\Microsoft\Office\8.0\Excel\Microsoft Excel\Add-in Manager"
		Case 9
			GetExcelAddinManagerKey = "HKCU\Software\Microsoft\Office\9.0\Excel\Add-in Manager"
		Case 10
			GetExcelAddinManagerKey = "HKCU\Software\Microsoft\Office\10.0\Excel\Add-in Manager"
		Case 11
			GetExcelAddinManagerKey = "HKCU\Software\Microsoft\Office\11.0\Excel\Add-in Manager"
		Case 12
			GetExcelAddinManagerKey = "HKCU\Software\Microsoft\Office\12.0\Excel\Add-in Manager"
		Case 13
			GetExcelAddinManagerKey = "HKCU\Software\Microsoft\Office\13.0\Excel\Add-in Manager"
		Case Else
			GetExcelAddinManagerKey = ""
	End Select
	excel.Quit
	Set excel = Nothing
End Function

'------------------------------------------------------------------------------
' GET THE EXCEL REGISTRY KEY STORING REGISTERED MACROS
'------------------------------------------------------------------------------
Private Function GetExcelOpenKey()
	Dim excel
	Set excel = CreateObject("excel.application")
	' depending on the version of excel we get the appropriate registry key
	Select Case Eval(excel.Version)
		Case 8
			GetExcelOpenKey = "HKCU\Software\Microsoft\Office\8.0\Excel\Microsoft Excel\OPEN"
		Case 9
			GetExcelOpenKey = "HKCU\Software\Microsoft\Office\9.0\Excel\Options\OPEN"
		Case 10
			GetExcelOpenKey = "HKCU\Software\Microsoft\Office\10.0\Excel\Options\OPEN"
		Case 11
			GetExcelOpenKey = "HKCU\Software\Microsoft\Office\11.0\Excel\Options\OPEN"
		Case 12
			GetExcelOpenKey = "HKCU\Software\Microsoft\Office\12.0\Excel\Options\OPEN"
		Case 13
			GetExcelOpenKey = "HKCU\Software\Microsoft\Office\13.0\Excel\Options\OPEN"
		Case Else
			GetExcelOpenKey = ""
	End Select
	excel.Quit
	Set excel = Nothing
End Function

'------------------------------------------------------------------------------
' TRIM toRemove FROM START AND END OF stringToClean
'------------------------------------------------------------------------------
Private Function CustomTrim(stringToClean, toRemove)
	While Mid(stringToClean, 1, Len(toRemove)) = toRemove
		stringToClean = Mid(stringToClean, Len(toRemove) + 1, Len(stringToClean) - Len(toRemove))
	Wend
	While Mid(stringToClean, Len(stringToClean) - Len(toRemove) + 1, Len(toRemove)) = toRemove
		stringToClean = Mid(stringToClean, 1, Len(stringToClean) - Len(toRemove))
	Wend
	CustomTrim = stringToClean
End Function
Retrieved from "http://www.metasharp.net/index.php/VBS_to_register_macros"
Personal tools