END GAME：用户保存的工作簿打开并镜像目标文件中的代码。更新多个工作簿中的VBA
我想创建一个简单的VBA应用程序，它具有Excel前端和Access后端。将有多个用户可以选择将他们想要的前端Excel片段保存起来。
我想知道当我需要推送更新时，能够在所有用户实例中更新宏的最有效方法。
本质上，我想从一个“全局”文件镜像代码Workbook_open。在过去，我确实设置了代码来打开一个单独的工作簿并运行代码（dim x as workbook,open,app.runmacro等），但我认为这不是最有效的方法。
四种可能的解决方案突然想到了这一点（比你有一个中介的工作簿的选项等），也有可能别人：
请注意，这些都是“拉”式，而不是“推”型解决方案，但最后一个例外。无论您用于版本检查的方法如何，任何推送解决方案都将分享4号码的缺点 - 没有可靠的方法来确保推送捕获所有无效版本。
真棒和及时的反馈。我有一些想法来做这个......作为一个新手编码员，他拿起了一个“副项目”，以摆脱一个巨大的共享电子表格，我可能会徘徊危险地接近为自己创造另一个全职工作:)干杯。 – JeremyBlack
以下是向用户推送更新的方式;要使用此方法，所有用户都需要访问本地共享驱动器。
'SAVE THIS TO A STANDARD MODULE
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 = False
'FOLDER PATHS (MUST UPDATE!)
Private Const SharedFolderPath As String = "S:\SharedFolder\"
Private Const BackupFolderPath As String = "C:\BackupFolder\"
Private Const UsersFolderPath As String = "C:\UsersFolder\"
'FILE NAMES
Private Const WorkbookFileName As String = "test.xlsb"
Private Const VersionFileName As String = "version.txt"
Private Const TesterVersionFileName As String = "testerVersion.txt"
Private Const UpdateNotes As String = "README.txt"
Private Const UserLog As String = "UserLog.txt"
'DEVELOPER\TESTER LIST (MUST BE COMMA SEPERATED WITH NO SPACES, CALLED FROM 'isTester()' 'isDeveloper()'
Public Const Developers As String = "yourcomputername"
Public Const Testers As String = "computuername,testuser2,testuser3,testuser4"
'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"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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
'========================================================================
' CHECKS FOR UPDATES //CALLED FROM Workbook_Open EVENT
'
' PACKAGE INCLUDES: LogVersionNumber(DELETE IF USING IN ANOTHER WORKBOOK)
'========================================================================
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
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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
'==============================================================================
' 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
以下是需要运行各种文件系统例程的类模块。
'SAVE THIS TO A CLASS MODULE, NAME IT: cFileSystemObject
Option Explicit
Option Compare Text
Private pFSO As Object
Private pTS As Object
Public Enum IOMode
ForReading = 1
ForWriting = 2
ForAppending = 8
End Enum
'INITIALIZE EVENT
Private Sub Class_Initialize()
Set pFSO = CreateObject("Scripting.FileSystemObject")
End Sub
'====================================================================
' retrive a value of a key property
'====================================================================
Public Function KeyValueRead(TextFilePath As String, Key As String, Optional ValueIfNull As String) As String
'DECLARE VARIABLES
Dim OpenTag As Integer
Dim CloseTag As Integer
Dim BreakTag As Integer
Dim s As Variant
Dim I As Integer
'INITIAL SET
On Error GoTo catchNotFound
s = Split(ReadTextFile(TextFilePath), vbNewLine)
For I = LBound(s, 1) To UBound(s, 1)
'CHECK TO SEE IF KEY MATCHS LINES KEYVALUE
OpenTag = InStr(s(I), """")
CloseTag = InStr(OpenTag + 1, s(I), """")
If Mid(s(I), OpenTag + 1, (CloseTag - OpenTag) - 1) = Key Then
'GET THE KEYS NAME\VALUE PAIR
BreakTag = InStr(s(I), ":")
OpenTag = InStr(BreakTag, s(I), """")
CloseTag = InStr(OpenTag + 1, s(I), """")
KeyValueRead = Mid(s(I), OpenTag + 1, (CloseTag - OpenTag) - 1)
Exit For
End If
Next I
If KeyValueRead = "" Then
KeyValueRead = ValueIfNull
End If
catchNotFound:
End Function
'====================================================================
' Write TO File using KEY:VALUE method
'====================================================================
Public Function KeyValueWrite(TextFilePath As String, Key As String, Value As String) As Boolean
'DECLARE VARIABLES
Dim OpenTag As Integer
Dim CloseTag As Integer
Dim BreakTag As Integer
Dim s As String
Dim Arr As Variant
Dim I As Long
Dim Found As Boolean
'INITIAL SET
If FileExists(TextFilePath) = False Then
If CreateFolderPath(TextFilePath) = False Then
Exit Function
End If
End If
Arr = Split(ReadTextFile(TextFilePath), vbNewLine)
For I = LBound(Arr, 1) To UBound(Arr, 1)
If Trim(Arr(I)) = "" Then GoTo nxt
'CHECK TO SEE IF KEY MATCHS LINES KEYVALUE
s = Arr(I)
OpenTag = InStr(s, """")
CloseTag = InStr(OpenTag + 1, s, """")
'UPDATE VALUE IF IT IS FOUND
If Mid(s, OpenTag + 1, (CloseTag - OpenTag) - 1) = Key Then
s = """" & Key & """" & ":" & """" & Value & """"
Arr(I) = s
Found = True
End If
nxt:
Next I
'IF IT WAS NOT FOUND, ADD RECORD TO THE END OF THE ARRAY
If Found = False Then
ReDim Preserve Arr(UBound(Arr, 1) + 1)
Arr(UBound(Arr, 1)) = """" & Key & """" & ":" & """" & Value & """"
End If
'REWRITE ARRAY TO TEXTFILE
WriteToTextFile TextFilePath, Join(Arr, vbNewLine)
End Function
'================================================
' READS TEXT FILE INTO A STRING, USING FILE PATH.
' PRIMARILY USED FOR SQL CONNECTIONS MODULE.
'================================================
Public Function ReadTextFile(filename As String) As String
On Error Resume Next
Set pTS = OpenTextFile(filename, ForReading, True)
ReadTextFile = pTS.ReadAll
Set pTS = Nothing
End Function
'================================================
' WRITES TEXT FILE INTO A STRING, USING FILE PATH.
' PRIMARILY USED FOR SQL CONNECTIONS MODULE.
'================================================
Public Function WriteToTextFile(filename As String, Text As String) As Boolean
Set pTS = OpenTextFile(filename, 2, True)
pTS.write (Text)
Set pTS = Nothing
WriteToTextFile = True
End Function
'=====================================================
' CREATES A FILE PATH - IF TEXT FILE WILL CREATE FILE
'=====================================================
Public Function CreateFolderPath(FullPath As String) As Boolean
Dim fso As New cFileSystemObject
Dim I As Integer
Dim sPath() As String
Dim CurPath As String
On Error GoTo Catch
sPath = Split(FullPath, "\")
For I = LBound(sPath, 1) To UBound(sPath, 1) - 1
CurPath = CurPath & sPath(I) & "\"
If Not FolderExists(CurPath) Then
Debug.Print "Created folder path:" & sPath(I)
CreateFolder CurPath
End If
Next I
CreateFolderPath = True
Exit Function
Catch:
CreateFolderPath = False
End Function
'=====================================================
' RETURNS TEMP FOLDER LOCATION
'=====================================================
Public Function TempFolder() As String
TempFolder = Environ("TEMP")
End Function
'BUILT IN FUNCTIONS
Public Function OpenTextFile(filename As String, Optional IOMode As IOMode = ForReading, Optional Create As Boolean = True) As Object
Set OpenTextFile = pFSO.OpenTextFile(filename, IOMode, Create)
End Function
Public Function CreateTextFile(filename As String, Optional Overwrite As Boolean = True) As Object
Set CreateTextFile = pFSO.CreateTextFile(filename, Overwrite)
End Function
Public Function FileExists(FileSpec As String) As Boolean
FileExists = pFSO.FileExists(FileSpec)
End Function
Public Function FolderExists(FileSpec As String) As Boolean
FolderExists = pFSO.FolderExists(FileSpec)
End Function
Public Function CreateFolder(foldername As String) As String
CreateFolder = pFSO.CreateFolder(foldername)
End Function
Public Function GetFolder(FolderPath As String) As Object
Set GetFolder = pFSO.GetFolder(FolderPath)
End Function
Public Function GetFile(FilePath As String) As Object
Set GetFolder = pFSO.GetFile(FilePath)
End Function
Public Function GetDrive(DriveSpec As String) As Object
Set GetDrive = pFSO.GetDrive(DriveSpec)
End Function
Public Function GetDriveName(Path As String) As String
GetDriveName = pFSO.GetDriveName(Path)
End Function
Public Function GetExtensionName(Path As String) As String
GetExtensionName = pFSO.GetExtensionName(Path)
End Function
Public Function GetBaseName(Path As String) As String
GetBaseName = pFSO.GetBaseName(Path)
End Function
Public Function GetAbsolutePathName(Path As String) As String
GetAbsolutePathName = pFSO.GetAbsolutePathName(Path)
End Function
Public Function GetFileVersion(filename As String) As String
GetFileVersion = pFSO.GetFileVersion(filename)
End Function
Public Function GetParentFolderName(Path As String) As String
GetParentFolderName = pFSO.GetParentFolderName(Path)
End Function
Public Function DriveExists(DrivSpec As String) As Boolean
DriveExists = pFSO.DriveExists(DrivSpec)
End Function
Public Function BuildPath(Path As String, Name As String) As String
BuildPath = pFSO.BuildPath(Path, Name)
End Function
'METHODS
Public Sub DeleteFile(FileSpec As String, Optional Force As Boolean = False)
pFSO.DeleteFile FileSpec, Force
End Sub
Public Sub DeleteFolder(FolderSpec As String, Optional Force As Boolean = False)
pFSO.DeleteFile FolderSpec, Force
End Sub
Public Sub MoveFile(Source As String, Destination As String)
pFSO.MoveFile Source, Destination
End Sub
Public Sub MoveFolder(Source As String, Destination As String)
pFSO.MoveFolder Source, Destination
End Sub
Public Sub CopyFolder(Source As String, Destination As String, Optional OverWriteFiles As Boolean = True)
pFSO.CopyFolder Source, Destination, OverWriteFiles
End Sub
Public Sub CopyFile(Source As String, Destination As String, Optional OverWriteFiles As Boolean = True)
pFSO.CopyFile Source, Destination, OverWriteFiles
End Sub
工作簿中的代码是否必须从Excel运行？ Excel代码是做什么的？ – Comintern
Excel代码与访问数据库进行交易。使用DAO对象来提取数据，并允许用户编辑访问记录。它具有公共变量，私有子例程以及双击，激活，更新pivot事件的一些格式化内容。 – JeremyBlack