ゴリラストロングの雑記帳

月収10万円の広告収入を目指す自称専業ライターのブログです。




【Excel VBA】PowerPoint(PPT)スライドの作成ツール。LINEメッセージ風。




どうも、ゴリラストロングです。

 

 

今回は、LINEメッセージ風のPowerPoint(PPT)スライドの作成ツールを作成してみました。

 

 

<動画>


【Excel VBA】PowerPoint(PPT)スライドの作成ツール。LINEメッセージ風。【ゴリラストロングの雑記帳】

 

最終的に動画のようなLINE風メッセージのパワポのスライドが完成します。

 

<元データ>

f:id:gorilla-strong:20200308124126p:plain

<マクロ①実行後>

f:id:gorilla-strong:20200308124234p:plain

このように、元データのやり取りがオートシェイプに転記されます。

 

 

<マクロ②実行後>

f:id:gorilla-strong:20200308124510p:plain

デザインは手動で変更していますが、オートシェイプが上から順番にパワポのスライドに貼り付けられます。

これで、スライドショーを実行すればLINEメッセージ風のやり取りのような動画になります。

 

 

 

 スポンサーリンク

 

 

 

ソースコード①>

Sub ライン風()

Dim yyt, asp As Object
Set yyt = Workbooks("ライン風.xlsm").Worksheets("やりとり")
Set asp = Workbooks("ライン風.xlsm").Worksheets("オートシェイプ")

Dim lastrowj As Long
lastrowj = yyt.Cells(Rows.Count, 1).End(xlUp).Row

Dim num As Long
num = WorksheetFunction.CountA(yyt.Range("A:D")) / 2 - 2

Dim mytime, mytext As String





For i = 2 To num + 1



If yyt.Range("A" & i) <> "" Then
    mytime = yyt.Range("A" & i)
    mytext = yyt.Range("B" & i)
ElseIf yyt.Range("A" & i) = "" Then
    mytime = yyt.Range("A" & i).Offset(0, 2)
    mytext = yyt.Range("B" & i).Offset(0, 2)
ElseIf yyt.Range("A" & i + 1) <> "" Then
    mytime = yyt.Range("A" & i + 1)
    mytext = yyt.Range("B" & i + 1)

End If





With asp.Range("B3:O15")
    asp.Shapes.AddShape(Type:=msoShapeRoundedRectangle, _
    Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select
End With

asp.Activate

Selection.Text = mytime & " " & mytext

asp.Shapes(i - 1).Fill.ForeColor.RGB = RGB(0, 255, 0)

asp.Shapes(i - 1).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)

asp.Shapes(i - 1).TextFrame.Characters.Font.Bold = True

asp.Shapes(i - 1).TextFrame.Characters.Font.Size = 45

asp.Shapes(i - 1).Line.Visible = msoFalse

Next

End Sub

 

 

ソースコード②>

Sub パワポ転記()

Dim asp As Object
Set asp = Workbooks("ライン風.xlsm").Worksheets("オートシェイプ")

Dim aspnum As Long
aspnum = asp.Shapes.Count

Dim ppapp As New PowerPoint.Application
ppapp.Visible = True

Dim ppprs As PowerPoint.Presentation
Set ppprs = ppapp.Presentations.Add(WithWindow:=True)

For i = 1 To aspnum

Dim ppsld As Object
Set ppsld = ppprs.Slides.Add(Index:=1, Layout:=12)

Next



For j = 1 To aspnum

asp.Shapes(j).CopyPicture xlScreen, xlPicture
ppprs.Slides(j).Shapes.Paste

Next



End Sub

 

ソースコード①のIF文の条件分岐がかなり難しかったです。

以上、ゴリラストロングでした。


 

 スポンサーリンク