OK、私は潜在的な解決策＃1を行った。
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
はThisWorkbookで
コードコード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