Embedded Files
Hello
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
Google Sites
Report abuse