Access (VBA)

Access VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : 指定なし)
Accessで作成したグラフをPowerPointに貼り付ける方法
投稿日時: 20/06/19 16:09:09
投稿者: @fukufuku

いつもお世話になっています。
まだまだ初心者です。
Accessでグラフを作成していますが、自動的にPowerPoinに貼り付ける方法を教えてください。
グラフの数も多く効率的な方法をお願いします

回答
投稿日時: 20/06/19 17:51:03
投稿者: sk

引用:
(Windows 10全般 : 指定なし)

・Access および PowerPoint( Office )のバージョンが不明。
 
引用:
Accessでグラフを作成していますが、自動的にPowerPoinに貼り付ける方法を教えてください。
グラフの数も多く効率的な方法をお願いします

・どのオブジェクト(フォーム/レポート)に埋め込まれているグラフなのかが不明。
 
・新規のプレゼンテーションファイル上のスライドに貼り付けたいのか、
 既存のプレゼンテーションファイルの任意のスライドに貼り付けたいのかが不明。
 
・図として貼り付けたいのか OLE オブジェクトとして貼り付けたいのかが不明。
 
・そもそも何を目的として PowerPoint に貼り付けたいのかが不明。
 
仮に Access のフォーム上にある単一のグラフオブジェクトを
クリップボードにコピーし、既に PowerPoint 上で開かれている
プレゼンテーションのスライド上に OLE オブジェクトとして貼り付けるとして、
この場合のグラフの形式(オブジェクトの種類)は PowerPoint によって
新規作成したグラフとは異なるものとなりますが、それについては
問題ないのでしょうか。

投稿日時: 20/06/19 21:58:33
投稿者: @fukufuku

SKさんありがとうございます。
また、言葉足らずで申し訳ございません。
本来、excelでデータ分析用のグラフを作成しており、数十枚をコピペでPowerPoinに貼り付けています。すごく時間を要するのでaccessで効率よく作成できないかと思い、取り掛かっています。
そこで指摘された件ですが、
・現在グラフはフォームで作成しています。(ただ、excelのようには、仕上がっていません)
・PowerPoinは、新規のスライドに貼り付けるつもりです。
・貼り付けはOLEオブジェクトは考えていません。
・目的はプレゼン用です。
 
まだまだ初心者ですのでよろしくお願いします。
access及びPowerPoinのバージョンは、365です。

回答
投稿日時: 20/06/22 11:58:37
投稿者: sk

引用:
本来、excelでデータ分析用のグラフを作成しており、
数十枚をコピペでPowerPoinに貼り付けています。
すごく時間を要するのでaccessで効率よく作成できないかと思い、
取り掛かっています。

「効率よく作成」というのは、「グラフのコピーアンドペースト」以外の処理
含めての話なのでしょうか。
 
(グラフオブジェクトなのかグラフシートなのかは不明ですが)
既に Excel ブック上に作成されているグラフを
新規プレゼンテーション内の各スライドに貼り付ける、
という部分の作業だけを自動化したいのであれば、
Excel のマクロでも出来そうですが。
 
(グラフのある Excel ブックの標準モジュール)
-----------------------------------------------------------------------
Public Sub subExportChartsToPresentation()
            
    Dim objSheet As Object
    Dim xlsChartObject As Excel.ChartObject
    
    Dim pptApp As Object            'PowerPoint.Application
    Dim pptPresentation As Object   'PowerPoint.Presentation
    
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    
    Set pptPresentation = pptApp.Presentations.Add
    
    For Each objSheet In ThisWorkbook.Sheets
        If TypeOf objSheet Is Excel.Worksheet Then
            For Each xlsChartObject In objSheet.ChartObjects
                xlsChartObject.Copy
                subPasteChartToNewSlide pptPresentation, xlsChartObject.Name
            Next
        Else
            objSheet.ChartArea.Copy
            subPasteChartToNewSlide pptPresentation, objSheet.Name
        End If
    Next
    
    Set pptPresentation = Nothing
    Set pptApp = Nothing
    
End Sub

Private Sub subPasteChartToNewSlide(Presentation As Object, Optional Title As String)

    Dim pptSlide As Object          'PowerPoint.Slide
    Dim pptLayout As Object         'PowerPoint.CustomLayout
    Dim pptShapeRange As Object     'PowerPoint.ShapeRange
    Dim pptTitle As Object          'PowerPoint.Shape
    Dim pptBody As Object           'PowerPoint.Shape

    With Presentation               'PowerPoint.Presentation
        Set pptLayout = .SlideMaster.CustomLayouts(2)
        Set pptSlide = .Slides.AddSlide(.Slides.Count + 1, pptLayout)
        Set pptLayout = Nothing
        pptSlide.Select
        If Title <> "" Then
            Set pptTitle = pptSlide.Shapes.Placeholders(1)
            pptTitle.TextFrame2.TextRange.Text = Title
            Set pptTitle = Nothing
        End If
        Set pptBody = pptSlide.Shapes.Placeholders(2)
        Set pptShapeRange = pptSlide.Shapes.PasteSpecial(11)
        With pptShapeRange
            .Top = pptBody.Top
            .Left = pptBody.Left
            .Width = pptBody.Width
            .Height = pptBody.Height
        End With
        Set pptShapeRange = Nothing
        Set pptBody = Nothing
        Set pptSlide = Nothing
    End With

End Sub
-----------------------------------------------------------------------
 
 
引用:
・現在グラフはフォームで作成しています。(ただ、excelのようには、仕上がっていません)

そのフォームは連結フォームでしょうか、それとも非連結フォームでしょうか。
 
もし前者である場合、レコードごとにグラフをプロットしようとなさっているのでしょうか。
 
引用:
・PowerPoinは、新規のスライドに貼り付けるつもりです。
・貼り付けはOLEオブジェクトは考えていません。
目的はプレゼン用です。

プレゼン目的となると、その数十枚あるグラフを個々のスライドに
埋め込むにしても、プレゼンの構成に応じてそれぞれのグラフを
挿入する位置や順番があらかじめ決められているのではないでしょうか。

投稿日時: 20/06/22 15:34:22
投稿者: @fukufuku

SKさんご丁寧な回答ありがとうございます。
ExcelからPowerPointへのマクロを使って貼り付けはできました。
ただ、複数のシートのグラフを一括しての貼り付ける方法をご指導していただけないでしょうか?
グラフはオブジェクトではなくシート(JPEG)でおねがいします。
よろしくお願いいたします。

回答
投稿日時: 20/06/22 17:27:47
投稿者: sk

引用:
複数のシートのグラフを一括しての貼り付ける方法

それは具体的にどのような状態のシート/グラフを意味していて、
それらがどのような形で貼り付けられればよいのでしょうか。
 
なお、私の例示したコードについては、以下のような動作になっています。
 
・1 つ以上のグラフオブジェクトが含まれているワークシートについては、
 1 つのグラフオブジェクトにつき 1 つのスライドを新規作成し、そこに貼り付ける。
 (これを全てのワークシートで実行している
 
・グラフシートについては、1 つのグラフシートにつき 1 つのスライドを新規作成し、
 そこに貼り付ける。
 (これを全てのグラフシートで実行している
 
・以上のいずれかの処理をシート(ワークシート/グラフシート)の順番に実行する。
 
引用:
グラフはオブジェクトではなくシート(JPEG)でおねがいします。

その場合は以下の箇所を書き換えて下さい。
 
引用:
Set pptShapeRange = pptSlide.Shapes.PasteSpecial(11)

Set pptShapeRange = pptSlide.Shapes.PasteSpecial(5)

投稿日時: 20/06/23 08:45:50
投稿者: @fukufuku

SKさん迅速な対応ありがとうございます。
あと2点の質問よろしいでしょうか。
マクロでPowerPoinに貼り付ける場合、そのPowerPoinのファイルを指定できるようにマクロを設定する方法も教えていただければ幸いです。
あと1点は、Accessのフォーム又はレポートのAccessのグラフをPowerPoinに貼り付ける方法は、初心者には難しいものなのでしょうか?
最後の質問とさせて頂きます。
よろしくお願いいたします。

回答
投稿日時: 20/06/23 10:23:27
投稿者: sk

引用:
マクロでPowerPoinに貼り付ける場合、そのPowerPoinのファイルを
指定できるようにマクロを設定する方法

グラフの出力先として既存のプレゼンテーションファイルを
選択できるようにしたい、ということであれば、
ファイルダイアログを呼び出すようになさればよいでしょう。
 
引用:
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
 
Set pptPresentation = pptApp.Presentations.Add

Dim strExportFilePath As String
 
With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "PowerPoint プレゼンテーション", _
                 "*.pptx; *.pptm; *.ppt"
    If .Show = 0 Then
        Exit Sub
    End If
    strExportFilePath = .SelectedItems(1)
End With
 
Set pptApp = CreateObject("PowerPoint.Application")
pptApp.Visible = True
 
Set pptPresentation = pptApp.Presentations.Open(strExportFilePath)
 
引用:
Accessのフォーム又はレポートのAccessのグラフをPowerPoinに貼り付ける方法

フォーム上のグラフに関しては、Excel のグラフシートと同じように
グラフエリアをクリップボードにコピーし、PowerPoint 側で
貼り付けを実行なさればよいでしょう。
 
(グラフのある Access のフォームのフォームモジュール)
----------------------------------------------------------
'コマンドボタンの[クリック時]イベント
Private Sub コマンドボタン名_Click()
    
    Call subExportChartToPresentation
    
End Sub

Private Sub subExportChartToPresentation()
            
    Dim pptApp As Object            'PowerPoint.Application
    Dim pptPresentation As Object   'PowerPoint.Presentation
    
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    
    '新規プレゼンテーションの作成と参照
    Set pptPresentation = pptApp.Presentations.Add
    
    With Me.グラフ名
        .Object.ChartArea.Copy
        subPasteChartToNewSlide pptPresentation, .Name
    End With
    
    Set pptPresentation = Nothing
    Set pptApp = Nothing
    
End Sub

Private Sub subPasteChartToNewSlide(Presentation As Object, Optional Title As String)

    Dim pptSlide As Object          'PowerPoint.Slide
    Dim pptLayout As Object         'PowerPoint.CustomLayout
    Dim pptShapeRange As Object     'PowerPoint.ShapeRange
    Dim pptTitle As Object          'PowerPoint.Shape
    Dim pptBody As Object           'PowerPoint.Shape

    With Presentation               'PowerPoint.Presentation
        Set pptLayout = .SlideMaster.CustomLayouts(2)
        Set pptSlide = .Slides.AddSlide(.Slides.Count + 1, pptLayout)
        Set pptLayout = Nothing
        pptSlide.Select
        If Title <> "" Then
            Set pptTitle = pptSlide.Shapes.Placeholders(1)
            pptTitle.TextFrame2.TextRange.Text = Title
            Set pptTitle = Nothing
        End If
        Set pptBody = pptSlide.Shapes.Placeholders(2)
        Set pptShapeRange = pptSlide.Shapes.PasteSpecial(2)    'EMF形式で貼り付け
        With pptShapeRange
            .Top = pptBody.Top
            .Left = pptBody.Left
            .Width = pptBody.Width
            .Height = pptBody.Height
        End With
        Set pptShapeRange = Nothing
        Set pptBody = Nothing
        Set pptSlide = Nothing
    End With

End Sub
----------------------------------------------------------
 
上記のサンプルの場合、フォームのカレントレコードのグラフが
新規プレゼンテーションに出力されることになります。
(複数のレコードのグラフを一斉に出力するのはあまりお奨めしません)

投稿日時: 20/06/23 13:42:58
投稿者: @fukufuku

SKさん多くのことを丁寧にご指導いただきありがとうございました。
感謝します。
今後もお尋ねすることもあるかと思いますが、その時は、よろしくお願いいたします。
ありがとうございました。