Yasumo_PPT_Sub

Sub nowを書く複数()

Dim sd As Slide

Dim n As Long

Dim s As String

Dim sname As String

Dim k As Long, kk As Long

Dim shp As Shape

sname = ActivePresentation.Path + vbCrLf + ActivePresentation.Name

For Each shp In ActivePresentation.Slides(1).Shapes

'MsgBox shp.Name

If shp.Name = "Title 1" Then

s = "☆☆☆☆☆" + vbCrLf + "【ppt　１枚目タイトル　】" + shp.TextFrame.TextRange.Text

Exit For

Else

If shp.HasTextFrame Then

If shp.TextFrame.HasText Then

s = s + vbCr + vbLf + shp.TextFrame.TextRange.Text

End If

End If

End If

Next shp

' https://tonari-it.com/powerpoint-vba-selection-type/

'If ActiveWindow.Selection.PpSelectionType = ppSelectionSlides Then

Debug.Print ("#####")

Debug.Print (ActiveWindow.Selection.SlideRange.Count)

For Each rg In ActiveWindow.Selection.SlideRange

n = rg.SlideIndex

s = s + vbCrLf + Format(Now, "yyyy/mm/dd:hh:mm:ss") + "作成" + Chr(13) + sname + Chr(13) + "Slide ID=" + Format(rg.SlideID, "0") + Chr(13)

's = s + vbCrLf + Format(Now, "yyyy/mm/dd:hh:mm:ss") + "作成" + Chr(13) + sname + Chr(13) + "Slide ID=" + Format(ActiveWindow.Selection.SlideRange.SlideID, "0") + Chr(13)

s = s + "スライド名：" + ActivePresentation.Slides(n).Name + vbCrLf + "☆☆☆☆☆ ☆☆☆☆☆" + vbCrLf + vbCrLf + vbCrLf

With ActivePresentation.Slides(n)

kk = 2

If .NotesPage.Shapes(kk).Name = "Notes Placeholder 2" Then

Else

kk = 0

For k = 1 To .NotesPage.Shapes.Count

If .NotesPage.Shapes(k).Name = "Notes Placeholder 2" Then

kk = k

Exit For

End If

Next k

If kk = 0 Then

MsgBox "NotesPageが見つかりませんでした。なんの成果も得られませんでしたが　終了いたします"

Exit Sub

End If

End If

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

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

End With

Next rg

End Sub

rem Class module として定義 　新しいスライドが作られたときにイベントを発生

rem Class moudule にYasumoClass1として定義する

Option Explicit

Public WithEvents App As PowerPoint.Application

Private Sub App_PresentationNewSlide(ByVal sd As Slide)

Dim sname As String, s As String, n As Long, nn As Long

sd.Parent.Windows(1).Activate

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

ActiveWindow.View.GotoSlide (sd.SlideIndex)

nn = ActivePresentation.Slides.Count

sname = "----------------" + vbCrLf

sname = sname + "【このスライドが初めて作成された日 : " + s + " 】" + vbCrLf

sname = sname + Format(nn, "0") + "枚目のスライドとして作成されました" + vbCrLf

sname = sname + ActivePresentation.Path + vbCrLf + ActivePresentation.Name + vbCrLf + "----------------" + vbCrLf

n = ActiveWindow.Selection.SlideRange.SlideIndex

With ActivePresentation.Slides(n)

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

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

End With

End Sub

Private Sub App_PresentationBeforeSave(ByVal Pres As Presentation, Cancel As Boolean)

Dim sname As String, s As String, n As Long, nn As Long

Dim w As DocumentWindow, w2 As DocumentWindow

Rem nn = ActiveWindow.Selection.SlideRange.SlideIndex

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

Set w = ActiveWindow

Set w2 = w.NewWindow

w2.Activate

ActiveWindow.View.GotoSlide (1)

sname = "----------------" + vbCrLf

sname = sname + "【保存しようとしています: " + s + " 】" + vbCrLf

sname = sname + ActivePresentation.Path + vbCrLf + ActivePresentation.Name + vbCrLf + "----------------" + vbCrLf

n = ActiveWindow.Selection.SlideRange.SlideIndex

With ActivePresentation.Slides(n)

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

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

End With

Rem ActiveWindow.View.GotoSlide (nn)

w2.Close

w.Activate

End Sub

rem time log のRestart

Public Sub ReStartTimeLog()

Set YasumoEvent = New YasumoClass1

Set YasumoEvent.App = Application

End Sub

Sub HeartOn5()

Dim ans As Long

Debug.Print (ActiveWindow.Selection.Type)

If (ActiveWindow.Selection.Type <> ppSelectionShapes) Then

'MsgBox "なにも選ばれていません"

With ActiveWindow.Selection.SlideRange

Set sp = .Shapes(.Shapes.Count)

End With

'ans = MsgBox("何も選択されていません。", vbAbortRetryIgnore + vbQuestion, "ヤッターマンのメッセージ")

'If ans = vbIgnore Then

' With ActiveWindow.Selection.SlideRange

' Set sp = .Shapes(.Shapes.Count)

' End With

'Else

' Exit Sub

'End If

Else

Set sp = ActiveWindow.Selection.ShapeRange(1)

End If

With sp

.Top = 0

.Left = 33.9 * 72 / 2.54

.Width = 100 * 72 / 2.54

End With

End Sub

Sub HeartOn4()

Rem MsgBox "HeartOn4"

If (ActiveWindow.Selection.Type <> ppSelectionShapes) Then

With ActiveWindow.Selection.SlideRange

Set sp = .Shapes(.Shapes.Count)

End With

Else

Set sp = ActiveWindow.Selection.ShapeRange(1)

End If

Rem MsgBox sp.Name

With sp

.Top = 5 * 72 / 2.54

.Left = 0

.Width = 33 * 72 / 2.54

.Height = 14 * 72 / 2.54

End With

End Sub

Sub MshgTest()

Dim ans As Long

Rem https://dobon.net/vb/dotnet/form/msgbox.html

Rem http://officetanaka.net/excel/vba/function/msgbox.htm

'ans = MsgBox("処理を続けますか？", vbYesNo + vbQuestion + vbIgnore)

ans = MsgBox("何も選択されていません。", vbAbortRetryIgnore + vbQuestion, "ヤッターマンのメッセージ")

MsgBox (ActiveWindow.Selection.SlideRange.SlideIndex)

ans = ActiveWindow.Selection.SlideRange.SlideIndex

MsgBox (ActiveWindow.Selection.SlideRange.Shapes(1).Name)

End Sub

Sub HeartOn3()

Rem MsgBox "HeartOn3"

'/ https://tonari-it.com/powerpoint-vba-selection-type/

'Selectionオブジェクト.Type

'Typeプロパティで取得できるのは以下のppSelectionType列挙で定義されている定数で表される4つの数値です｡

'ppSelectionType 値 スライド シェイプ テキスト

'ppSelectionNone 0 ? ? ?

'ppSelectionSlides 1 1つ以上 ? ?

'ppSelectionShapes 2 1つ 1つ以上 ?

'ppSelectionText 3 1つ 1つ テキスト範囲

Dim ans As Long

Debug.Print (ActiveWindow.Selection.Type)

If (ActiveWindow.Selection.Type <> ppSelectionShapes) Then

'MsgBox "なにも選ばれていません"

With ActiveWindow.Selection.SlideRange

Set sp = .Shapes(.Shapes.Count)

End With

'ans = MsgBox("何も選択されていません。", vbAbortRetryIgnore + vbQuestion, "ヤッターマンのメッセージ")

'If ans = vbIgnore Then

' With ActiveWindow.Selection.SlideRange

' Set sp = .Shapes(.Shapes.Count)

' End With

'Else

' Exit Sub

'End If

Else

Set sp = ActiveWindow.Selection.ShapeRange(1)

End If

Rem MsgBox sp.Name

With sp

.Top = 0

.Left = 0

.Width = 100 * 72 / 2.54

End With

End Sub

Sub HlinkPaste()

'ハイパーリンクPaste

Dim shp2 As Shape

Dim nn As Long

Dim sp As Shape

With ActiveWindow.Selection

If .Type = ppSelectionShapes Or .Type = ppSelectionText Then

Set sp = ActiveWindow.Selection.ShapeRange(1)

Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("TextBox2")

sp.ActionSettings(ppMouseClick).Hyperlink.SubAddress = shp2.TextFrame.TextRange.Text

MsgBox sp.ActionSettings(ppMouseClick).Hyperlink.SubAddress

End If

End With

End Sub

Sub HLinkCopy()

'ハイパーリンクコピー

Dim shp2 As Shape

Dim nn As Long

Dim sp As Shape

With ActiveWindow.Selection

If .Type = ppSelectionShapes Or .Type = ppSelectionText Then

Set sp = ActiveWindow.Selection.ShapeRange(1)

Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("TextBox2")

shp2.TextFrame.TextRange.Text = sp.ActionSettings(ppMouseClick).Hyperlink.SubAddress

MsgBox shp2.TextFrame.TextRange.Text

End If

End With

End Sub

Sub 次()

Dim sd As Slide

Dim itp As PpSelectionType

Dim tp As Double, lft As Double, s As String

Dim sp As Shape, sc As Double, dmy As String

sc = 72 / 2.54

Dim shp2 As Shape, ss As String

Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("TextBox1")

ss = shp2.TextFrame.TextRange.Text

Set sd = ActiveWindow.Selection.SlideRange(1)

itp = ActiveWindow.Selection.Type

If itp = ppSelectionShapes Or itp = ppSelectionText Then

With ActiveWindow.Selection

tp = .ShapeRange.Top

lft = .ShapeRange.Left

End With

Else

tp = 19 * sc

lft = 23 * sc

End If

s = "次（" + Format(Now, "yyyy/mm/dd:hh:mm:ss") + "）→"

Set sp = sd.Shapes.AddShape(msoShapeRightArrow, lft, tp - sc * 2, sc * 10, sc * 2)

sp.TextFrame.TextRange.Text = s

sp.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)

sp.Fill.BackColor.RGB = RGB(204, 0, 0)

sp.Fill.ForeColor.RGB = RGB(204, 255, 255)

sp.Line.ForeColor.RGB = RGB(0, 0, 0)

sp.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink.SubAddress = ss

' https://www.relief.jp/docs/powerpoint-vba-selection-difference-excel.html

'https://msdn.microsoft.com/ja-jp/vba/powerpoint-vba/articles/ppselectiontype-enumeration-powerpoint

'ppSelectionNone 0 なし

'ppSelectionShapes 2 図形

'ppSelectionSlides 1 スライド

'ppSelectionText 3 テキスト 'https://www.relief.jp/docs/017842.html

End Sub

Sub 戻()

Dim sd As Slide

Dim itp As PpSelectionType

Dim tp As Double, lft As Double, s As String

Dim sp As Shape, sc As Double

Dim shp2 As Shape, ss As String

Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("TextBox1")

ss = shp2.TextFrame.TextRange.Text

s = "←戻（" + Format(Now, "yyyy/mm/dd:hh:mm:ss") + "）"

sc = 72 / 2.54

Set sd = ActiveWindow.Selection.SlideRange(1)

itp = ActiveWindow.Selection.Type

With ActiveWindow.Selection

If itp = 3 Or itp = 2 Then

tp = .ShapeRange.Top

lft = .ShapeRange.Left

Set sp = sd.Shapes.AddShape(msoShapeLeftArrow, lft, tp - sc * 2, sc * 10, sc * 2)

Else

If itp = 0 Or itp = 1 Then

tp = 0.2 * sc

lft = 0.2 * sc

Set sp = sd.Shapes.AddShape(msoShapeLeftArrow, lft, tp, sc * 10, sc * 2)

Else

Exit Sub

End If

End If

End With

sp.TextFrame.TextRange.Text = s

sp.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)

sp.Fill.BackColor.RGB = RGB(204, 0, 0)

sp.Fill.ForeColor.RGB = RGB(255, 242, 204)

sp.Line.ForeColor.RGB = RGB(0, 0, 0)

sp.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink.SubAddress = ss

End Sub

Sub 時刻スタンプ()

Dim sd As Slide

Dim itp As PpSelectionType

Dim tp As Double, lft As Double, s As String

Dim sp As Shape, sc As Double

s = "時刻（" + Format(Now, "yyyy/mm/dd:hh:mm:ss") + "）"

sc = 72 / 2.54

Set sd = ActiveWindow.Selection.SlideRange(1)

itp = ActiveWindow.Selection.Type

With ActiveWindow.Selection

If itp = 3 Or itp = 2 Then

tp = .ShapeRange.Top

lft = .ShapeRange.Left

Set sp = sd.Shapes.AddShape(msoShapeRectangle, lft, tp - sc * 2, sc * 10, sc * 2)

Else

If itp = 0 Then

tp = 13 * sc

lft = 22 * sc

Set sp = sd.Shapes.AddShape(msoShapeLeftArrow, lft, tp, sc * 10, sc * 2)

Else

Exit Sub

End If

End If

End With

sp.TextFrame.TextRange.Text = s

sp.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)

sp.Fill.BackColor.RGB = RGB(204, 0, 0)

sp.Fill.ForeColor.RGB = RGB(255, 255, 0)

sp.Line.ForeColor.RGB = RGB(0, 0, 0)

End Sub

Sub IDRegister()

Dim shp2 As Shape

Dim nn As Long

Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("TextBox1")

nn = ActiveWindow.Selection.SlideRange(1).SlideIndex

shp2.ActionSettings(ppMouseClick).Hyperlink.SubAddress = nn

shp2.TextFrame.TextRange.Text = shp2.ActionSettings(ppMouseClick).Hyperlink.SubAddress

End Sub

Public Sub 修正記録を書く()

Dim tp As Double, lft As Double, s As String

MsgBox "HeartOn"

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

With ActiveWindow.Selection

If .Type = ppSelectionNone Or _

.Type = ppSelectionSlides Then Exit Sub

With .ShapeRange

MsgBox .Id & vbCrLf & _

.Name & vbCrLf & _

.Type & vbCrLf & _

.AutoShapeType & vbCrLf & _

.Top & vbCrLf & _

.Left

tp = .Top

lft = .Left

End With

Dim sd As Slide, sp As Shape, sc As Double

sc = 72 / 2.54

Set sd = ActiveWindow.Selection.SlideRange(1)

Set sp = sd.Shapes.AddTextbox(msoTextOrientationHorizontal, lft, tp - sc * 1, sc * 8, sc)

sp.TextFrame.TextRange.Text = s

sp.TextFrame.TextRange.Font.Color = RGB(255, 0, 0)

sp.Fill.BackColor.RGB = RGB(255, 255, 0)

End With

' https://www.relief.jp/docs/018007.html

End Sub

Public Sub 加筆スタンプ(ribbon As IRibbonControl)

'MsgBox "加筆記録を書く"

Dim tp As Double, lft As Double, s As String

Dim sd As Slide, sp As Shape, sc As Double

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

With ActiveWindow.Selection

If .Type = ppSelectionNone Or .Type = ppSelectionSlides Then Exit Sub

tp = .ShapeRange.Top

lft = .ShapeRange.Left

sc = 72 / 2.54

Set sd = ActiveWindow.Selection.SlideRange(1)

Set sp = sd.Shapes.AddTextbox(msoTextOrientationHorizontal, lft, tp - sc * 1, sc * 8, sc)

sp.TextFrame.TextRange.Text = s

sp.TextFrame.TextRange.Font.Color = RGB(0, 0, 0)

sp.Fill.BackColor.RGB = RGB(102, 255, 204)

End With

End Sub

Public Sub 見え消しスタンプ(ribbon As IRibbonControl)

Dim tp As Double, lft As Double, s As String, wd As Double, ht As Double

Dim sd As Slide, sp As Shape, sc As Double

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

With ActiveWindow.Selection

If .Type = ppSelectionNone Or .Type = ppSelectionSlides Then Exit Sub

tp = .ShapeRange.Top

lft = .ShapeRange.Left

wd = .ShapeRange.Width

ht = .ShapeRange.Height

sc = 72 / 2.54

Set sd = ActiveWindow.Selection.SlideRange(1)

Set sp = sd.Shapes.AddShape(msoShapeNoSymbol, lft, tp, wd, ht)

With sp

With .Fill

.Visible = msoTrue

.ForeColor.RGB = RGB(255, 0, 0)

.Transparency = 0.498039186

.Solid

End With

With .Line

.ForeColor.RGB = RGB(255, 0, 0)

.Transparency = 0

.Visible = msoTrue

.Weight = 3

End With

With .TextFrame2.TextRange

.Characters.Text = s

.ParagraphFormat.Alignment = msoAlignCenter

End With

.TextFrame2.VerticalAnchor = msoAnchorMiddle

End With

sp.TextFrame.TextRange.Text = s

sp.TextFrame.TextRange.Font.Color = RGB(255, 255, 0)

sp.Fill.BackColor.RGB = RGB(255, 0, 0)

sp.Fill.Transparency = 0.75

End With

End Sub

Public Sub HeartOn(ribbon As IRibbonControl)

Dim tp As Double, lft As Double, s As String, wd As Double, ht As Double

Dim sd As Slide, sp As Shape, sc As Double

Dim shp2 As Shape, ss As String

Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("TextBox1")

ss = shp2.TextFrame.TextRange.Text

sc = 72 / 2.54

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

With ActiveWindow.Selection

If .Type = ppSelectionNone Or .Type = ppSelectionSlides Then

tp = 0

lft = 0

wd = sc * 5

ht = sc * 5

Else

tp = .ShapeRange.Top

lft = .ShapeRange.Left

wd = .ShapeRange.Width

ht = .ShapeRange.Height

End If

Set sd = ActiveWindow.Selection.SlideRange(1)

Set sp = sd.Shapes.AddShape(msoShapeHeart, lft, tp, wd, ht)

With sp

With .Fill

.Visible = msoTrue

.ForeColor.RGB = RGB(255, 184, 184)

.Transparency = 0.61

.Solid

End With

With .Line

.ForeColor.RGB = RGB(255, 0, 0)

.Transparency = 0

.Visible = msoTrue

.Weight = 0.5

End With

With .TextFrame2.TextRange

.Characters.Text = s

.ParagraphFormat.Alignment = msoAlignCenter

End With

.TextFrame2.VerticalAnchor = msoAnchorMiddle

.TextFrame.TextRange.Font.Color = RGB(255, 0, 0)

.ActionSettings(ppMouseClick).Hyperlink.SubAddress = ss

End With

' .ShapeRange(1).ActionSettings(ppMouseClick).Hyperlink.SubAddress = ss

End With

sp.ActionSettings(ppMouseClick).Hyperlink.SubAddress = sd.SlideIndex

End Sub

Public Sub HeartOn2(ribbon As IRibbonControl)

Dim tp As Double, lft As Double, s As String, wd As Double, ht As Double

Dim sd As Slide, sp As Shape, sc As Double

Dim shp2 As Shape, ss As String

Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("TextBox1")

ss = shp2.TextFrame.TextRange.Text

sc = 72 / 2.54

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

With ActiveWindow.Selection

If .Type = ppSelectionNone Or .Type = ppSelectionSlides Then

tp = 0

lft = 0

wd = sc * 5

ht = sc * 5

Else

tp = .ShapeRange.Top

lft = .ShapeRange.Left

wd = .ShapeRange.Width

ht = .ShapeRange.Height

End If

Set sd = ActiveWindow.Selection.SlideRange(1)

Set sp = sd.Shapes.AddShape(msoShapeSmileyFace, lft, tp, wd, ht)

With sp

With .Fill

.Visible = msoTrue

.ForeColor.RGB = RGB(255, 255, 0)

.Transparency = 0.61

.Solid

End With

With .Line

.ForeColor.RGB = RGB(237, 125, 49)

.Transparency = 0

.Visible = msoTrue

.Weight = 0.5

End With

With .TextFrame2.TextRange

.Characters.Text = s

.ParagraphFormat.Alignment = msoAlignCenter

End With

.TextFrame2.VerticalAnchor = msoAnchorMiddle

.TextFrame.TextRange.Font.Color = RGB(255, 0, 0)

.ActionSettings(ppMouseClick).Hyperlink.SubAddress = ss

End With

End With

sp.ActionSettings(ppMouseClick).Hyperlink.SubAddress = ss

End Sub