ExcelVBAでxlsからpptの表をいじる

## コード xls
``` vb
Option Explicit

Const pptPath = フルパス

Sub pptをいじる()
  'pptひな形を別名保存
    Dim pptPathNew: pptPathNew = 別名保存(pptPath, "テスト")
  
  ' ppt準備
    Dim ppApp As New PowerPoint.Application
    ppApp.Visible = True
    Dim ppPrs
    Set ppPrs = PowerPointファイルを開く(ppApp, ppPrs, pptPathNew)
  
  'いじるテーブルをセットする
    Dim TableObj, ObjName
    ObjName = "test"    '事前にppt側でObj名を付けておく必要があるが、ページ数など無視して取得できる
    Set TableObj = SeachObj(ppPrs, ObjName).Table
'    Set TableObj = GetObjName(ppPrs).Table
  
  
  '  ' 行の追加　最終行のみ？
  '  Call TableAddRow(TableObj)
  '
  '  ' 行の削除　こっちは行指定可能
  '  Dim RowNom
  '  RowNom = 5
  '  Call TableDelRow(TableObj, RowNom)
    
'  ' テーブルに値を入れていく
'    Dim Arr: Arr = Cells(5, 1).Resize(5, 2)
'    Call EditTableVal(TableObj, 2, 1, Arr)
  
'  ' 指定セルを結合
'    Call MergeCells(TableObj, 2, 5, 5, 8, True) 'args(TableObj, rBottomp , cLeft , rBottom , cRight , 第一セル以外の値を消すか)
    Call 上のセルと値が同じなら結合する(TableObj, 6, 2)
    

  
  Set ppApp = Nothing
End Sub

Sub 上のセルと値が同じなら結合する(TableObj, r As Long, c As Long)
  Dim r1: r1 = TableObj.Cell(r - 1, c).Shape.TextFrame.TextRange.Text
  Dim r2: r2 = TableObj.Cell(r, c).Shape.TextFrame.TextRange.Text
  If r2 = r1 Then: Call MergeCells(TableObj, r - 1, c, r, c, True)
End Sub

Private Sub MergeCells(TableObj, _
                        rBottomp As Long, cLeft As Long, _
                        rBottom As Long, cRight As Long, _
                        MergeYesNo As Boolean)
  ' 左上のセル1つの中身を残して、指定範囲のセルを結合する
  With TableObj
    'MergeYesNoがTrueなら子セルの中身を消す
      If MergeYesNo = True Then
        Dim r, c, buf
        buf = .Cell(rBottomp, cLeft).Shape.TextFrame.TextRange.Text
        For r = rBottomp To rBottom
          For c = cLeft To cRight
          .Cell(r, c).Shape.TextFrame.TextRange.Text = ""
          Next
        Next
        .Cell(rBottomp, cLeft).Shape.TextFrame.TextRange.Text = buf
      End If
    '結合する
      .Cell(rBottomp, cLeft).Merge MergeTo:=.Cell(rBottom, cRight)
  End With
End Sub

Sub EditTableVal(TableObj, r_Top, c_Left, Arr)
  Dim ubR: ubR = UBound(Arr, 1)
  Dim ubC: ubC = UBound(Arr, 2)
  Stop
  With TableObj
    Dim r As Long, c As Long
    For r = 1 To ubR
      For c = 1 To ubC
        .Cell(r + r_Top - 1, c + c_Left - 1).Shape.TextFrame.TextRange.Text = Arr(r, c)

      Next c
    Next r
  End With

End Sub

Private Function 別名保存(TargetFilePath As String, NewName As String)
  Dim DirPath: DirPath = ThisWorkbook.Path
  Dim pptNewPath
  pptNewPath = DirPath & "\" & NewName & ".pptm"
  
  FileCopy TargetFilePath, pptNewPath
  
  別名保存 = pptNewPath
End Function




Private Function SeachObj(ppPrs, ObjName)
 ' スライド、シェイプインデックス未知の時、
 ' 指定シェイプ名を探して返す
 Dim sld, shp
  For Each sld In ppPrs.Slides
    For Each shp In sld.Shapes
      If shp.Name = ObjName Then
        Set SeachObj = shp
        Exit Function
      End If
    Next
  Next

End Function

Private Function PowerPointファイルを開く(ppApp, ppPrs, pptPath)
  Set ppPrs = ppApp.Presentations.Open(pptPath) 'プレゼンテーションを開く
  Set PowerPointファイルを開く = ppPrs
End Function




Private Function GetObjName(ppPrs)  'スライド、シェイプインデックス既知用
  Dim TableObj
  Set TableObj = ppPrs.Slides("Slide22").Shapes("Table 2")
  Debug.Print TableObj.Name
  Set GetObjName = TableObj
End Function

Private Sub TableAddRow(TableObj) ' 行の追加　最終行のみ？
  With TableObj
    .Rows.Add
  End With
End Sub

Private Sub TableDelRow(TableObj, RowNom) ' 行の削除　こっちは行指定可能
  With TableObj
    .Rows(1).Delete
  End With
End Sub


Private Sub EditTableValTest(TableObj) ' テーブルに値を入れていく
  With TableObj
    Dim r As Long, c As Long
    For r = 1 To .Rows.Count
      For c = 1 To .Columns.Count
        .Cell(r, c).Shape.TextFrame.TextRange.Text = r & "行" & c & "列"

      Next c
    Next r
  End With

End Sub

Private Sub EditTableVal_Sample(TableObj) ' テーブルに値を入れていく
  With TableObj
    Dim r As Long, c As Long
    For r = 1 To .Rows.Count
      For c = 1 To .Columns.Count
        .Cell(r, c).Shape.TextFrame.TextRange.Text = r & "行" & c & "列"

      Next c
    Next r
  End With

End Sub

```

## ppt アドイン化
参考：

https://ppdtp.com/powerpoint/macro-custom-ui/#toc12

### rels
```
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">
<Relationship Id="rId3" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Target="docProps/core.xml"/>
<Relationship Id="rId2" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/thumbnail" Target="docProps/thumbnail.jpeg"/>
<Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Target="ppt/presentation.xml"/>
<Relationship Id="rId4" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Target="docProps/app.xml"/>
<Relationship Id="myCustomUI" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility" Target="customUI.xml"/>
</Relationships>
```

### xml 
customUI.xml

``` xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<ribbon startFromScratch="false">
<tabs>
<tab id="MyTab1" label="自作pptマクロ">

<group id="Group1" label="シェイプ名操作">
<button id="Button1-1" label="シェイプ名 変更" imageMso="MacroPlay" size="normal" onAction="SetShapeName" />
<button id="Button1-2" label="シェイプ名 取得" imageMso="MacroPlay" size="normal" onAction="GetShapeName" />
</group>

</tab>
</tabs>
</ribbon>
</customUI>
```