【テクニカル・上級編】【上級者向け】カスタムフィールドの値をJSON形式でエクスポート・インポートする – Project VBA解析バイブル

スポンサーリンク

1. 企業の基幹系システムとMS Projectを巡る断絶と課題

Microsoft Project（以下、MS Project）はプロジェクト管理の現場において比類なき表現力を持っています。しかし、エンタープライズアーキテクチャの視点に立つと、しばしば「データの孤島」と化します。

Jira、ServiceNow、SAP、あるいは社内の独自ERPといったモダンな基幹系システムは、RESTful APIとJSONをデファクトスタンダードとしてデータをやり取りします。一方、MS Project内部のカスタムフィールド（`Text1`〜`Text30`、`Number1`〜`Number20`、コスト、日付、あるいは独自の計算式）に保持された高度なドメイン知識は、COMオブジェクトの壁に阻まれ、外部システムとの疎結合な同期が困難でした。

一般的なVBA開発者が陥りがちな過ちは、CSVを経由したデータ交換や、32bit環境依存のレガシーコンポーネント（`MSScriptControl.ScriptControl` など）に依存した実装です。これらは64bit版Office環境で即座に破綻し、数万タスク規模の巨大プロジェクトファイルにおいて深刻なメモリリークとパフォーマンス低下を引き起こします。

本稿では、外部ライブラリに依存せず、64bit環境（x64 Architecture）に完全対応した純粋なVBAおよびWindows APIのみを用い、MS Projectのカスタムフィールド群を極限のパフォーマンスでJSONシリアライズ／デシリアライズするアーキテクチャを提示します。

2. アーキテクチャ設計要件とメモリ最適化の原則

巨大なプロジェク計画データをJSONへ高速に相互変換するためには、以下の3つの技術的要件を満たす必要があります。

(1) Dynamic Field Constant Mapping（動的フィールド定数マッピング）

MS Projectのカスタムフィールドは、UI上の表示名（例: “Jira_Issue_Key”）と内部フィールドID（例: `pjTaskText1`）が分離されています。`Application.FieldNameToFieldConstant` を毎回ループ内で評価すると、COMのVTable呼び出しオーバーヘッドが爆発します。事前にハッシュマップ（`Scripting.Dictionary`）へ定数化（キャッシュ）する設計が不可欠です。

(2) String Buffer Strategy（文字列バッファ戦略によるメモリ再割当の防止）

VBAにおける標準の文字列結合（`s = s & “…”`）は、結合のたびにBSTR（Basic String）の新規割り当てとコピーを発生させ、計算量は $O(N^2)$ に悪化します。大規模プロジェクト（数千タスク×数十カスタムフィールド）のシリアライズでは、可変長配列を利用したバッファリングを行い、最後に一括結合（`Join`）することで $O(N)$ の線形時間に抑え込みます。

(3) Deterministic Object Lifecycle Control（確定的なオブジェクト破棄）

Project VBAのオブジェクトモデル（`Task`、`Resource`、`Assignment`）は、内部的に重厚なCOMラッパーです。ループ処理内での参照リークを防ぐため、オブジェクト変数の明確なスコープ管理と `Set obj = Nothing` による即時解放を物理レベルで徹底します。

3. 完全実装コード：JSON Serialization / Deserialization Engine

以下に、実稼働環境へそのまま投入可能なプロダクションレベルのVBAモジュールを示します。高精度タイマー（Windows API）を組込み、処理時間をマイクロ秒単位で計測・最適化できる構成としています。

Standard Module: `mod_JsonSerializer.bas`

Option Explicit

' ==============================================================================
' Windows API Declarations for High-Precision Performance Monitoring
' ==============================================================================


  
スポンサーリンク

  

    




          







  


If VBA7 Then

    Private Declare PtrSafe Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Private Declare PtrSafe Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

Else

    Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
    Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

End If


' ==============================================================================
' Public API: Task Custom Fields Export to JSON
' ==============================================================================
Public Function ExportTaskCustomFieldsToJSON(ByRef TargetProject As Project, _
                                             ByRef FieldNames() As String) As String
    Dim startTime As Currency, endTime As Currency, freq As Currency
    QueryPerformanceFrequency freq
    QueryPerformanceCounter startTime

    ' 画面描画と計算エンジンの即時停止（スループットの極大化）
    Dim oldScreenUpdating As Boolean
    Dim oldCalculation As PjCalculation
    oldScreenUpdating = Application.ScreenUpdating
    oldCalculation = Application.Calculation
    
    Application.ScreenUpdating = False
    Application.Calculation = pjManual

    On Error GoTo ErrorHandler

    ' 1. フィールド名から FieldConstant への事前マッピング (VTable呼び出し最適化)
    Dim fieldMap As Object
    Set fieldMap = CreateObject("Scripting.Dictionary")
    
    Dim i As Long
    Dim fieldID As Long
    For i = LBound(FieldNames) To UBound(FieldNames)
        On Error Resume Next
        fieldID = Application.FieldNameToFieldConstant(FieldNames(i), pjTask)
        On Error GoTo ErrorHandler
        
        If fieldID <> pjTaskNone Then
            If Not fieldMap.Exists(FieldNames(i)) Then
                fieldMap.Add FieldNames(i), fieldID
            End If
        End If
    Next i

    ' 2. タスクデータの抽出と文字列バッファ構築
    Dim tsk As Task
    Dim jsonBuffer() As String
    Dim bufferIndex As Long
    ReDim jsonBuffer(0 To TargetProject.Tasks.Count)
    bufferIndex = 0

    Dim taskJsonParts() As String
    ReDim taskJsonParts(0 To fieldMap.Count + 1) ' ID, Name + CustomFields
    
    Dim k As Long
    Dim fldName As Variant
    Dim fieldValue As String
    
    For Each tsk In TargetProject.Tasks
        ' 割り当てのないヌルタスク（削除済み行など）のスキップ
        If Not (tsk Is Nothing) Then
            k = 0
            ' 必須標準フィールド
            taskJsonParts(k) = """ID"":" & tsk.ID
            k = k + 1
            taskJsonParts(k) = """Name"":" & EscapeJSONString(tsk.Name)
            
            ' カスタムフィールドのシリアライズ
            For Each fldName In fieldMap.Keys
                k = k + 1
                fieldID = CLng(fieldMap(fldName))
                fieldValue = tsk.GetField(fieldID)
                taskJsonParts(k) = """" & EscapeJSONString(CStr(fldName)) & """:" & EscapeJSONString(fieldValue)
            Next fldName
            
            jsonBuffer(bufferIndex) = "{" & Join(taskJsonParts, ",") & "}"
            bufferIndex = bufferIndex + 1
        End If
    Next tsk

    ' バッファの有効サイズへのリサイズ
    If bufferIndex > 0 Then
        ReDim Preserve jsonBuffer(0 To bufferIndex - 1)
        ExportTaskCustomFieldsToJSON = "[" & Join(jsonBuffer, ",") & "]"
    Else
        ExportTaskCustomFieldsToJSON = "[]"
    End If

CleanUp:
    ' リソースの明示的解放と設定のリストア
    Set fieldMap = Nothing
    Set tsk = Nothing
    Application.Calculation = oldCalculation
    Application.ScreenUpdating = oldScreenUpdating
    
    QueryPerformanceCounter endTime
    Debug.Print "Export Execution Time: " & Format$((endTime - startTime) / freq, "0.0000") & " Seconds"
    Exit Function

ErrorHandler:
    ExportTaskCustomFieldsToJSON = "{""error"":""" & EscapeJSONString(Err.Description) & """}"
    Resume CleanUp
End Function

' ==============================================================================
' Public API: JSON Import to Task Custom Fields
' Note: Light-weight, high-performance Json Parser for Flat Field Structural Payloads
' ==============================================================================
Public Sub ImportTaskCustomFieldsFromJSON(ByRef TargetProject As Project, ByVal JsonString As String)
    On Error GoTo ErrorHandler

    Dim oldScreenUpdating As Boolean
    Dim oldCalculation As PjCalculation
    oldScreenUpdating = Application.ScreenUpdating
    oldCalculation = Application.Calculation
    
    Application.ScreenUpdating = False
    Application.Calculation = pjManual

    ' 超高速化のために文字列トリミング
    JsonString = Trim$(JsonString)
    If Left$(JsonString, 1) <> "[" Or Right$(JsonString, 1) <> "]" Then
        Err.Raise vbObjectError + 1001, , "Invalid JSON Array Format"
    End If

    ' 外側のブラケットを除去
    JsonString = Mid$(JsonString, 2, Len(JsonString) - 2)
    
    ' トークナイズ処理（簡略化フラットオブジェクト解析）
    ' 注意: 本ロジックは標準的なフラット配列エクスポートデータの高速インポートに特化
    Dim objects() As String
    objects = Split(JsonString, "},{")
    
    Dim idx As Long
    Dim rawObj As String
    Dim keyValues() As String
    Dim kvIndex As Long
    Dim kvPair() As String
    Dim taskID As Long
    Dim currentTask As Task
    
    Dim fieldName As String
    Dim fieldValue As String
    Dim fieldID As Long

    For idx = LBound(objects) To UBound(objects)
        rawObj = objects(idx)
        rawObj = Replace(rawObj, "{", "")
        rawObj = Replace(rawObj, "}", "")
        
        keyValues = Split(rawObj, ",")
        
        ' 1回目のパスでIDを特定
        taskID = 0
        For kvIndex = LBound(keyValues) To UBound(keyValues)
            kvPair = Split(keyValues(kvIndex), ":")
            fieldName = UnescapeJSONString(kvPair(0))
            If UCase$(fieldName) = "ID" Then
                taskID = CLng(kvPair(1))
                Exit For
            End If
        Next kvIndex

        ' IDに基づくタスクオブジェクトのバインド
        If taskID > 0 Then
            On Error Resume Next
            Set currentTask = TargetProject.Tasks(taskID)
            On Error GoTo ErrorHandler
            
            If Not (currentTask Is Nothing) Then
                ' 2回目のパスでカスタムフィールドの書き込み
                For kvIndex = LBound(keyValues) To UBound(keyValues)
                    kvPair = Split(keyValues(kvIndex), ":")
                    fieldName = UnescapeJSONString(kvPair(0))
                    
                    If UCase$(fieldName) <> "ID" And UCase$(fieldName) <> "NAME" Then
                        fieldValue = UnescapeJSONString(kvPair(1))
                        
                        On Error Resume Next
                        fieldID = Application.FieldNameToFieldConstant(fieldName, pjTask)
                        On Error GoTo ErrorHandler
                        
                        If fieldID <> pjTaskNone Then
                            ' カスタムフィールドへ値を設定
                            currentTask.SetField fieldID, fieldValue
                        End If
                    End If
                Next kvIndex
            End If
        End If
        Set currentTask = Nothing
    Next idx

CleanUp:
    Set currentTask = Nothing
    Application.Calculation = oldCalculation
    Application.ScreenUpdating = oldScreenUpdating
    Exit Sub

ErrorHandler:
    MsgBox "Import Error: " & Err.Description, vbCritical, "JSON Execution Engine"
    Resume CleanUp
End Sub

' ==============================================================================
' Utility Helper Functions for Sanitization and Escaping
' ==============================================================================
Private Function EscapeJSONString(ByVal Source As String) As String
    Dim str As String
    str = Source
    str = Replace(str, "\", "\\")
    str = Replace(str, """", "\""")
    str = Replace(str, vbCrLf, "\n")
    str = Replace(str, vbCr, "\n")
    str = Replace(str, vbLf, "\n")
    str = Replace(str, vbTab, "\t")
    EscapeJSONString = """" & str & """"
End Function

Private Function UnescapeJSONString(ByVal Source As String) As String
    Dim str As String
    str = Trim$(Source)
    ' 引用符の除去
    If Left$(str, 1) = """" And Right$(str, 1) = """" Then
        str = Mid$(str, 2, Len(str) - 2)
    End If
    str = Replace(str, "\""", """")
    str = Replace(str, "\\", "\")
    str = Replace(str, "\n", vbCrLf)
    str = Replace(str, "\t", vbTab)
    UnescapeJSONString = str
End Function

4. 技術解説：アーキテクトが押さえるべき極限の知見

(1) `FieldNameToFieldConstant` の計算量とルックアップ最適化

MS Projectの内部アーキテクチャにおいて、文字列によるフィールド名解釈は非常に低速なシンボル解決処理を伴います。上記コードでは、エクスポート開始時に `Scripting.Dictionary` を使用し、ユーザー定義名から `pjField` 列挙型整数値（`Long`）への変換を $O(1)$ のハッシュテーブルに事前構築しています。これにより、ループ内での文字列解析オーバーヘッドを完全に排除しています。

(2) 64bit VBA環境におけるポインタとメモリ安全性の確保

`QueryPerformanceCounter` などのWin32 APIを定義する際、`VBA7` 条件付きコンパイル文を使用しています。64bit環境（x64）のOfficeではポインタサイズが8バイトに拡張されるため、`PtrSafe` キーワードを適用し、整数型ポインタの精密なマッピングを行う必要があります。これを怠ると、最悪の場合、Excel/Projectプロセスごとサイレントクラッシュ（アクセス違反例外）を引き起こします。

(3) COMオブジェクトのライフサイクルとガベージコレクションの制限

VBAの参照カウント型ガベージコレクション（引用カウント方式）は、`For Each tsk In TargetProject.Tasks` のようなCOMコレクションのループにおいて内部参照が残りやすい性質を持っています。
インポートループ内で `Set currentTask = TargetProject.Tasks(taskID)` により取得したオブジェクトは、次のイテレーションに入る前に必ず `Set currentTask = Nothing` を明示実行し、COMインターフェースを解放します。これにより、数万行単位の更新処理においても作業メモリ（Working Set）の不必要な膨張を完全に防止できます。

5. まとめとシステム連携の展望

本稿で解説したJSON変換エンジンを導入することにより、MS Projectは単なるローカルのデスクトップツールから、モダンなWebベースのエンタープライズ・アーキテクチャにシームレスに統合されたノードへと昇華します。

1. REST API経由の同期: PythonやNode.jsで作成した中間マイクロサービスへ、本VBAエンジンが出力したJSONをHTTP Post（`MSXML2.ServerXMLHTTP` 等を利用）することで、Jiraとの双方向自動同期（WBSおよび進捗の更新）が実現可能になります。
2. 保守性の向上: サードパーティ製のDLLやOCX、あるいは非推奨となったレガシーコンポーネントに一切依存しない設計のため、将来的なOffice 365のバージョンアップやC2R (Click-to-Run) アップデートに対しても完璧な後方互換性を保証します。

レガシーな技術要素であるVBAであっても、計算量・メモリ構造・Windows APIへの深い洞察を持って設計すれば、モダンな分散システムの足回りとして圧倒的な信頼性とパフォーマンスを発揮します。本ロジックを基幹アーキテクチャのコンポーネントとしてぜひ活用してください。

スポンサーリンク
タイトルとURLをコピーしました