PowerPoint (全般)

PowerPoint 全般に関する話題を扱うフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : PowerPoint 2016)
字入力されたセルの数に応じてPPTにテキストボックスを生成
投稿日時: 17/12/12 19:04:09
投稿者: えび天

はじめまして。質問させていただきます。
Excel VBAからテキストボックスをPowerPointへ動的に生成したいです。
色んなサイトを見てみてみましたが、先例もなかったので困っております。
 
Excelとの連携をしており、Excelファイルの"Words"というシートに
 
  A  B  C  D  E  F  G  H  I   J
見だし  1  2  3  4  5  6  7 カテゴリ イラスト
 あ  あ  い う           …   ....png
 か  か  き く け         …    ....png
 さ  さ  し す せ そ       …    ....png
 た  た  ち             …    ....png
 な  な  に ぬ           …   ....png
 
というように文字が入っています。
Power Pointを立ち上げたときにB〜H列の2行目以降のセルデータを、数に応じて
テキストボックスを生成し、文字を反映させたいです。1行につき1スライドです。
(あいう行であればテキストボックス3つが中央ぞろえで並んでそのなかにそれぞれあ、い、う、と入る。)
(さしす行であればテキストボックス5つが中央ぞろえで並んでそのなかにそれぞれさ、し、す、せ、そ、と入る。)
 
テキストボックスを数に応じてスライドに横並びで挿入、かつ中央揃えにする方法を教えていただきたいです。
【B〜Dまで入っているときのイメージ↓】
_________________
|                |
|      イラスト      |
|                |      
|     □ □ □      |
|________________| 
 
お詳しい方、よろしくお願いいたします。
下記のコードはテキストボックスについての記述はしておりません。
("カテゴリ"などは無視していただいて大丈夫です)
---------------------------------------------------------------------
Sub スライド作成_Click()
 
  Dim ShpPic As PowerPoint.Shape, myShp As PowerPoint.Shape
  Dim PpApp As New PowerPoint.Application
  Dim PpPrs As PowerPoint.Presentation
  Dim lastRow As Long
  Dim NewSldR As PowerPoint.SlideRange
  Dim bhvEff As AnimationBehavior
  Dim EW As String
  Dim myRng As Range, myEff As Effect
  Dim Wsh As Worksheet
  Dim Catg, Cmb2
  Dim Rw As Long, N順位 As Long, j As Long
  Dim Rndm
     
   Set Wsh = Worksheets("Words")
   lastRow = Wsh.Cells(Rows.Count, 1).End(xlUp).Row
     
    'ランダム順取得
    With Wsh.Range("K2").Resize(lastRow - 1)
        .Formula = "=RAND()"
        Rndm = Application.Rank(.Cells, .Cells)
        .Value = Rndm
    End With
     
    PpApp.Visible = msoCTrue
    Set PpPrs = PpApp.Presentations.Open(ThisWorkbook.Path & "\スライド.pptx")
     Rw = 1 '初期化
     Catg = Worksheets("Database").ComboBox1.Value
     Cmb2 = Worksheets("Words").ComboBox2.Value
 
    'コンボ2の値までスライドを複製する
      For N順位 = 1 To lastRow - 1
        If PpPrs.Slides.Count >= Cmb2 + 1 Then '規定スライド数に到達
            Exit For
        Else
             
         Rw = Application.Match(N順位, Rndm, 0) + 1 'N順位がある行番号を取得する
             
           If Wsh.Cells(Rw, "I").Value = Catg Then 'カテゴリーが一致したら・・
           Set NewSldR = PpPrs.Slides(1).Duplicate
               NewSldR.MoveTo toPos:=PpPrs.Slides.Count
                 
              Set ShpPic = NewSldR.Shapes.AddPicture(Filename:="C:\Users\Owner\Desktop\イラスト\" & Wsh.Cells(Rw, 9).Value & "\" & Wsh.Cells(Rw, 10).Value, _
                                                     LinkToFile:=msoFalse, _
                                                     SaveWithDocument:=msoTrue, _
                                                     Left:=200, _
                                                     Top:=60, _
                                                     Width:=450, _
                                                     Height:=300)
            End If
        End If
    Next N順位
     
   Set PpPrs = Nothing
   Set PpApp = Nothing
End Sub

回答
投稿日時: 17/12/13 07:38:16
投稿者: んなっと

Sub スライド作成_Click2()
   
  Dim ShpPic As PowerPoint.Shape, myShp As PowerPoint.Shape
  Dim PpApp As New PowerPoint.Application
  Dim PpPrs As PowerPoint.Presentation
  Dim lastRow As Long
  Dim NewSldR As PowerPoint.SlideRange
  Dim bhvEff As AnimationBehavior
  Dim EW As String
  Dim myRng As Range, myEff As Effect
  Dim Wsh As Worksheet
  Dim Catg, Cmb2
  Dim Rw As Long, N順位 As Long, j As Long
  Dim Rndm
  Dim colCnt As Long
  Dim Str As String
  Dim myLeft As Single, myTop As Single, myWidth As Single, myHeight As Single
  Dim myIntv As Single, fntS As Single
  Set Wsh = Worksheets("Words")
  lastRow = Wsh.Cells(Rows.Count, 1).End(xlUp).Row
   
  'ランダム順取得
  With Wsh.Range("K2").Resize(lastRow - 1)
    .Formula = "=RAND()"
    Rndm = Application.Rank(.Cells, .Cells)
    .Value = Rndm
  End With
   
  PpApp.Visible = msoCTrue
  Set PpPrs = PpApp.Presentations.Open(ThisWorkbook.Path & "\スライド.pptx")
  Rw = 1 '初期化
  Catg = Worksheets("Database").ComboBox1.Value
  Cmb2 = Worksheets("Words").ComboBox2.Value
  myIntv = 100
  myTop = PpPrs.PageSetup.SlideHeight * 0.7
  myWidth = 50
  myHeight = 30
  fntS = 32
  'コンボ2の値までスライドを複製する
  For N順位 = 1 To lastRow - 1
    If PpPrs.Slides.Count >= Cmb2 + 1 Then '規定スライド数に到達
      Exit For
      Else
       
      Rw = Application.Match(N順位, Rndm, 0) + 1 'N順位がある行番号を取得する
       
      If Wsh.Cells(Rw, "I").Value = Catg Then 'カテゴリーが一致したら・・
        Set NewSldR = PpPrs.Slides(1).Duplicate
        NewSldR.MoveTo toPos:=PpPrs.Slides.Count
        colCnt = WorksheetFunction.CountIf(Wsh.Cells(Rw, 2).Resize(, 7), "?*")
        myLeft = PpPrs.PageSetup.SlideWidth / 2 - myIntv * colCnt / 2 _
                                                + (myIntv - myWidth) / 2
        For j = 2 To colCnt + 1
          Str = Wsh.Cells(Rw, j).Value
          With NewSldR.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                      myLeft, myTop, myWidth, myHeight).TextFrame
            .TextRange.Text = Str
            .TextRange.Font.Size = fntS
            .HorizontalAnchor = msoAnchorCenter
          End With
          myLeft = myLeft + myIntv
        Next j
        Set ShpPic = NewSldR.Shapes.AddPicture(Filename:="C:\Users\Owner\Desktop\イラスト\" & Wsh.Cells(Rw, 9).Value & "\" & Wsh.Cells(Rw, 10).Value, _
                          LinkToFile:=msoFalse, _
                          SaveWithDocument:=msoTrue, _
                          Left:=200, _
                          Top:=60, _
                          Width:=450, _
                          Height:=300)
      End If
    End If
  Next N順位
   
  Set PpPrs = Nothing
  Set PpApp = Nothing
End Sub

投稿日時: 17/12/13 15:03:27
投稿者: えび天

んなっと様
 
ありがとうございます。
本当に自分の思い描いている通りに表示されました。
 
微調整をしているところなのですが、
テキストボックスの大きさはどこで変更すればよろしいでしょうか。
 
というのも、例のところできちんと示していなかった私が悪いのですが
B〜Hのセルには文字数が不規則で入っています。(すみません、あ、い、う等で書いてしまって…)
2文字入っているところがテキストボックスで縦に入ってしまうので横並びにしたいです。
mywidthに数値を入れたところ大きくはなるのですが、縦のままでした。
 
お手数おかけしてすみません。
よろしくお願いいたします。

回答
投稿日時: 17/12/13 16:05:48
投稿者: んなっと

文字数が異なるなら整列(Distribute)を使ったほうがいいですね。
myLeftの計算が無駄になりました。
 
Sub スライド作成_Click2()
   
  Dim ShpPic As PowerPoint.Shape, myShp As PowerPoint.Shape
  Dim PpApp As New PowerPoint.Application
  Dim PpPrs As PowerPoint.Presentation
  Dim lastRow As Long
  Dim NewSldR As PowerPoint.SlideRange
  Dim bhvEff As AnimationBehavior
  Dim EW As String
  Dim myRng As Range, myEff As Effect
  Dim Wsh As Worksheet
  Dim Catg, Cmb2
  Dim Rw As Long, N順位 As Long, j As Long
  Dim Rndm
  Dim colCnt As Long
  Dim Str As String
  Dim myLeft As Single, myTop As Single, myWidth As Single, myHeight As Single
  Dim myIntv As Single, fntS As Single
  Dim ShpName() As String
  Set Wsh = Worksheets("Words")
  lastRow = Wsh.Cells(Rows.Count, 1).End(xlUp).Row
   
  'ランダム順取得
  With Wsh.Range("K2").Resize(lastRow - 1)
    .Formula = "=RAND()"
    Rndm = Application.Rank(.Cells, .Cells)
    .Value = Rndm
  End With
   
  PpApp.Visible = msoCTrue
  Set PpPrs = PpApp.Presentations.Open(ThisWorkbook.Path & "\スライド.pptx")
  Rw = 1 '初期化
  Catg = Worksheets("Database").ComboBox1.Value
  Cmb2 = Worksheets("Words").ComboBox2.Value
  myIntv = 100
  myTop = PpPrs.PageSetup.SlideHeight * 0.7
  myWidth = 50
  myHeight = 30
  fntS = 32
  'コンボ2の値までスライドを複製する
  For N順位 = 1 To lastRow - 1
    If PpPrs.Slides.Count >= Cmb2 + 1 Then '規定スライド数に到達
      Exit For
      Else
       
      Rw = Application.Match(N順位, Rndm, 0) + 1 'N順位がある行番号を取得する
       
      If Wsh.Cells(Rw, "I").Value = Catg Then 'カテゴリーが一致したら・・
        Set NewSldR = PpPrs.Slides(1).Duplicate
        NewSldR.MoveTo toPos:=PpPrs.Slides.Count
        colCnt = WorksheetFunction.CountIf(Wsh.Cells(Rw, 2).Resize(, 7), "?*")
        If colCnt > 0 Then
          myLeft = PpPrs.PageSetup.SlideWidth / 2 - myIntv * colCnt / 2 _
                                                  + (myIntv - myWidth) / 2
          ReDim ShpName(1 To colCnt)
          For j = 1 To colCnt
            Str = Wsh.Cells(Rw, j + 1).Value
            With NewSldR.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                        myLeft, myTop, myWidth, myHeight)
              ShpName(j) = .Name
              With .TextFrame
                .HorizontalAnchor = msoAnchorCenter
                .WordWrap = msoFalse
                .AutoSize = ppAutoSizeShapeToFitText
                .TextRange.ParagraphFormat.Alignment = ppAlignCenter
                .TextRange.Text = Str
                .TextRange.Font.Size = fntS
              End With
            End With
            myLeft = myLeft + myIntv
          Next j
          NewSldR.Shapes.Range(ShpName).Distribute msoDistributeHorizontally, True
          Set ShpPic = NewSldR.Shapes.AddPicture(Filename:="C:\Users\Owner\Desktop\イラスト\" & Wsh.Cells(Rw, 9).Value & "\" & Wsh.Cells(Rw, 10).Value, _
                            LinkToFile:=msoFalse, _
                            SaveWithDocument:=msoTrue, _
                            Left:=200, _
                            Top:=60, _
                            Width:=450, _
                            Height:=300)
        End If
      End If
    End If
  Next N順位
   
  Set PpPrs = Nothing
  Set PpApp = Nothing
End Sub
 
 

          NewSldR.Shapes.Range(ShpName).Distribute msoDistributeHorizontally, True
 
の部分を以下に変えると、数が少ない場合になるべく真ん中寄りで配置します。
 
          If colCnt > 2 Then
            NewSldR.Shapes.Range(ShpName).Distribute msoDistributeHorizontally, False
          End If

投稿日時: 17/12/13 17:16:44
投稿者: えび天

んなっと様
 
本当にありがとうございます。ちょうどいい幅で配置することができました。
 
たいへん厚かましいのですが、
このバラバラに配置したテキストボックスにアニメーションをつけたいです。
----------------------------------------------------------------------------------------
 With PpPrs.Slides(PpPrs.Slides.Count).TimeLine.MainSequence.AddEffect(Shape:=myShp, _
                                                       effectid:=msoAnimEffectChangeFontColor, _
                                                       Level:=msoAnimateTextByFirstLevel, _
                                                       trigger:=msoAnimTriggerOnPageClick)
                                                        .EffectParameters.Color2.RGB = RGB(200, 0, 0)
                                                        .Timing.Duration = 0.1
                                                        .Timing.SmoothEnd = msoFalse
 
End With
-----------------------------------------------------------------------------------------
このようなアニメーションを各スライドに配置したテキストボックスひとつひとつに
適用したいのですがどうすればよいでしょうか。
【イメージ】
Enterキーを押すと一番左のTextBoxの文字が赤くなる

次のEnterで最初のTextBox赤字は黒に戻って、左から2番目のTextBoxの文字が赤くなる。

次のEnterで2番目のTextBoxは黒に戻って、左から3番目のTextBoxの文字が赤くなる

スライド上のテキストボックスが3つだった場合、次のEnterで次のスライドへ
以下、繰り返し
 
For〜Nextでテキストボックスの数を変数にしてみたのですが、最初の一つ以外適用されませんでした。
そして、赤くなった文字は次のEnterで元には戻りませんでした。
助けていただいているのに、次から次へと申し訳ございません。
どうか、よろしくお願いします。

回答
投稿日時: 17/12/13 21:45:13
投稿者: んなっと

Sub スライド作成_Click2()
   
  Dim ShpPic As PowerPoint.Shape, Shp As PowerPoint.Shape
  Dim PpApp As PowerPoint.Application
  Dim ppPre As PowerPoint.Presentation
  Dim Pre As PowerPoint.Presentation
  Dim lastRow As Long
  Dim NewSldR As PowerPoint.SlideRange
  Dim bhvEff As AnimationBehavior
  Dim EW As String
  Dim myRng As Range, myEff As Effect
  Dim Wsh As Worksheet
  Dim Catg, Cmb2
  Dim Rw As Long, N順位 As Long, i As Long, j As Long
  Dim Rndm
  Dim colCnt As Long
  Dim Str As String
  Dim myLeft As Single, myTop As Single, myWidth As Single, myHeight As Single
  Dim myIntv As Single, fntS As Single
  Dim ShpName() As String
  Dim Sld As PowerPoint.Slide
  Dim tmpShp As PowerPoint.Shape
   
  Set Wsh = Worksheets("Words")
  lastRow = Wsh.Cells(Rows.Count, 1).End(xlUp).Row
   
  'ランダム順取得
  With Wsh.Range("K2").Resize(lastRow - 1)
    .Formula = "=RAND()"
    Rndm = Application.Rank(.Cells, .Cells)
    .Value = Rndm
  End With
  Set PpApp = New PowerPoint.Application
  PpApp.Visible = msoCTrue
   
  'アニメーションコピー元テキストボックス作成
  Set Pre = PpApp.Presentations.Add
  Set Sld = Pre.Slides.Add(1, ppLayoutBlank)
  Set tmpShp = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
              10, 10, 10, 10)
  With Sld.TimeLine.MainSequence.AddEffect(Shape:=tmpShp, _
        effectid:=msoAnimEffectChangeFontColor, _
        Level:=msoAnimateTextByFirstLevel, _
        trigger:=msoAnimTriggerOnPageClick)
    .EffectParameters.Color2 = vbRed
    .Timing.TriggerType = msoAnimTriggerWithPrevious
    .Timing.Duration = 0.1
    .Timing.SmoothEnd = msoFalse
  End With
  tmpShp.Cut
  Set Sld = Pre.Slides.Add(2, ppLayoutBlank)
  Set tmpShp = Sld.Shapes.Paste(1)
  With Sld.TimeLine.MainSequence.AddEffect(Shape:=tmpShp, _
        effectid:=msoAnimEffectChangeFontColor, _
        Level:=msoAnimateTextByFirstLevel, _
        trigger:=msoAnimTriggerOnPageClick)
    .EffectParameters.Color2 = vbBlack
    .Timing.Duration = 0.1
    .Timing.SmoothEnd = msoFalse
  End With
  tmpShp.PickupAnimation
   
  Set ppPre = PpApp.Presentations.Open(ThisWorkbook.Path & "\スライド.pptx")
  Rw = 1 '初期化
  Catg = Worksheets("Database").ComboBox1.Value
  Cmb2 = Worksheets("Words").ComboBox2.Value
  myIntv = 100
  myTop = ppPre.PageSetup.SlideHeight * 0.7
  myWidth = 50
  myHeight = 30
  fntS = 32
  'コンボ2の値までスライドを複製する
  For N順位 = 1 To lastRow - 1
    If ppPre.Slides.Count >= Cmb2 + 1 Then '規定スライド数に到達
      Exit For
      Else
       
      Rw = Application.Match(N順位, Rndm, 0) + 1 'N順位がある行番号を取得する
       
      If Wsh.Cells(Rw, "I").Value = Catg Then 'カテゴリーが一致したら・・
        Set NewSldR = ppPre.Slides(1).Duplicate
        NewSldR.MoveTo toPos:=ppPre.Slides.Count
        colCnt = WorksheetFunction.CountIf(Wsh.Cells(Rw, 2).Resize(, 7), "?*")
        If colCnt > 0 Then
          myLeft = ppPre.PageSetup.SlideWidth / 2 - myIntv * colCnt / 2 _
                                                  + (myIntv - myWidth) / 2
          ReDim ShpName(1 To colCnt)
          For j = 1 To colCnt
            Str = Wsh.Cells(Rw, j + 1).Value
            Set Shp = NewSldR.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                        myLeft, myTop, myWidth, myHeight)
            With Shp
              ShpName(j) = .Name
              With .TextFrame
                .HorizontalAnchor = msoAnchorCenter
                .WordWrap = msoFalse
                .AutoSize = ppAutoSizeShapeToFitText
                .TextRange.ParagraphFormat.Alignment = ppAlignCenter
                .TextRange.Text = Str
                .TextRange.Font.Size = fntS
              End With
              .ApplyAnimation
            End With
            myLeft = myLeft + myIntv
          Next j
          NewSldR.Shapes.Range(ShpName).Distribute msoDistributeHorizontally, True
          NewSldR.TimeLine.MainSequence(1).Timing.TriggerType = msoAnimTriggerOnPageClick
          Set ShpPic = NewSldR.Shapes.AddPicture(Filename:="C:\Users\Owner\Desktop\イラスト\" & Wsh.Cells(Rw, 9).Value & "\" & Wsh.Cells(Rw, 10).Value, _
                            LinkToFile:=msoFalse, _
                            SaveWithDocument:=msoTrue, _
                            Left:=200, _
                            Top:=60, _
                            Width:=450, _
                            Height:=300)
        End If
      End If
    End If
  Next N順位
  Pre.Saved = msoTrue
  Pre.Close
  Set Pre = Nothing
  Set ppPre = Nothing
  Set PpApp = Nothing
End Sub

投稿日時: 17/12/14 14:57:30
投稿者: えび天

 
んなっと様
本当にありがとうございます。
全て思い通りになりました。
 
立ち上がるスライドなのですが,
powerpointが2つ立ち上がり,1つはパス通りのファイルのもので,
もう1つは白紙のものが立ち上がります。
どのように編集すればよろしいでしょうか。
 
よろしくお願いいたします。

回答
投稿日時: 17/12/14 15:49:46
投稿者: んなっと

Sub スライド作成_Click2()
   
  Dim ShpPic As PowerPoint.Shape, Shp As PowerPoint.Shape
  Dim PpApp As PowerPoint.Application
  Dim ppPre As PowerPoint.Presentation
  Dim lastRow As Long
  Dim NewSldR As PowerPoint.SlideRange
  Dim bhvEff As AnimationBehavior
  Dim EW As String
  Dim myRng As Range, myEff As Effect
  Dim Wsh As Worksheet
  Dim Catg, Cmb2
  Dim Rw As Long, N順位 As Long, i As Long, j As Long
  Dim Rndm
  Dim colCnt As Long
  Dim Str As String
  Dim myLeft As Single, myTop As Single, myWidth As Single, myHeight As Single
  Dim myIntv As Single, fntS As Single
  Dim ShpName() As String
  Dim Sld As PowerPoint.Slide
  Dim tmpShp As PowerPoint.Shape
   
  Set Wsh = Worksheets("Words")
  lastRow = Wsh.Cells(Rows.Count, 1).End(xlUp).Row
   
  'ランダム順取得
  With Wsh.Range("K2").Resize(lastRow - 1)
    .Formula = "=RAND()"
    Rndm = Application.Rank(.Cells, .Cells)
    .Value = Rndm
  End With
  Set PpApp = New PowerPoint.Application
  PpApp.Visible = msoCTrue
 
   
  Set ppPre = PpApp.Presentations.Open(ThisWorkbook.Path & "\スライド.pptx")
    'アニメーションコピー元テキストボックス作成
  Set Sld = ppPre.Slides(1)
  Set tmpShp = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
              10, 10, 10, 10)
  With Sld.TimeLine.MainSequence.AddEffect(Shape:=tmpShp, _
        effectid:=msoAnimEffectChangeFontColor, _
        Level:=msoAnimateTextByFirstLevel, _
        trigger:=msoAnimTriggerOnPageClick)
    .EffectParameters.Color2 = vbRed
    .Timing.TriggerType = msoAnimTriggerWithPrevious
    .Timing.Duration = 0.1
    .Timing.SmoothEnd = msoFalse
  End With
  tmpShp.Cut
  Set Sld = ppPre.Slides.Add(2, ppLayoutBlank)
  Set tmpShp = Sld.Shapes.Paste(1)
  With Sld.TimeLine.MainSequence.AddEffect(Shape:=tmpShp, _
        effectid:=msoAnimEffectChangeFontColor, _
        Level:=msoAnimateTextByFirstLevel, _
        trigger:=msoAnimTriggerOnPageClick)
    .EffectParameters.Color2 = vbBlack
    .Timing.Duration = 0.1
    .Timing.SmoothEnd = msoFalse
  End With
  tmpShp.PickupAnimation
   
  Rw = 1 '初期化
  Catg = Worksheets("Database").ComboBox1.Value
  Cmb2 = Worksheets("Words").ComboBox2.Value
  myIntv = 100
  myTop = ppPre.PageSetup.SlideHeight * 0.7
  myWidth = 50
  myHeight = 30
  fntS = 32
  'コンボ2の値までスライドを複製する
  For N順位 = 1 To lastRow - 1
    If ppPre.Slides.Count >= Cmb2 + 1 Then '規定スライド数に到達
      Exit For
      Else
       
      Rw = Application.Match(N順位, Rndm, 0) + 1 'N順位がある行番号を取得する
       
      If Wsh.Cells(Rw, "I").Value = Catg Then 'カテゴリーが一致したら・・
        Set NewSldR = ppPre.Slides(1).Duplicate
        NewSldR.MoveTo toPos:=ppPre.Slides.Count
        colCnt = WorksheetFunction.CountIf(Wsh.Cells(Rw, 2).Resize(, 7), "?*")
        If colCnt > 0 Then
          myLeft = ppPre.PageSetup.SlideWidth / 2 - myIntv * colCnt / 2 _
                                                  + (myIntv - myWidth) / 2
          ReDim ShpName(1 To colCnt)
          For j = 1 To colCnt
            Str = Wsh.Cells(Rw, j + 1).Value
            Set Shp = NewSldR.Shapes.AddTextbox(msoTextOrientationHorizontal, _
                        myLeft, myTop, myWidth, myHeight)
            With Shp
              ShpName(j) = .Name
              With .TextFrame
                .HorizontalAnchor = msoAnchorCenter
                .WordWrap = msoFalse
                .AutoSize = ppAutoSizeShapeToFitText
                .TextRange.ParagraphFormat.Alignment = ppAlignCenter
                .TextRange.Text = Str
                .TextRange.Font.Size = fntS
              End With
              .ApplyAnimation
            End With
            myLeft = myLeft + myIntv
          Next j
          NewSldR.Shapes.Range(ShpName).Distribute msoDistributeHorizontally, True
          NewSldR.TimeLine.MainSequence(1).Timing.TriggerType = msoAnimTriggerOnPageClick
          Set ShpPic = NewSldR.Shapes.AddPicture(Filename:="C:\Users\Owner\Desktop\イラスト\" & Wsh.Cells(Rw, 9).Value & "\" & Wsh.Cells(Rw, 10).Value, _
                            LinkToFile:=msoFalse, _
                            SaveWithDocument:=msoTrue, _
                            Left:=200, _
                            Top:=60, _
                            Width:=450, _
                            Height:=300)
        End If
      End If
    End If
  Next N順位
   
  Sld.Delete
  Set ppPre = Nothing
  Set PpApp = Nothing
End Sub

投稿日時: 17/12/14 16:25:36
投稿者: えび天

 
んなっと様
 
Set ppPre = PpApp.Presentations.Open(ThisWorkbook.Path & "\スライド.pptx")
の位置を変えるだけだったのですね。
ありがとうございます。
 
これまでたくさんお手数をおかけしました。
PowerPointのVBAの参考になるものがなかなか少なくて
困っていましたが,んなっと様のおかげで非常に助かりました。
 
コードの中に知らないものがたくさんあったので
教えていただいたものを理解できるように勉強していきたいと思います。
 
またご縁がありましたらよろしくお願いいたします。
本当にありがとうございました。