Code for sharing multiple copies of a workbook containing code, with the ability to push out updates to users.
Switch branches/tags
Nothing to show
Clone or download
Fetching latest commit…
Cannot retrieve the latest commit at this time.
Permalink
Type Name Latest commit message Commit time
Failed to load latest commit information.
assets
CODE_OF_CONDUCT.md
LICENSE
README.md
versionControl.bas

README.md

VBA Distribution

Allows the ability to to push out updates of Excel macros to multiple users.


Note:

  • To be able to use this the users will need to all have access to a shared drive.

Related Projects

Many of the core functions needed for this code to work are included in the VBA-File-System-Object.

Usage

First, update the constants to work in your environment. IE folderpaths, developer, testers, ECT.

Option Explicit
Option Compare Text


'CHANGE TO SET MACROS TO PRODUCTION (WILL NOT ALLOW UPDATES TO HAPPEN WHILE FALSE)
'[WARNING, DO NOT SEND TO USERS WHILE FALSE, OTHERWISE FORCE UPDATE WILL HAVE TO BE APPLIED.]
Private Const inProduction As Boolean = True

'FOLDER PATHS
Public Const SharedFolderPath = "K:\AA\SHARE\AuditTools\rtmacros\versions\"
Public Const BackupFolderPath = "C:\Backup of my stuff\rtmacros\versions\"
Public Const UsersFolderPath = "C:\rtmacros\"

'FILE NAMES
Public Const WorkbookFileName As String = "RT_Macros.xlsb"
Public Const VersionFileName As String = "version.txt"
Public Const TesterVersionFileName As String = "testerVersion.txt"
Public Const UserLog As String = "UserLog.txt"
Public Const UpdateNotes As String = "README.txt"

'MACRO NAME - QUICK ACCESS TOOLBAR BUTTON (DEFAULT ONLY ONE. WILL NOT ADD IF EMPTY STRING)
Private Const QuickAccessButton As String = "RT_Macros_Box"

'DEVELOPER\TESTER LIST (MUST BE COMMA SEPERATED WITH NO SPACES, CALLED FROM 'isTester()' 'isDeveloper()'
Public Const Developers As String = "rtoda02,LREIC00,MCART49"
Public Const Testers As String = "mcart49,aingr00,elaws07,rtoda02,fsada01"

'USERS VERSION NUMBER [WARNING: FILE NAMES ARE SAVED BASED ON THE TesterVersionNumber]
Public Const VersionNumber As String = "0.0.0"
Public Const TesterVersionNumber As String = "0.0.0"

Then run SaveUpdatedVerion(), and it will create the folders for you. This will be the way to push out updates as well.

'==== NOTES ====================================================================================================================================
'
' THIS MODULE IS USED TO PUSH OUT UPDATES TO USERS. EACH USER HAS THEIR OWN COPY OF THIS WORKBOOK.
'
' ------------------------------------------------------------------------------------------------
' PACKAGE MUST INCLUDE: cFileSystemObject
'=========================================================================================================================================



'==================================================================================
' SAVES THISWORKBOOK VERSION TO SHARED AND BACKUP FOLDERS //(RUN FROM VISUAL BASIC)
'==================================================================================
Private Sub SaveUpdatedVersion()
    
    'DECLARE VARIABLES
    Dim fso As cFileSystemObject
    Dim NotesResult As String
    Dim TextFileResult As VbMsgBoxResult
    
    'INITIAL SET
    Set fso = New cFileSystemObject
    
    ''''''''''''''''''''''''''''''''''''''''''''''''
    'CHECK TO MAKE SURE FOLDERS EXIST
    ''''''''''''''''''''''''''''''''''''''''''''''''
    If fso.FolderExists(BackupFolderPath) And fso.FolderExists(SharedFolderPath) Then
        
        
        'CHECK TO SEE IF USER IS A DEVELOPER
        If IsDeveloper = False Then
            MsgBox "You are currently not a developer. Please add your name to the const 'Developers'", vbCritical
            Exit Sub
        End If
        
        'SAVE THISWORKBOOK (TO INSURE ANY UPDATES ARE APPLIED)
        ThisWorkbook.Save
        
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' SAVE UPDATED FILES SECTION
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        If fso.FileExists(SharedFolderPath & TesterVersionNumber & " " & WorkbookFileName) Then
            If MsgBox("[WARNING FILE EXISTS] Are you sure you would like to overwrite it?", vbYesNo) = vbNo Then
                Exit Sub
            End If
        End If
        
        'SAVE FILE TO SHARED LOCATION - NOTE IT WILL ALWAYS BE SAVED WITH THE TESTER VERSION #
        fso.CopyFile ThisWorkbook.FullName, SharedFolderPath & TesterVersionNumber & " " & WorkbookFileName, True
        
        'SAVE FILE TO BACKUP LOCATION
        fso.CopyFile ThisWorkbook.FullName, BackupFolderPath & TesterVersionNumber & " " & WorkbookFileName, True
        
        'UPDATE VERSION #'S. NOTE: UPDATE VERSION # CONST IN ORDER TO PUSH OUT UPDATES
        fso.WriteToTextFile SharedFolderPath & VersionFileName, VersionNumber
        fso.WriteToTextFile SharedFolderPath & TesterVersionFileName, TesterVersionNumber
        
        
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' ADD NOTES ABOUT THE UPDATE
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        NotesResult = InputBox("Update notes", "Notes")
        NotesResult = "[" & TesterVersionNumber & "] (" & Now & ") " & NotesResult & vbNewLine & fso.ReadTextFile(SharedFolderPath & UpdateNotes)
        fso.WriteToTextFile SharedFolderPath & UpdateNotes, NotesResult
        
        'UPDATES A LOG OF CURRENT
        LogVersionNumber
        
        
        'SUCCESS!!
        Debug.Print "Succefully pushed out updates!"
        
    Else
    
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'FOLDER(S) DO NOT EXIST [ERROR]. OPTIONAL CREATE FOLDERS
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        If MsgBox("[ERROR] Folder(s) do not exist in order to overwrite updated Version. Would you like to create them?", vbYesNo) = vbYes Then
            
            'CREATE FOLDERS
            If fso.CreateFolderPath(BackupFolderPath) = True And fso.CreateFolderPath(SharedFolderPath) = True Then
                
                'SUCCESS RERUN THIS SUB TO ADD FILES
                MsgBox "Folders were succesfully created!", vbInformation
                SaveUpdatedVersion
                
            Else
                MsgBox "[ERROR Creating Folders] for unknown reasons the folders could not be created.", vbCritical
            End If
            
            
        End If
    
    End If
    
End Sub

The Sub that will update each users version will be the CheckForUpdates. Note the: optional forceupdate. Pass true to force updates. You can call this from Workbook events or when other code is executed; such as a userform opening.

'==========================================================================
' CHECKS FOR UPDATES //CALLED FROM Workbook_Open EVENT/RT_MACROS INITIALIZE
'==========================================================================
Public Sub CheckForUpdates(Optional ForceUpdate As Boolean = False)
    
    'DECLARE VARIABLES
    Dim fso As New cFileSystemObject
    Dim WB As Workbook
    Dim WbName As String
    Dim sTesterVersion As String
    Dim sVersion As String
    
    'CHECK TO SEE IF CODE IS READY TO GO INTO PRODUCTION (inProduction IS A CONST)
    If ForceUpdate = False Then
        If inProduction = False Then
            Debug.Print "Currently the 'CheckForUpdates' Macro is turned off. To start updates, set the const inProduction = True "
            Exit Sub
        End If
    End If
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CHECK TO SEE IF THISWORKBOOK IS SAVED IN CORRECT PATH.
    ' (NEEDED FIRST, JUST IN CASE USER OPENS THE VERSION THAT IS SAVED ON THE SHARED DRIVE.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If ThisWorkbook.FullName <> UsersFolderPath & WorkbookFileName Then
        
        'CHECK IF USERS FOLDER EXITS
        If Not fso.FolderExists(UsersFolderPath) Then
            
            'DOES NOT EXIST, CREATE FOLDER PATH
            If fso.CreateFolderPath(UsersFolderPath) = False Then
                
                'UNABLE TO CREATE FOLDER PATH
                MsgBox "[ERROR CREATING FOLDER PATH] '" & UsersFolderPath & "' could not be created.", vbCritical
                Exit Sub
                
            End If
            
        End If
        
        'CHECK TO SEE IF WORKBOOK EXISTS, IF SO IF IT IS OPEN
        If fso.FileExists(UsersFolderPath & WorkbookFileName) Then
            
            'CHECK TO SEE IF WORKBOOK IS ALREADY OPEN
            Set WB = Workbooks(WorkbookFileName)
            If Not WB Is Nothing Then
                Debug.Print "[ERROR] WORKBOOK ALREADY EXISTS AND IS ALREADY OPEN."
                ThisWorkbook.Close False
                Exit Sub
            End If
            
        End If
        
        'SAVE THISWORKBOOK TO USERS PERSONAL FOLDER
        Application.DisplayAlerts = False
        ThisWorkbook.SaveAs UsersFolderPath & WorkbookFileName
        Application.DisplayAlerts = True
    End If
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CHECK IF SHARED FILES EXISTS THAT ARE NEEDED TO UPDATE FROM
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Not fso.FileExists(SharedFolderPath & WorkbookFileName) And Not fso.FileExists(SharedFolderPath & VersionFileName) And Not fso.FileExists(SharedFolderPath & TesterVersionFileName) Then
        
        'FILES DON'T EXIST
        MsgBox "[ERROR UPDATING] UPDATED FILES NOT FOUND, OR USER DOESN'T HAVE ACCESS", vbCritical
        Exit Sub
        
    End If
    
    'INSURE VERSION FILES EXIST (AS WELL AS STORE THE FILE NAMES IN A LOCAL VARIABLE)
    sTesterVersion = SharedFolderPath & fso.ReadTextFile(SharedFolderPath & TesterVersionFileName) & " " & WorkbookFileName
    sVersion = SharedFolderPath & fso.ReadTextFile(SharedFolderPath & VersionFileName) & " " & WorkbookFileName
        
    If Not fso.FileExists(sTesterVersion) Or Not fso.FileExists(sVersion) Then
        Debug.Print "Tried to update. Version File(s) not found."
        Exit Sub
    End If
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'ADD QUICK ACCESS TOOLBAR BUTTON (IF NOT ALREADY THERE). (QuickAccessButton IS A CONST)
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Not QuickAccessButton = "" Then
        QuickAccessToolBarAdd QuickAccessButton, UsersFolderPath & WorkbookFileName
    End If
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CHECK FOR UPDATES FOR TESTERS (THEY HAVE THEIR OWN VERSION #)
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If isTester And fso.ReadTextFile(SharedFolderPath & TesterVersionFileName) <> TesterVersionNumber Then
        ForceUpdate = True
    End If
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CHECK VERSION #'S TO SEE IF THERE ARE ANY UPDATES. (OPTIONAL FORCED UPDATE)
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If fso.ReadTextFile(SharedFolderPath & VersionFileName) <> VersionNumber Or ForceUpdate = True Then
        

        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        'DEVELOPER WARNING (DOUBLE CHECK TO MAKE SURE NOT TO OVERRIDE ANY CHANGES TO CODE.)
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        If IsDeveloper Then
            If MsgBox("[WARNING] You are a developer, would you like to apply updates?", vbYesNo) = vbNo Then
                Exit Sub
            End If
        End If
        
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ' UPDATE SECTION - CHANGES THISWORKBOOK NAME TO ALLOW THE UPDATED VERSION TO BE SAVED
        ' IN ITS ORIGINAL PLACE.
        ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        
        'CHANGE THE NAME OF CURRENT WORKBOOK
        On Error GoTo ErrorSaveAsCatch
        Application.DisplayAlerts = False
        ThisWorkbook.SaveAs UsersFolderPath & "TEMP" & WorkbookFileName, xlReadOnly
        Application.DisplayAlerts = True
        
        
        'COPY UPDATED FILE OVER THE OLD FILE LOCATION
        On Error GoTo ErrorCatch
        If isTester = True Then
            fso.CopyFile sTesterVersion, UsersFolderPath & WorkbookFileName, True
         Else
            fso.CopyFile sVersion, UsersFolderPath & WorkbookFileName, True
        End If
        
        'SHARED TEXT FILE THAT TRACKS USERS VERSION NUMBERS (REMOVE FOR OPEN SOURCE CODE)
        LogVersionNumber
        
        'OPEN THE NEW FILE LOCATION
        Application.EnableEvents = False
        Workbooks.Open UsersFolderPath & WorkbookFileName
        Application.EnableEvents = True
        
        MsgBox "Updates Applied!", vbInformation
        
        
        ''''''''''''''''''''''''''''''''''''''''''''''''''''
        'DELETE THE CURRENT WORKBOOK (OLD TEMP VERSION)
        ''''''''''''''''''''''''''''''''''''''''''''''''''''
        With ThisWorkbook
            .Saved = True
            .ChangeFileAccess xlReadOnly
             Kill .FullName
            .Close False
        End With

    End If
    
    Exit Sub
    
ErrorSaveAsCatch:
    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs UsersFolderPath & WorkbookFileName
    Application.DisplayAlerts = True
    
ErrorCatch:
    
End Sub

QucikAccessToolBarAdd() is a way of adding an icon in the quick access toolbar, that has a macro assigned to it. If it is left blank, then it will skip. This is called from CheckForUpdates().

'==================================================================================
' CREATES A QUICK ACCESS BUTTON FOR A PARTICULAR MACRO. MUST INCLUDE WB FULL NAME.
'==================================================================================
Public Function QuickAccessToolBarAdd(MacroName As String, WorkbookFullName As String) As Boolean
    
    'INITIAL DECLARE
    Dim fso As New cFileSystemObject
    Dim TS As Object
    
    Dim sCode As String
    Dim myInsert As Integer
    
    Dim xlUIFilePath As String
    Dim txtPath As String
    Dim ExcelOfficeUiBackup As String
    Dim S As String
    
    'FILE LOCATIONS
    xlUIFilePath = "C:\Users\" & Environ("username") & "\Local Settings\application data\microsoft\Office\Excel.officeUI"
    txtPath = fso.TempFolder & "\officeUiLinkUpdate.txt"
    ExcelOfficeUiBackup = fso.TempFolder & "\Excel.officeUI"
    
    
    'CHECK TO SEE IF UI FILE IS FOUND
    If fso.FileExists(xlUIFilePath) Then
    
        'COPY UI FILE INTO A TEXT FILE FOR EDITING
        fso.CopyFile xlUIFilePath, txtPath
        
        'CREATE A BACKUP OF THE ORIGINAL -- WILL NOT OVERIDE THE FIRST BACKUP
        If Not fso.FileExists(ExcelOfficeUiBackup) Then
            fso.CopyFile xlUIFilePath, ExcelOfficeUiBackup
        End If
        
        'WRITE UI TEXTFILE INTO STRING
        S = fso.ReadTextFile(txtPath)
        
        'CHECK TO SEE IF QUICK ACCESS BUTTON ALREADY EXISTS
        If S Like "*!" & MacroName & "*" Then
            'MsgBox "Macro already On the list"
        Else
            
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' CREATE XML CODE FOR BUTTON AND ADD TO S VARIABLE
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            
            'CREATE XML CODE
            sCode = Replace("x1:" & WorkbookFullName & "!" & MacroName & "_1", "\", "_")
            sCode = "<mso:button idQ=""" & sCode & """ visible=""true"" label=""" & MacroName & """ imageMso=""Info"" onAction=""" & WorkbookFullName & "!" & MacroName & """/>"
            
            'LOCATION WHERE TO ADD HML
            myInsert = InStr(S, "</mso:sharedControls></mso:qat>")
            
            'INSERT CODE INTO HML (END OF THE ACCESS BUTTONS)
            S = Left(S, myInsert - 1) & sCode & Mid(S, myInsert)
            
            
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            'REWRITE UI TEXTFILE USING THE NEW STRING, UPDATE FILE
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            Set TS = fso.OpenTextFile(txtPath, ForWriting)
            TS.write S
            
            'REPLACE OFFICE UI FILE WITH NEW ONE
            fso.CopyFile txtPath, xlUIFilePath
            
        End If
        

    Else
        
        'UI FILE WAS NOT FOUND
        MsgBox "[ERROR FINDING EXCEL UI FILE] Used to update quick access toolbar.", vbCritical
        
    End If
        

End Function

Additional Functions that can be added to log user version numbers, check for developers\testers.

'==============================================================================
' LOG TO KEEP TRACK OF WHAT VERSION NUMBERS USERS HAVE
'==============================================================================
Public Function LogVersionNumber() As Boolean

    Dim fso As New cFileSystemObject

    On Error GoTo ErrorCatch
    
    If fso.CreateFolderPath(SharedFolderPath & UserLog) = False Then GoTo ErrorCatch
    
    If isTester = True Then
        fso.KeyValueWrite SharedFolderPath & UserLog, Environ("Username"), "[" & fso.ReadTextFile(SharedFolderPath & TesterVersionFileName) & "]-(" & Now & ")"
    Else
        fso.KeyValueWrite SharedFolderPath & UserLog, Environ("Username"), "[" & fso.ReadTextFile(SharedFolderPath & VersionFileName) & "]-(" & Now & ")"
    End If
    
    LogVersionNumber = True
    
    Exit Function
ErrorCatch:
    Debug.Print "[ERROR IN LOG VERSION NUMBER]"

End Function

'======================================================================
' RETURN TRUE IF THE COMPUTER NAME IS STORED IN THE CONSTANT 'Testers'
'======================================================================
Public Function isTester() As Boolean
    
    'INITIAL DECLARE
    Dim CurrentUser As String
    Dim TesterList As Variant
    Dim I As Integer
    
    'INITIAL SET
    On Error GoTo CatchError
    CurrentUser = Environ("Username")
    TesterList = Split(Testers, ",")
    
    'LOOP ARRAY LOOKING FOR MATCH
    For I = LBound(TesterList, 1) To UBound(TesterList, 1)
        
        If TesterList(I) = CurrentUser Then
            isTester = True
            Exit Function
        End If
        
    Next I
    
    'ERROR HANDLING
CatchError:

End Function

'========================================================================
' RETURN TRUE IF THE COMPUTER NAME IS STORED IN THE CONSTANT 'Developers'
'========================================================================
Public Function IsDeveloper() As Boolean
    
    'INITIAL DECLARE
    Dim CurrentUser As String
    Dim DeveloperList As Variant
    Dim I As Integer
    
    'INITIAL SET
    On Error GoTo CatchError
    CurrentUser = Environ("Username")
    DeveloperList = Split(Developers, ",")
    
    'LOOP ARRAY LOOKING FOR MATCH
    For I = LBound(DeveloperList, 1) To UBound(DeveloperList, 1)
        
        If DeveloperList(I) = CurrentUser Then
            IsDeveloper = True
            Exit Function
        End If
        
    Next I
    
    'ERROR HANDLING
CatchError:

End Function



<!---"Comment" <p align="center">
<p align="center">
  <img alt="VS Code in action" src="https://cloud.githubusercontent.com/assets/11839736/16642200/6624dde0-43bd-11e6-8595-c81885ba0dc2.png">
</p>
--->