none
MS Projectのグラフをマクロで表示したい RRS feed

  • 質問

  • マイクロソフト コミュニティのほうで一度質問したのですが、こちらのほうが正しいアドバイスが集まると教えられたので、改めてこちらで質問させていただきます。

    https://answers.microsoft.com/ja-jp/msoffice/forum/msoffice_project-mso_winother/ms/c2b68d5c-9c23-440d-9b95-ad04ce7d2414

    MS Project 2013で、マクロを使って、レポート(グラフ)を表示させたいのですが、やり方がよくわかりません。

    デフォルトのグラフを表示するところまではできたのですが、それ以上の事を実行する方法がわかりません。

    VBAリファレンスを読んでも、欲しい情報に辿り着けないし、それっぽいものがあっても日本語が直訳のせいで不完全だったり、情報そのものが不完全だったりで、全然わかりません。

    実際にMS Project上での操作のように、「レポート」メニューから「新しいレポート」を作り、「フィールドリスト」の各項目を設定して、表示したいグラフを作るように、マクロでそれをやりたいのですが無理なのでしょうか?

    2017年1月22日 14:36

回答

  • こんな?
    #2016でテストしてます

    'モジュール
    Sub Test()
        Dim r As Report
        On Error Resume Next
        Set r = Application.ActiveProject.Reports("TestReport")
        If (Err.Number <> 0) Then
            Set r = Application.ActiveProject.Reports.Add("TestReport")
        End If
        On Error GoTo 0
        Dim shp As Shape
        Dim ch As Chart
        If (r.Shapes.Count = 0) Then
            Set shp = r.Shapes.AddChart(Type:=xl3DColumnClustered)
            Set ch = shp.Chart
        ElseIf (r.Shapes(1).HasChart) Then
            Set shp = r.Shapes(1)
            Set ch = shp.Chart
        Else
            Set shp = r.Shapes.AddChart(Type:=xl3DColumnClustered)
            Set ch = shp.Chart
        End If
        
        'チャートの操作はExcelを参考にして
        Dim ax As Object 'IMsoAxis
        Set ax = ch.Axes(Excel.XlAxisType.xlValue)
        ax.Border.ColorIndex = 1
        ax.Border.Weight = 3
    
    
        'チャートに表示されるフィールドの選択
        Dim tool As New ChartTool
        Dim index As Long
        Dim elements As UIAutomationClient.IUIAutomationElementArray
        Dim elem As UIAutomationClient.IUIAutomationElement
        Application.ScreenUpdating = False
        Set elements = tool.GetFields(shp)
        For index = 0 To elements.Length - 1
            Set elem = elements.GetElement(index)
            Debug.Print elem.CurrentName, tool.GetCheckState(elem)
            
            If (elem.CurrentName = "達成率") Then
                Call tool.SetCheckState(elem, True)
            Else
                Call tool.SetCheckState(elem, False)
            End If
        Next
        Application.ScreenUpdating = True
    End Sub

    'クラスモジュール(ChartTool)
    Option Explicit
    'UIAutomationClientの参照を追加
    Private uia As New UIAutomationClient.CUIAutomation
    
    Public Function GetCheckState(ByVal e As UIAutomationClient.IUIAutomationElement) As UIAutomationClient.ToggleState
        Dim tgl As UIAutomationClient.IUIAutomationTogglePattern
        Set tgl = e.GetCurrentPattern(UIAutomationClient.UIA_PatternIds.UIA_TogglePatternId)
        Let GetCheckState = tgl.CurrentToggleState
    End Function
    
    'チェックボックスにチェック
    Public Sub SetCheckState(ByVal e As UIAutomationClient.IUIAutomationElement, ByVal isCheck As Boolean)
        Dim tgl As UIAutomationClient.IUIAutomationTogglePattern
        Set tgl = e.GetCurrentPattern(UIAutomationClient.UIA_PatternIds.UIA_TogglePatternId)
        If (isCheck) Then
            If (tgl.CurrentToggleState <> ToggleState_On) Then
                tgl.Toggle
            End If
        Else
            If (tgl.CurrentToggleState <> ToggleState_Off) Then
                tgl.Toggle
            End If
        End If
    End Sub
    
    'フィールドリストのペインをUIAutomationで操作してフィールドの一覧を取得する
    Public Function GetFields(ByVal shp As Shape) As IUIAutomationElementArray
        Application.ScreenUpdating = True
        
        shp.Select 'グラフ選択することでフィールドリストのペインを表示させる
        
        Dim bar As CommandBar
        Set bar = Application.CommandBars("Field List")
        bar.Visible = True
    
        Dim arTreeViews As IUIAutomationElementArray
        Dim arCheck As IUIAutomationElementArray
        Dim wMain As UIAutomationClient.IUIAutomationElement
        Dim wTask As UIAutomationClient.IUIAutomationElement
        Dim gCategory As UIAutomationClient.IUIAutomationElement
        Dim gFields As UIAutomationClient.IUIAutomationElement
        
        'Projectのウィンドウをさがす
        Set wMain = FindClass(uia.GetRootElement(), "JWinproj-WhimperMainClass")
        
        'フィールドリストのペインを探す
        Dim time As Date
        time = DateAdd("s", 10, Now)
        Do While (wTask Is Nothing)
            If (Now > time) Then
                Exit Function
            End If
            Set wTask = FindClassAndName(wMain, "MsoCommandBar", bar.Controls(1).Caption)
            DoEvents
        Loop
    
        Set gCategory = FindClassAndName(wTask, "NetUIGroupBox", "カテゴリの選択")
        Set gFields = FindClassAndName(wTask, "NetUIGroupBox", "フィールドの選択")
    
        'ツリーをさがす
        Set arTreeViews = FindClassAll(gFields, "NetUITreeView")
        Dim index As Integer
        For index = 0 To arTreeViews.Length - 1
            'ツリーを展開
            Call ExpandAll(arTreeViews.GetElement(index))
        Next
        
        'チェックボックスを全部さがす
        Set GetFields = FindAll(arTreeViews.GetElement(0), UIAutomationClient.UIA_PropertyIds.UIA_IsTogglePatternAvailablePropertyId, True)
        
        
    End Function
    
    
    Private Sub ExpandAll(ByVal treeViewItem As UIAutomationClient.IUIAutomationElement)
        Dim arTreeItems As IUIAutomationElementArray
        Dim con As UIAutomationClient.IUIAutomationCondition
        Set con = uia.CreatePropertyCondition(UIAutomationClient.UIA_PropertyIds.UIA_IsExpandCollapsePatternAvailablePropertyId, True)
        Dim index As Long
        Set arTreeItems = treeViewItem.FindAll(TreeScope_Children, con)
        For index = 0 To arTreeItems.Length - 1
            Dim item As UIAutomationClient.IUIAutomationElement
            Set item = arTreeItems.GetElement(index)
            
            Dim exp As IUIAutomationExpandCollapsePattern
            Set exp = item.GetCurrentPattern(UIAutomationClient.UIA_PatternIds.UIA_ExpandCollapsePatternId)
            On Error Resume Next
            exp.Expand
            If (Err.Number = 0) Then
                Call ExpandAll(item)
            End If
        Next
        
    End Sub
    
    
    Private Function Find(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal id As Long, ByVal value As Variant) As UIAutomationClient.IUIAutomationElement
        Dim con As UIAutomationClient.IUIAutomationCondition
        Set con = uia.CreatePropertyCondition(id, value)
        Set Find = elem.FindFirst(TreeScope_Subtree, con)
    End Function
    Private Function FindAll(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal id As Long, ByVal value As Variant) As UIAutomationClient.IUIAutomationElementArray
        Dim con As UIAutomationClient.IUIAutomationCondition
        Set con = uia.CreatePropertyCondition(id, value)
        Set FindAll = elem.FindAll(TreeScope_Subtree, con)
    End Function
    Private Function FindClass(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal value As String) As UIAutomationClient.IUIAutomationElement
        Set FindClass = Find(elem, CLng(UIAutomationClient.UIA_PropertyIds.UIA_ClassNamePropertyId), value)
    End Function
    Private Function FindName(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal value As String) As UIAutomationClient.IUIAutomationElement
        Set FindName = Find(uia, elem, UIAutomationClient.UIA_PropertyIds.UIA_NamePropertyId, value)
    End Function
    Private Function FindClassAndName(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal className As String, ByVal name As String) As UIAutomationClient.IUIAutomationElement
        Dim con1 As UIAutomationClient.IUIAutomationCondition
        Dim con2 As UIAutomationClient.IUIAutomationCondition
        Dim conAnd As UIAutomationClient.IUIAutomationCondition
        Set con1 = uia.CreatePropertyCondition(UIAutomationClient.UIA_PropertyIds.UIA_ClassNamePropertyId, className)
        Set con2 = uia.CreatePropertyCondition(UIAutomationClient.UIA_PropertyIds.UIA_NamePropertyId, name)
        Set conAnd = uia.CreateAndCondition(con1, con2)
        Set FindClassAndName = elem.FindFirst(TreeScope_Subtree, conAnd)
    End Function
    Private Function FindClassAll(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal className As String, Optional ByVal scope As UIAutomationClient.TreeScope = TreeScope_Subtree) As UIAutomationClient.IUIAutomationElementArray
        Dim con As UIAutomationClient.IUIAutomationCondition
        Set con = uia.CreatePropertyCondition(UIAutomationClient.UIA_PropertyIds.UIA_ClassNamePropertyId, className)
        Set FindClassAll = elem.FindAll(scope, con)
    End Function



    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2017年1月23日 11:57

すべての返信

  • こんな?
    #2016でテストしてます

    'モジュール
    Sub Test()
        Dim r As Report
        On Error Resume Next
        Set r = Application.ActiveProject.Reports("TestReport")
        If (Err.Number <> 0) Then
            Set r = Application.ActiveProject.Reports.Add("TestReport")
        End If
        On Error GoTo 0
        Dim shp As Shape
        Dim ch As Chart
        If (r.Shapes.Count = 0) Then
            Set shp = r.Shapes.AddChart(Type:=xl3DColumnClustered)
            Set ch = shp.Chart
        ElseIf (r.Shapes(1).HasChart) Then
            Set shp = r.Shapes(1)
            Set ch = shp.Chart
        Else
            Set shp = r.Shapes.AddChart(Type:=xl3DColumnClustered)
            Set ch = shp.Chart
        End If
        
        'チャートの操作はExcelを参考にして
        Dim ax As Object 'IMsoAxis
        Set ax = ch.Axes(Excel.XlAxisType.xlValue)
        ax.Border.ColorIndex = 1
        ax.Border.Weight = 3
    
    
        'チャートに表示されるフィールドの選択
        Dim tool As New ChartTool
        Dim index As Long
        Dim elements As UIAutomationClient.IUIAutomationElementArray
        Dim elem As UIAutomationClient.IUIAutomationElement
        Application.ScreenUpdating = False
        Set elements = tool.GetFields(shp)
        For index = 0 To elements.Length - 1
            Set elem = elements.GetElement(index)
            Debug.Print elem.CurrentName, tool.GetCheckState(elem)
            
            If (elem.CurrentName = "達成率") Then
                Call tool.SetCheckState(elem, True)
            Else
                Call tool.SetCheckState(elem, False)
            End If
        Next
        Application.ScreenUpdating = True
    End Sub

    'クラスモジュール(ChartTool)
    Option Explicit
    'UIAutomationClientの参照を追加
    Private uia As New UIAutomationClient.CUIAutomation
    
    Public Function GetCheckState(ByVal e As UIAutomationClient.IUIAutomationElement) As UIAutomationClient.ToggleState
        Dim tgl As UIAutomationClient.IUIAutomationTogglePattern
        Set tgl = e.GetCurrentPattern(UIAutomationClient.UIA_PatternIds.UIA_TogglePatternId)
        Let GetCheckState = tgl.CurrentToggleState
    End Function
    
    'チェックボックスにチェック
    Public Sub SetCheckState(ByVal e As UIAutomationClient.IUIAutomationElement, ByVal isCheck As Boolean)
        Dim tgl As UIAutomationClient.IUIAutomationTogglePattern
        Set tgl = e.GetCurrentPattern(UIAutomationClient.UIA_PatternIds.UIA_TogglePatternId)
        If (isCheck) Then
            If (tgl.CurrentToggleState <> ToggleState_On) Then
                tgl.Toggle
            End If
        Else
            If (tgl.CurrentToggleState <> ToggleState_Off) Then
                tgl.Toggle
            End If
        End If
    End Sub
    
    'フィールドリストのペインをUIAutomationで操作してフィールドの一覧を取得する
    Public Function GetFields(ByVal shp As Shape) As IUIAutomationElementArray
        Application.ScreenUpdating = True
        
        shp.Select 'グラフ選択することでフィールドリストのペインを表示させる
        
        Dim bar As CommandBar
        Set bar = Application.CommandBars("Field List")
        bar.Visible = True
    
        Dim arTreeViews As IUIAutomationElementArray
        Dim arCheck As IUIAutomationElementArray
        Dim wMain As UIAutomationClient.IUIAutomationElement
        Dim wTask As UIAutomationClient.IUIAutomationElement
        Dim gCategory As UIAutomationClient.IUIAutomationElement
        Dim gFields As UIAutomationClient.IUIAutomationElement
        
        'Projectのウィンドウをさがす
        Set wMain = FindClass(uia.GetRootElement(), "JWinproj-WhimperMainClass")
        
        'フィールドリストのペインを探す
        Dim time As Date
        time = DateAdd("s", 10, Now)
        Do While (wTask Is Nothing)
            If (Now > time) Then
                Exit Function
            End If
            Set wTask = FindClassAndName(wMain, "MsoCommandBar", bar.Controls(1).Caption)
            DoEvents
        Loop
    
        Set gCategory = FindClassAndName(wTask, "NetUIGroupBox", "カテゴリの選択")
        Set gFields = FindClassAndName(wTask, "NetUIGroupBox", "フィールドの選択")
    
        'ツリーをさがす
        Set arTreeViews = FindClassAll(gFields, "NetUITreeView")
        Dim index As Integer
        For index = 0 To arTreeViews.Length - 1
            'ツリーを展開
            Call ExpandAll(arTreeViews.GetElement(index))
        Next
        
        'チェックボックスを全部さがす
        Set GetFields = FindAll(arTreeViews.GetElement(0), UIAutomationClient.UIA_PropertyIds.UIA_IsTogglePatternAvailablePropertyId, True)
        
        
    End Function
    
    
    Private Sub ExpandAll(ByVal treeViewItem As UIAutomationClient.IUIAutomationElement)
        Dim arTreeItems As IUIAutomationElementArray
        Dim con As UIAutomationClient.IUIAutomationCondition
        Set con = uia.CreatePropertyCondition(UIAutomationClient.UIA_PropertyIds.UIA_IsExpandCollapsePatternAvailablePropertyId, True)
        Dim index As Long
        Set arTreeItems = treeViewItem.FindAll(TreeScope_Children, con)
        For index = 0 To arTreeItems.Length - 1
            Dim item As UIAutomationClient.IUIAutomationElement
            Set item = arTreeItems.GetElement(index)
            
            Dim exp As IUIAutomationExpandCollapsePattern
            Set exp = item.GetCurrentPattern(UIAutomationClient.UIA_PatternIds.UIA_ExpandCollapsePatternId)
            On Error Resume Next
            exp.Expand
            If (Err.Number = 0) Then
                Call ExpandAll(item)
            End If
        Next
        
    End Sub
    
    
    Private Function Find(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal id As Long, ByVal value As Variant) As UIAutomationClient.IUIAutomationElement
        Dim con As UIAutomationClient.IUIAutomationCondition
        Set con = uia.CreatePropertyCondition(id, value)
        Set Find = elem.FindFirst(TreeScope_Subtree, con)
    End Function
    Private Function FindAll(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal id As Long, ByVal value As Variant) As UIAutomationClient.IUIAutomationElementArray
        Dim con As UIAutomationClient.IUIAutomationCondition
        Set con = uia.CreatePropertyCondition(id, value)
        Set FindAll = elem.FindAll(TreeScope_Subtree, con)
    End Function
    Private Function FindClass(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal value As String) As UIAutomationClient.IUIAutomationElement
        Set FindClass = Find(elem, CLng(UIAutomationClient.UIA_PropertyIds.UIA_ClassNamePropertyId), value)
    End Function
    Private Function FindName(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal value As String) As UIAutomationClient.IUIAutomationElement
        Set FindName = Find(uia, elem, UIAutomationClient.UIA_PropertyIds.UIA_NamePropertyId, value)
    End Function
    Private Function FindClassAndName(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal className As String, ByVal name As String) As UIAutomationClient.IUIAutomationElement
        Dim con1 As UIAutomationClient.IUIAutomationCondition
        Dim con2 As UIAutomationClient.IUIAutomationCondition
        Dim conAnd As UIAutomationClient.IUIAutomationCondition
        Set con1 = uia.CreatePropertyCondition(UIAutomationClient.UIA_PropertyIds.UIA_ClassNamePropertyId, className)
        Set con2 = uia.CreatePropertyCondition(UIAutomationClient.UIA_PropertyIds.UIA_NamePropertyId, name)
        Set conAnd = uia.CreateAndCondition(con1, con2)
        Set FindClassAndName = elem.FindFirst(TreeScope_Subtree, conAnd)
    End Function
    Private Function FindClassAll(ByVal elem As UIAutomationClient.IUIAutomationElement, ByVal className As String, Optional ByVal scope As UIAutomationClient.TreeScope = TreeScope_Subtree) As UIAutomationClient.IUIAutomationElementArray
        Dim con As UIAutomationClient.IUIAutomationCondition
        Set con = uia.CreatePropertyCondition(UIAutomationClient.UIA_PropertyIds.UIA_ClassNamePropertyId, className)
        Set FindClassAll = elem.FindAll(scope, con)
    End Function



    個別に明示されていない限りgekkaがフォーラムに投稿したコードにはフォーラム使用条件に基づき「MICROSOFT LIMITED PUBLIC LICENSE」が適用されます。(かなり自由に使ってOK!)

    2017年1月23日 11:57
  • gekkaさん。

    ご返事が遅れて申し訳ありません。

    ご回答ありがとうございます。

    回答されたプログラムを見て、理解してから返信しようと思っていたのですが、なかなか時間が取れず、結局今でもほぼ手つかずの状態です。

    このまま無理にMS Projectの機能にこだわるよりも、必要なデータをエクセルに移して、それからグラフとして表示するほうが、現実的な解決法かもしれないと、今は考えております。

    折角、回答していただいたのに、申し訳ありません。

    もし、どうしてもこの方法しかないという場合は、その時に改めて参考にさせていただくかもしれません。

    2017年1月30日 5:57