检测 MS 项目文件中何时发生更改（例如，当日期更改时）并自动将更改记录在 Excel 文件中

Question

我经常需要对大型 MS 项目文件进行更改。我想使用 MS 项目事件处理程序来检测任务何时发生更改（名称更改、日期更改、持续时间更改、链接更改等），复制发生更改的行，并复制到将其粘贴到 Excel 工作表中。我决定从仅跟踪任务名称字段开始。如果我能让这个工作，我可能就能让其他人工作。

我尝试了两种方法。第一种方法是将项目数据复制粘贴到 Excel 文件中，以便将其链接起来。如果我在 MS 项目中进行更改，则链接的 Excel 工作表中的相同值也会发生更改。然后，我将使用 MS 项目事件处理程序来调用 excel 中的 Sub。该子程序将找到更改的单元格数据并将其粘贴到同一工作簿中的另一个工作表中（以及其他相关信息）。我会使用 MS 项目事件处理程序，因为当我在 MS 项目中所做的更改发生在 Excel 工作表中时，我无法让 Excel 事件处理程序注意到。当我手动更改单元格中的值时，Excel 事件处理程序似乎仅检测到更改。

第二种方法，也是最有希望的一种方法，如下所述。我会简单地检测 MS 项目中特定字段下何时进行更改。复制所需的行并将其直接粘贴到 Excel 工作表中。我对此还没有了解太多，但我有一种感觉，我只是错过了一个小细节。

在 MS 项目模块中：

Dim myobject As New Class1

Sub Initialize_App()
    
    Set myobject.App = MSProject.Application
    Set myobject.Proj = Application.ActiveProject

End Sub

在课堂上

Option Explicit

Public WithEvents App As Application
Public WithEvents Proj As Project
Dim TrackchangesP1 As Workbook
Dim stuff As Worksheet
Dim filepath As String


Private Sub App_ProjectBeforeTaskChange(ByVal tsk As Task, ByVal Field As PjField, ByVal NewVal As Variant, Cancel As Boolean)
   
'This event triggers before a task field changes.
 'The entire file path is not shown here, but is present in my code.

    filepath = "C:\...\Track changes P1.xlsm"

     On Error Resume Next
          Set TrackchangesP1 = Workbooks(filepath)
         On Error GoTo 0
    If TrackchangesP1 Is Nothing Then
        ' Workbook is not open. Open it in read-only mode.
        Set TrackchangesP1 = Workbooks.Open(filepath, ReadOnly:=True)
    End If

    If Field = pjTaskName Then
        MsgBox "Task name changed to: " & NewVal
        
     
    'TrackchangesP1.Sheets("Sheet1").test 
'calls a sub in the worksheet which displays a message box, commented 'out for now, this is related to
'my first approach.


    TrackchangesP1.Sheets("Sheet1").Range("N2") = "hello world"
 '''
'I wanted to try to see if I could use a change to a task name in MS 'project to trigger something to be entered into a specific cell in excel. 'It didn't work. There are no errors, but nothing is pasted.
    
    End If
    

Answer 1

此代码将跟踪 Excel 工作簿中的更改。

对于 Class1 class 模块：

Public WithEvents App As Application
Public WithEvents Proj As Project

Private Sub Class_Initialize()

    Set App = Application
        
End Sub

Private Sub App_ProjectBeforeTaskChange(ByVal tsk As Task, ByVal Field As PjField _
    , ByVal NewVal As Variant, Cancel As Boolean)
    
    With ChangeLog
        Dim r As Long
        r = .UsedRange.Rows.Count + 1
        .Cells(r, 1) = Now
        .Cells(r, 2) = tsk.UniqueID
        .Cells(r, 3) = tsk.Name
        .Cells(r, 4) = Application.FieldConstantToFieldName(Field)
        .Cells(r, 5) = NewVal
    End With
    
End Sub

对于 Module1 模块：

Public myobject As New Class1

Public xlApp As Excel.Application
Public TrackchangesP1 As Excel.Workbook
Public ChangeLog As Excel.Worksheet
Public stuff As Excel.Worksheet

Public Const filepath As String = "C:\....xlsx"


Sub StartEvents()

    Set myobject.App = Application
    
    InitExcel
    
End Sub

Sub InitExcel()

    On Error Resume Next
    
    If xlApp Is Nothing Then
        Set xlApp = GetObject(, "Excel.Application")
        If xlApp Is Nothing Then
            Set xlApp = CreateObject("Excel.Application")
        End If
    End If

    If Not xlApp.Visible Then
        xlApp.WindowState = xlMinimized
        xlApp.Visible = True
    End If
    
    If TrackchangesP1 Is Nothing Then
        Set TrackchangesP1 = xlApp.Workbooks.Open(filepath)
    End If
    If ChangeLog Is Nothing Then
        Set ChangeLog = TrackchangesP1.Worksheets("Sheet1")
    End If
    
End Sub

最后，在 ThisProject 模块中：

Private Sub Project_Open(ByVal pj As Project)

    Call Module1.StartEvents

End Sub

注意：请务必在某个时候保存工作簿。