FigCopy

Sub FigCopy()

Dim ws1 As Worksheet, ws2 As Worksheet, wb As Workbook

Dim ws As Worksheet, flg As Long, ws0 As Worksheet

Dim ppAp As PowerPoint.Application

Dim pp As PowerPoint.Presentation, ppp As PowerPoint.Presentation

Dim sd As PowerPoint.Slide

Dim sc As Double, bxtp As Double, bxwd As Double, bxht As Double 'マップの位置とサイズ（cmで指定）

Dim i As Long

Dim rg As Range, rgerr1 As Range, rgerr2 As Range, rgerr3 As Range

Dim ppwin As PowerPoint.DocumentWindow

sc = 72 / 2.54

Set ws0 = ThisWorkbook.Worksheets("Main")

Set rg = ws0.Range("K1")

Set rgerr1 = ws0.Range("N1")

Set rgerr2 = ws0.Range("L1")

Set rgerr3 = ws0.Range("N1")

Set ppAp = New PowerPoint.Application

Set pp = ppAp.Presentations.Add

Set sd = pp.Slides.AddSlide(1, pp.SlideMaster.CustomLayouts(7))

sname = pp.Path + vbCrLf + pp.Name

s = Format(Now, "yyyy/mm/dd:hh:mm:ss") + "作成"

s = s + Chr(13) + sname + Chr(13)

s = s + "Slide ID=" + Format(sd.SlideID, "0") + Chr(13)

s = s + "スライド名：" + sd.Name + vbCrLf

With sd

s = s + .NotesPage.Shapes(2).TextFrame.TextRange.Text

.NotesPage.Shapes(2).TextFrame.TextRange.Text = s

End With

Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7))

flg = 0

For Each wb In Workbooks

Call GetExcelDataWorkBook(ws1, ws2, wb, flg)

If flg >= 2 Then

For Each ws In wb.Worksheets

If Left(ws.Name, 5) = "graph" Then

For Each ppwin In ppAp.Windows

If ppwin.Presentation.Name = pp.Name Then

For i = 1 To 100

rg.Value = i

Call DrawGraphTest(i)

If rgerr1.Value + rgerr2.Value + rgerr3.Value < 1 Then

With ppwin

ws.Activate

ws.Shapes("Chart 1").Select

Selection.Copy

.Activate

Set ppshprg = _

pp.Slides(pp.Slides.Count).Shapes.PasteSpecial(ppPasteEnhancedMetafile)

With ppshprg(1)

.Left = 2 * sc: .Top = 1 * sc: .Height = 16 * sc: .Width = 24 * sc

End With

Set sd = pp.Slides.AddSlide(pp.Slides.Count + 1, pp.SlideMaster.CustomLayouts(7))

End With

Else

Exit Sub

End If

Next i

End If

Next ppwin

End If

Next ws

End If

Next wb

End Sub