VB and VBA Users Source Code: Upgrading the VBA code in an Excel Workbook
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Upgrading the VBA code in an Excel Workbook
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Tuesday, March 27, 2001
Hits:
1065
Category:
Unspecified
Article:
The following code upgrades the VBA code in one Workbook using the code in another workbook: Option Explicit 'API to get the temporary directory Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long 'Purpose : Upgrades the code in a specified workbook using the code in another workbook 'Inputs : oWorkbookToUpgrade The workbook to upgrade. ' oWorkbookNewCode The workbook containing the new upgrade code. ' [sBackupDirectory] The name of the path to store a backup of the original code in. 'Outputs : Returns "SUCCESS" if succeeded, else returns the error description. 'Author : Andrew Baker 'Date : 03/05/2001 13:50 'Notes : You must open the workbooks before calling this routine. ' The routine will not work if either of the projects are locked/protected. ' The routine will not upgrade code in the workbook containing this routine. 'Revisions : Function WorkbookUpgradeVBA(oWorkbookToUpgrade As Excel.Workbook, oWorkbookNewCode As Excel.Workbook, Optional sBackupDirectory As String) As String Dim oNewCodeModule As Object, sNewCode As String, lNewNumLines As Long Dim sModuleName As String, lOldNumLines As Long, bComponentExists As Boolean Dim oOldCodeModule As Object On Error GoTo ErrFailed If Len(sBackupDirectory) = 0 Then 'Use the temp directory to backup code sBackupDirectory = DirTemp ElseIf Right$(sBackupDirectory, 1) <> "\" Then sBackupDirectory = sBackupDirectory & "\" End If For Each oNewCodeModule In oWorkbookNewCode.VBProject.VBComponents 'Get data from new workbook lNewNumLines = oNewCodeModule.CodeModule.CountOfLines sModuleName = oNewCodeModule.CodeModule.Name sNewCode = oNewCodeModule.CodeModule.Lines(1, lNewNumLines) 'Determine if component exists in old project bComponentExists = False On Error Resume Next bComponentExists = Len(oWorkbookToUpgrade.VBProject.VBComponents(sModuleName).Name) > 0 On Error GoTo ErrFailed If bComponentExists Then Set oOldCodeModule = oWorkbookToUpgrade.VBProject.VBComponents(sModuleName).CodeModule End If If Len(Dir$(sBackupDirectory & sModuleName & ".bak")) Then 'Delete existing backup file VBA.Kill sBackupDirectory & sModuleName & ".bak" End If If Len(Dir$(sBackupDirectory & sModuleName & ".new")) Then 'Delete existing temp file VBA.Kill sBackupDirectory & sModuleName & ".new" End If If oNewCodeModule.Type <= 3 Then 'Component is either 1=Standard,2=Class or 3=Dialog 'Export new component to file oNewCodeModule.Export sBackupDirectory & sModuleName & ".new" If bComponentExists = True Then 'Remove the existing component oWorkbookToUpgrade.VBProject.VBComponents.Remove oOldCodeModule.Parent End If 'Import the new component oWorkbookToUpgrade.VBProject.VBComponents.Import sBackupDirectory & sModuleName & ".new" Else 'Thisworkbook code 'Delete old code lOldNumLines = oOldCodeModule.CountOfLines If Len(sBackupDirectory) > 0 And lOldNumLines > 0 Then 'Backup original code If Len(Dir$(sBackupDirectory & sModuleName & ".bak")) Then 'Delete existing backup VBA.Kill sBackupDirectory & sModuleName & ".bak" End If oOldCodeModule.Parent.Export sBackupDirectory & sModuleName & ".bak" End If If lOldNumLines Then 'Delete original code oOldCodeModule.DeleteLines 1, lOldNumLines End If 'Add new code oOldCodeModule.InsertLines 1, sNewCode End If Next Set oOldCodeModule = Nothing 'Succeeded WorkbookUpgradeVBA = "SUCCESS" Exit Function ErrFailed: 'Failed WorkbookUpgradeVBA = Err.Description Debug.Print "Error: " & WorkbookUpgradeVBA Debug.Assert False Exit Function Resume End Function 'Purpose : Returns the path of the temporary directory 'Inputs : N/A 'Outputs : The temporary path name 'Author : Andrew Baker 'Date : 13/01/2001 21:00 'Notes : Can use Environ("Temp") as an alternative to the API call on NT machines 'Revisions : Function DirTemp() As String Dim lLenTemp As Long Static ssTempDir As String If Len(ssTempDir) = 0 Then lLenTemp = 150 ssTempDir = String$(lLenTemp, Chr$(0)) 'Get the username lLenTemp = GetTempPath(lLenTemp, ssTempDir) 'strip the rest of the buffer ssTempDir = Left$(ssTempDir, lLenTemp) If Right$(ssTempDir, 1) <> "\" Then ssTempDir = ssTempDir & "\" End If End If DirTemp = ssTempDir End Function 'Demonstration routine Sub Test() 'Open the workbook containing the new code Workbooks.Open "C:\Book2.xls" 'Open the workbook containing the code to upgrade Workbooks.Open "C:\Book3.xls" 'Upgrade the workbooks Debug.Print WorkbookUpgradeVBA(Workbooks("Book3.xls"), Workbooks("Book2.xls"), "C:\Temp\") 'Save and close the upgraded workbook Workbooks("Book3.xls").Close True 'Close the original workbook Workbooks("Book2.xls").Close False End Sub
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
