Excel VBA从中央服务器获取命令的最佳方法

Question

我确信之前已经问过这样的事情，但我想我没有找到合适的关键字，因为我找不到一个好的答案。

我创建了一个由我的整个团队使用的Excel加载项。我将最新版本保留在网络驱动器上，每当有人重新打开Excel时，加载项会检查是否有新版本并自动更新。

我想要做的是能够单独向加载项发送命令以执行。例如，如果我有一个重要的推送更新，而不是等待每个用户重新打开Excel，我希望能够在网络驱动器上以文本文件保存命令（即“USER：ALL;命令：UPDATE“）并且每个用户的加载项将自动获取该命令并在合理的时间范围内处理它。

我的问题是完成此操作的最佳方法是什么？我可以想到两个解决方案，我不喜欢它。

潜在解决方案＃1 - 在“Worksheet_Calculate”或类似地方，让它检查新命令并处理它找到的任何命令。然而，这似乎有点矫枉过正，可能会经常检查。

潜在解决方案＃2 - 使用无限链的Application.OnTime调用，以便每隔X秒/分钟检查新的中央命令，并处理它找到的任何内容。但是我发现Application.OnTime很时髦且不可靠。

有什么想法吗？我觉得做一个班级的事情是要走的路，但我没有太多的经验。

谢谢！

Answer 1

好的，我最终选择了潜在的解决方案＃1。

ThisWorkbook中的代码

Private Sub Workbook_SheetCalculate(ByVal Sh As Object)

    If mdtLastCheck = 0 Or DateDiff("s", mdtLastCheck, Now) > miCHECK_FREQUENCY_SECONDS Then
        mdtLastCheck = Now

        CheckForCommandsAndRun

    End If

End Sub

MCentralCommands中的代码 请注意，此模块中对其他模块的唯一引用是对几个全局变量，如gsAPP_MASTER_PATH。此代码使用本书中的MErrorHandler系统：Professional Excel Development。

Option Explicit

' Description:  This module contains
'
Private Const msModule As String = "MCentralCommands"

Private Const msCOMMANDS_FOLDER As String = "Commands\"
Private Const msCOMMAND_NAME_FORUSER As String = "CMD_USERNAME_*"
Private Const msCOMMAND_NAME_FORALL As String = "CMD_ALL_*"

Public Const miCHECK_FREQUENCY_SECONDS = 10
Public mdtLastCheck As Date


Sub CheckForCommandsAndRun()

' *********************************************
' Entry-Point Procedure Code Start
' *********************************************
    Const sSource As String = "CheckForCommandsAndRun"
    On Error GoTo ErrorHandler
' *********************************************
' *********************************************

    Dim sCommands() As String
    If Not bGetNewCommands(sCommands) Then Err.Raise glHANDLED_ERROR
    If Not bProcessAllCommands(sCommands) Then Err.Raise glHANDLED_ERROR

' *********************************************
' Entry-Point Procedure Code Exits
' *********************************************
ErrorExit:
    Exit Sub

ErrorHandler:
    If bCentralErrorHandler(msModule, sSource, , True) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If

End Sub
Private Function bGetNewCommands(sCommands() As String) As Boolean

' *********************************************
' **** Function Code Start
' *********************************************
    Dim bReturn As Boolean
    Const sSource As String = "bGetNewCommands()"

    On Error GoTo ErrorHandler
    bReturn = True
' *********************************************
' *********************************************

    Dim sCommandPath As String, sUser As String
    sCommandPath = gsAPP_MASTER_PATH & msCOMMANDS_FOLDER
    sUser = UCase(Application.UserName)

    Dim iCommandCount As Integer

    Dim vFile As Variant
    vFile = Dir(sCommandPath)
    While (vFile <> "")
        If vFile Like msCOMMAND_NAME_FORALL Or _
           vFile Like Replace(msCOMMAND_NAME_FORUSER, "USERNAME", sUser) Then _

            ReDim Preserve sCommands(0 To iCommandCount)
            sCommands(iCommandCount) = vFile
            iCommandCount = iCommandCount + 1

        End If

        vFile = Dir
    Wend

' *********************************************
' Function Code Exits
' *********************************************
ErrorExit:
    bGetNewCommands = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msModule, sSource) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function
Private Function bProcessAllCommands(sCommands() As String) As Boolean

' *********************************************
' **** Function Code Start
' *********************************************
    Dim bReturn As Boolean
    Const sSource As String = "bProcessAllCommands()"

    On Error GoTo ErrorHandler
    bReturn = True
' *********************************************
' *********************************************

    Dim sCommandPath As String, sUser As String
    sCommandPath = gsAPP_MASTER_PATH & msCOMMANDS_FOLDER
    sUser = UCase(Application.UserName)

    Dim iCmd As Integer
    For iCmd = LBound(sCommands) To UBound(sCommands)
        If Not bProcessCommand(sCommands(iCmd)) Then Err.Raise glHANDLED_ERROR
    Next

' *********************************************
' Function Code Exits
' *********************************************
ErrorExit:
    bProcessAllCommands = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msModule, sSource) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function
Private Function bProcessCommand(sCommand As String, Optional bDeleteIfUserCmd As Boolean = True) As Boolean

' *********************************************
' **** Function Code Start
' *********************************************
    Dim bReturn As Boolean
    Const sSource As String = "bProcessCommand()"

    On Error GoTo ErrorHandler
    bReturn = True
' *********************************************
' *********************************************

    Dim sCommandPath As String, sUser As String
    sCommandPath = gsAPP_MASTER_PATH & msCOMMANDS_FOLDER
    sUser = UCase(Application.UserName)

    Dim bHaveIRun As Boolean, bCommandSuccessful As Boolean
    If Not bHaveIRunCommand(sCommand, bHaveIRun) Then Err.Raise glHANDLED_ERROR

    If Not bHaveIRun Then

        If Not bRunCommand(sCommand, bCommandSuccessful) Then Err.Raise glHANDLED_ERROR
        If bCommandSuccessful Then
            If Not bMarkCommandAsRan(sCommand) Then Err.Raise glHANDLED_ERROR
            MLog.Log "Ran: " & sCommand
        End If

    End If

' *********************************************
' Function Code Exits
' *********************************************
ErrorExit:
    bProcessCommand = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msModule, sSource) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function
Private Function bRunCommand(sCommand As String, bCommandSuccessful As Boolean) As Boolean

' *********************************************
' **** Function Code Start
' *********************************************
    Dim bReturn As Boolean
    Const sSource As String = "bRunCommand()"

    On Error GoTo ErrorHandler
    bReturn = True
' *********************************************
' *********************************************

    Dim sCommandName As String
    sCommandName = Replace(Mid(sCommand, InStrRev(sCommand, "_") + 1), ".txt", "")

    Select Case UCase(sCommandName)
        Case "MSGBOX":
            Dim sMsgBoxText As String
            If Not bGetParameterFromCommand(sCommand, "Msg", sMsgBoxText) Then Err.Raise glHANDLED_ERROR
            MsgBox sMsgBoxText
            bCommandSuccessful = True

        Case "UPDATE":
            CheckForUpdates False
            bCommandSuccessful = True

        Case "OLFLDRS":
            UpdateSavedOutlookFolderList
            bCommandSuccessful = True

    End Select



' *********************************************
' Function Code Exits
' *********************************************
ErrorExit:
    bRunCommand = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msModule, sSource) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function
Private Function bGetParameterFromCommand(sCommand As String, sParameterName As String, sParameterReturn As String) As Boolean

' *********************************************
' **** Function Code Start
' *********************************************
    Dim bReturn As Boolean
    Const sSource As String = "bGetParameterFromCommand()"

    On Error GoTo ErrorHandler
    bReturn = True
' *********************************************
' *********************************************

    Dim sCommandPath As String, sUser As String
    sCommandPath = gsAPP_MASTER_PATH & msCOMMANDS_FOLDER
    sUser = UCase(Application.UserName)

    Dim sFilePath As String, sParameterText() As String, sTextLine As String
    Dim iLineCount As Integer
    sFilePath = sCommandPath & sCommand

    Dim bBegin As Boolean

    Open sFilePath For Input As #1
    Do Until EOF(1)
        Line Input #1, sTextLine

        If bBegin Then If Left(sTextLine, 1) = ":" Then bBegin = False
        If sTextLine Like "*:Parameters:*" Then
            bBegin = True
        End If

        If bBegin Then
            ReDim Preserve sParameterText(0 To iLineCount)
            sParameterText(iLineCount) = sTextLine
            iLineCount = iLineCount + 1
        End If
    Loop
    Close #1

    Dim iParameterCounter As Integer
    For iParameterCounter = LBound(sParameterText) To UBound(sParameterText)
        If sParameterText(iParameterCounter) Like sParameterName & ": *" Then _
            sParameterReturn = Mid(sParameterText(iParameterCounter), InStr(1, sParameterText(iParameterCounter), " ") + 1)
    Next


' *********************************************
' Function Code Exits
' *********************************************
ErrorExit:
    bGetParameterFromCommand = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msModule, sSource) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function
Private Function bHaveIRunCommand(sCommand As String, bHaveIRun As Boolean) As Boolean

' *********************************************
' **** Function Code Start
' *********************************************
    Dim bReturn As Boolean
    Const sSource As String = "bHaveIRunCommand()"

    On Error GoTo ErrorHandler
    bReturn = True
' *********************************************
' *********************************************

    Dim sCommandPath As String, sUser As String
    sCommandPath = gsAPP_MASTER_PATH & msCOMMANDS_FOLDER
    sUser = UCase(Application.UserName)

    Dim sFile As String, sText As String, sTextLine As String
    sFile = sCommandPath & sCommand

    Dim bBegin As Boolean

    Open sFile For Input As #1
    Do Until EOF(1)
        Line Input #1, sTextLine

        If bBegin Then If Left(sTextLine, 1) = ":" Then bBegin = False
        If sTextLine Like "*:Run By Users:*" Then bBegin = True

        If bBegin Then
            sText = sText & sTextLine
        End If
    Loop
    Close #1

    bHaveIRun = sText Like "*" & sUser & "*"

' *********************************************
' Function Code Exits
' *********************************************
ErrorExit:
    bHaveIRunCommand = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msModule, sSource) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function
Private Function bMarkCommandAsRan(sCommand As String) As Boolean

' *********************************************
' **** Function Code Start
' *********************************************
    Dim bReturn As Boolean
    Const sSource As String = "bMarkCommandAsRan()"

    On Error GoTo ErrorHandler
    bReturn = True
' *********************************************
' *********************************************

    Dim sCommandPath As String, sUser As String
    sCommandPath = gsAPP_MASTER_PATH & msCOMMANDS_FOLDER
    sUser = UCase(Application.UserName)

    Dim sFilePath As String, sRanText As String, sTextLine As String, bHaveIRun As Boolean
    Dim sFullText() As String, iLineCount As Integer, iRunBy As Integer
    sFilePath = sCommandPath & sCommand

    Dim bBegin As Boolean

    Open sFilePath For Input As #1
    Do Until EOF(1)
        Line Input #1, sTextLine

        ReDim Preserve sFullText(0 To iLineCount)
        sFullText(iLineCount) = sTextLine
        iLineCount = iLineCount + 1

        If bBegin Then If Left(sTextLine, 1) = ":" Then bBegin = False
        If sTextLine Like "*:Run By Users:*" Then
            bBegin = True
            iRunBy = iLineCount - 1
        End If

        If bBegin Then
            sRanText = sRanText & sTextLine
        End If
    Loop
    Close #1

    bHaveIRun = sRanText Like "*" & sUser & "*"

    If Not bHaveIRun Then
        Dim iCounter As Integer

        Open sFilePath For Output As #1
        For iLineCount = LBound(sFullText) To UBound(sFullText)
            Print #1, sFullText(iLineCount)
            If iLineCount = iRunBy Then _
                Print #1, sUser
        Next
        Close #1
    End If


' *********************************************
' Function Code Exits
' *********************************************
ErrorExit:
    bMarkCommandAsRan = bReturn
    Exit Function

ErrorHandler:
    bReturn = False
    If bCentralErrorHandler(msModule, sSource) Then
        Stop
        Resume
    Else
        Resume ErrorExit
    End If


End Function