Embedded Files
Hello
20180921-ArbitraryFluxoidRing
〇.pptm
ArbitraryFlux.pptm
Class
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
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
nn = ActiveWindow.Selection.SlideRange.SlideIndex
s = Format(Now, "yyyy/mm/dd:hh:mm:ss")
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
ActiveWindow.View.GotoSlide (nn)
End Sub
Form
Private Sub CommandButton1_Click()
Dim ii As Long
Dim sl As Slide
TextBox1.Text = Format(ActiveWindow.Selection.SlideRange.SlideIndex, "0")
ii = ActiveWindow.Selection.SlideRange.SlideIndex
Set sl = ActivePresentation.Slides(ii)
sl.Name = TextBox4.Text
Call UserForm_Initialize
End Sub
Private Sub CommandButton2_Click()
Dim sl As Slide
Set sl = ActivePresentation.Slides(TextBox4.Text)
sl.Select
Call UserForm_Initialize
End Sub
Private Sub CommandButton3_Click()
Dim ii As Long
Dim sl As Slide
ii = Val(TextBox2.Text)
Set sl = ActivePresentation.Slides.FindBySlideID(ii)
sl.Select
'Call UserForm_Initialize
End Sub
Private Sub CommandButton4_Click()
Dim sd As Slide
Dim n As Long
Dim s As String, sname As String
Dim ribbon As IRibbonControl
n = ActiveWindow.Selection.SlideRange.SlideIndex
s = Format(Now, "yyyy/mm/dd:hh:mm:ss") + "作成" + Chr(13)
With ActivePresentation.Slides(n)
s = s + .NotesPage.Shapes(2).TextFrame.TextRange.Text
' .NotesPage.Shapes(2).TextFrame.TextRange.Text = s
End With
Call Memo.nowを書く(ribbon)
sname = ActivePresentation.Path + vbCrLf + ActivePresentation.Name
n = ActiveWindow.Selection.SlideRange.SlideIndex
s = 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
With ActivePresentation.Slides(n)
s = s + .NotesPage.Shapes(2).TextFrame.TextRange.Text
' .NotesPage.Shapes(2).TextFrame.TextRange.Text = s
End With
TextBox7.Text = s
End Sub
Private Sub TextBox5_Click()
End Sub
Private Sub CommandButton5_Click()
TextBox5.Text = Format(Now(), "yyyy/mm/dd:hh:mm:ss")
End Sub
Private Sub CommandButton6_Click()
Dim ii As Long
Dim sl As Slide
ii = Val(TextBox1.Text)
Set sl = ActivePresentation.Slides(ii)
sl.Select
Call UserForm_Initialize
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub UserForm_Click()
'TextBox1.Text = "AAA"
End Sub
Private Sub UserForm_Initialize()
Dim ii As Long
Dim sl As Slide
TextBox1.Text = Format(ActiveWindow.Selection.SlideRange.SlideIndex, "0")
ii = ActiveWindow.Selection.SlideRange.SlideIndex
Set sl = ActivePresentation.Slides(ii)
TextBox1.Text = Format(ii, "0") ' + " " + sl(ii).Name)
TextBox2.Text = Format(sl.SlideID, "0")
TextBox3.Text = sl.Name
TextBox5.Text = Format(Now(), "yyyy/mm/dd:hh:mm:ss")
'TextBox6.Text = TypeName(Selection)
TextBox6.Text = ActivePresentation.Name
End Sub
Buttons
Sub HeartOn5()
MsgBox "HeartOn5"
End Sub
Sub HeartOn4()
MsgBox "HeartOn4"
End Sub
Sub HeartOn3()
MsgBox "HeartOn3"
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
Memo
Option Explicit
'Private Const idname As String = "Blank5"
' http://suyamasoft.blue.coocan.jp/Ribbon/ReverseResolution/getEnabled/index.html
Private rbRibbon As IRibbonUI ' リボン
Private rbPressed As Boolean ' チェック
Private rbEnabled As Boolean ' 有効・無効]
Private IRctrl As IRibbonControl
Private idname As String
Private YasumoEvent As YasumoClass1
Public Sub Ribbon_onLoad(ribbon As IRibbonUI)
Set rbRibbon = ribbon
rbEnabled = True
If (ActiveWindow.Selection.SlideRange(1).Shapes.HasTitle) Then
idname = ActiveWindow.Selection.SlideRange(1).Shapes.Title.TextFrame.TextRange.Text
Else
idname = "一枚目にタイトルは書かれていません。"
End If
Call LogPPT(" ファイルが開かれました" + vbCrLf + "一枚目のタイトルは: " + idname)
Set YasumoEvent = New YasumoClass1
Set YasumoEvent.App = Application
End Sub
Public Sub SlideEventTest()
Set YasumoEvent = New YasumoClass1
Set YasumoEvent.App = Application
End Sub
Public Sub OldHeartOn2()
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 OldHeartOn(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 nowを書く(ribbon As IRibbonControl)
' MsgBox "nowを書く"
Dim sd As Slide
Dim n As Long
Dim s As String
Dim sname As String
sname = ActivePresentation.Path + vbCrLf + ActivePresentation.Name
n = ActiveWindow.Selection.SlideRange.SlideIndex
s = 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
With ActivePresentation.Slides(n)
s = s + .NotesPage.Shapes(2).TextFrame.TextRange.Text
.NotesPage.Shapes(2).TextFrame.TextRange.Text = s
End With
End Sub
Public Sub スライド名表示(ribbon As IRibbonControl)
' MsgBox "スライド名表示"
UserForm2.Show (False)
End Sub
Sub スライドの名前表示()
UserForm2.Show (False)
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(255, 0, 0)
sp.Fill.BackColor.RGB = RGB(255, 255, 0)
End With
End Sub
Public Sub GetEnabledMacro(control As IRibbonControl, ByRef Enabled)
Enabled = True
Exit Sub
If rbEnabled = True Then
Enabled = False
MsgBox "AAA2"
rbEnabled = False
Else
Enabled = True
MsgBox "BBB2"
rbEnabled = True
End If
Enabled = True
End Sub
Public Sub buttonon() 'マクロを直すと、rbRibbonがリセットされるので、これは走らなくなります。
rbRibbon.Invalidate
End Sub
Sub LogPPT(ByVal mes As String)
Dim p As PowerPoint.Presentation
Dim sd As Slide
Dim pptLayout As CustomLayout
Dim sp As Shape, sc As Single, i As Long, sc2 As Single, v As Double
Dim x0 As Single, y0 As Single, rr As Single, rr2 As Single, x00 As Single, ll As Long
Dim a() As String 'array
Dim nna As Long, n As Long, s As String, nn As Long
Dim flg As Boolean
flg = False
For i = 1 To Presentations.Count
On Error GoTo baka
Set p = Presentations(i)
If p.Slides(1).Shapes.HasTitle Then
s = p.Slides(1).Shapes.Title.TextFrame.TextRange.Text
If s = idname Then
flg = True
Exit For
End If
End If
baka:
Next i
If Not (flg) Then
Exit Sub
End If
nn = ActiveWindow.Selection.SlideRange.SlideIndex
Set sd = p.Slides(1)
sd.Select
ActiveWindow.View.GotoSlide (sd.SlideIndex)
Dim sname As String
sname = ActivePresentation.Path + vbCrLf + ActivePresentation.Name
n = ActiveWindow.Selection.SlideRange.SlideIndex
s = Format(Now, "yyyy/mm/dd:hh:mm:ss") + mes + vbCrLf + sname + vbCrLf + "----------------" + vbCrLf
With ActivePresentation.Slides(n)
s = s + .NotesPage.Shapes(2).TextFrame.TextRange.Text
.NotesPage.Shapes(2).TextFrame.TextRange.Text = s
End With
ActiveWindow.View.GotoSlide (nn)
End Sub
Sub test01()
UserForm2.Show False
End Sub
'UnZip
'UTF-8で開く
'フォルダの中に、「customUI」フォルダ作成。
' 「customUI」フォルダ「customUI.xml」
'タブにボタン追加
'再ZIPする時には、必要なファイルを選んでZIPする。
'必要なファイルの入っているフォルダをZIPしても動かないよ。これは重要
Test
Sub Test()
Dim sd As Slide, shp As Shape
Dim n As Long, nn As Long
n = ActiveWindow.Selection.SlideRange.SlideIndex
Dim s As String
With ActivePresentation.Slides(n).Shapes.BuildFreeform(msoEditingAuto, 0, 110)
' .Name = "目的のもの" + Format(nn, "0")
.AddNodes msoSegmentCurve, msoEditingAuto, 10, 10, 100, 0, 0, 10
.AddNodes msoSegmentCurve, msoEditingAuto, 10, 10, 100, 0, 100, 10
.AddNodes msoSegmentCurve, msoEditingAuto, 10, 10, 100, 0, 100, 110
.AddNodes msoSegmentCurve, msoEditingAuto, 10, 10, 100, 0, 200, 110
.AddNodes msoSegmentCurve, msoEditingAuto, 10, 10, 100, 0, 200, 10
.AddNodes msoSegmentCurve, msoEditingAuto, 10, 10, 100, 0, 300, 10
.AddNodes msoSegmentCurve, msoEditingAuto, 10, 10, 100, 0, 300, 110
.AddNodes msoSegmentCurve, msoEditingAuto, 10, 10, 100, 0, 400, 110
.AddNodes msoSegmentCurve, msoEditingAuto, 10, 10, 100, 0, 400, 10
'.ConvertToShape.Select
Set shp = .ConvertToShape
End With
nn = ActivePresentation.Slides(n).Shapes.Count
s = "目的のもの" + Format(nn, "0")
shp.Name = 2
Set shp = ActivePresentation.Slides(n).Shapes(s)
' shp.Nodes.Count
End Sub
Sub Test2()
Dim sd As Slide, shp As Shape, shp2 As Shape
Dim n As Long, nn As Long
n = ActiveWindow.Selection.SlideRange.SlideIndex
Dim s As String
Dim pap As PowerPoint.Application
'Set pap = ActivePresentation.Parent.Parent.Parent
Set shp = ActivePresentation.Slides("Slide74").Shapes("左矢印 4")
Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("TextBox1")
shp2.TextFrame2.TextRange.Text = Format(shp.ActionSettings(ppMouseClick).Hyperlink.SubAddress, "0")
shp.ActionSettings(ppMouseClick).Hyperlink.SubAddress = 4
'MsgBox shp.ActionSettings(ppMouseClick).Hyperlink.SubAddress
'MsgBox shp.ActionSettings(ppMouseOver).Hyperlink.SubAddress
'MsgBox shp.Name
'MsgBox shp.ActionSettings(ppMouseClick).Hyperlink.Address
MsgBox shp.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink.SubAddress
End Sub
' https://msdn.microsoft.com/ja-jp/vba/powerpoint-vba/articles/hyperlink-object-powerpoint
' http://www.momen40.net/entry/2016/10/27/195541
Sub HeartOn6()
Dim sd As Slide
Dim itp As PpSelectionType
Dim sp As Shape
Dim shp2 As Shape, ss As String, nn As Long
Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("TextBox2")
Set sd = ActiveWindow.Selection.SlideRange(1)
itp = ActiveWindow.Selection.Type
With ActiveWindow.Selection
If itp = ppSelectionShapes Then
Set sp = ActiveWindow.Selection.ShapeRange(1)
shp2.Fill.BackColor.RGB = sp.Fill.BackColor.RGB
shp2.TextFrame.TextRange.Text = sp.AutoShapeType
shp2.TextFrame.TextRange.Font.Color = sp.TextFrame.TextRange.Font.Color
' shp2.Fill.BackColor.RGB = sp.Fill.BackColor.RGB
'shp2.Fill.BackColor.RGB = RGB(255, 0, 155)
nn = sp.Fill.BackColor.RGB
MsgBox nn
shp2.Fill.BackColor.RGB = nn
' shp2.Fill.ForeColor.RGB = sp.Fill.ForeColor.RGB
' shp2.Line.ForeColor.RGB = sp.Line.ForeColor.RGB
' shp2.Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
End With
End Sub
Sub HeartOn7()
Dim sd As Slide
Dim itp As PpSelectionType
Dim tp As Double, lft As Double, s As String, nn As Long
Dim sp As Shape, sc As Double, sp2 As Shape
Dim shp2 As Shape, ss As String
Set shp2 = ActivePresentation.Slides("Patterns作業帳").Shapes("AutoShapeTypeBox1")
sc = 72 / 2.54
Set sd = ActiveWindow.Selection.SlideRange(1)
itp = ActiveWindow.Selection.Type
With ActiveWindow.Selection
If itp = ppSelectionShapes Then
Set sp2 = ActiveWindow.Selection.ShapeRange(1)
s = sp2.TextFrame.TextRange.Text
tp = sp2.Top
lft = sp2.Left
Set sp = sd.Shapes.AddShape(nn, lft, tp + sc * 2, sc * 10, sc * 2)
sp.TextFrame.TextRange.Text = sp2.TextFrame.TextRange.Text
sp.TextFrame.TextRange.Font.Color = shp2.TextFrame.TextRange.Font.Color
sp.Fill.BackColor.RGB = shp2.BackColor.RGB
sp.Fill.ForeColor.RGB = shp2.Fill.ForeColor.RGB
sp.Line.ForeColor.RGB = shp2.Line.ForeColor.RGB
sp.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink.SubAddress = _
sp2.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink.SubAddress
End If
End With
End Sub
Google Sites
Report abuse