Embedded Files
Hello
Sub 連続写真を作る2()
Dim pt As Presentation
Dim sd As Slide
Dim n As Long, i As Long, v1 As Double, nn As Double
Dim shp As Shape, tt As Long
Dim flg As Boolean, mm As Long
Set pt = ActivePresentation
nn = pt.Slides.Count
Set sd = pt.Slides.AddSlide(nn, pt.SlideMaster.CustomLayouts(7))
nn = nn + 1
pt.Windows(1).Activate
v1 = 0
tt = 0
For i = 2 To 73
Set sd = pt.Slides(i)
pt.Slides(i).Shapes(1).Copy
pt.Slides(nn).Select
pt.Slides(nn).Shapes.PasteSpecial DataType:=0
n = pt.Slides(nn).Shapes.Count
pt.Slides(nn).Shapes(n).Top = v1
pt.Slides(nn).Shapes(n).Left = 1.5 * 72 / 2.56
With pt.Slides(nn).Shapes.AddTextbox(msoTextOrientationHorizontal, 0, v1, 1.5 * 72 / 2.56, 50)
.TextFrame.TextRange.text = Format(tt, "")
End With
v1 = v1 + pt.Slides(nn).Shapes(n).Height
tt = tt + 1
Next i
End Sub
Sub 連続トリミング()
Dim pt As Presentation
Dim sd As Slide
Dim n As Long, i As Long, v1 As Double, nn As Double, tp As Double, lft As Double, bt As Double, rt As Double
Dim shp As Shape, tt As Long
Dim flg As Boolean, mm As Long
Dim s0 As String, s1 As String
Set pt = ActivePresentation
With ActivePresentation.Slides(2).Shapes(1)
tp = .PictureFormat.CropTop
lft = .PictureFormat.CropLeft
bt = .PictureFormat.CropBottom
rt = .PictureFormat.CropRight
End With
For i = 3 To 80
Set shp = pt.Slides(i).Shapes(1)
With shp
.PictureFormat.CropTop = tp
.PictureFormat.CropLeft = lft
.PictureFormat.CropBottom = bt
.PictureFormat.CropRight = rt
End With
Next i
End Sub
Sub 図面左右上下ひっくり返す()
Dim pt As Presentation
Dim sd As Slide
Dim n As Long, i As Long, v1 As Double, nn As Double
Dim shp As Shape, tt As Long
Dim flg As Boolean, mm As Long
Dim s0 As String, s1 As String
Set pt = ActivePresentation
For i = 2 To 80
Set shp = pt.Slides(i).Shapes(1)
shp.Flip (msoFlipHorizontal)
shp.Flip (msoFlipVertical)
Next i
End Sub
Sub 画像貼り付け()
Dim pt As Presentation
Dim sd As Slide
Dim n As Long, i As Long, v1 As Double, nn As Double
Dim shp As Shape, tt As Long
Dim flg As Boolean, mm As Long
Dim s0 As String, s1 As String
s0 = "F:\Casio-ExF1\DCIM-Casio-90-201208-AAA\20120814\DCIM-Casio-20120814\100CASIO\CIMG7406\CIMG7406-2189(every600)〇.png"
Set pt = ActivePresentation
For i = 1 To 20
s1 = Replace(s0, "〇", Format(i, "00"))
nn = pt.Slides.Count
Set sd = pt.Slides.AddSlide(nn, pt.SlideMaster.CustomLayouts(7))
Set shp = sd.Shapes.AddPicture(s1, False, True, 0, 0, -1, -1)
Next i
End Sub
Sub 連続写真を作る()
Dim pt As Presentation
Dim sd As Slide
Dim n As Long, i As Long, v1 As Double, nn As Double
Dim shp As Shape, tt As Long
Dim flg As Boolean, mm As Long
'Set pt = Presentations("プレゼンテーション3")
Set pt = ActivePresentation
'nn = 359
nn = pt.Slides.Count
Set sd = pt.Slides.AddSlide(nn, pt.SlideMaster.CustomLayouts(7))
nn = nn + 1
pt.Windows(1).Activate
v1 = 0
tt = 0
flg = False
mm = 0
For i = 1 To nn
Set sd = pt.Slides(i)
For Each shp In sd.Shapes
If shp.Type = msoOLEControlObject Then
Set obj = shp.OLEFormat.Object
If obj.Value = True Then
If flg = False Then
tt = 0
flg = True
End If
If mm = 1 Then
pt.Slides(i).Shapes(1).Copy
pt.Slides(nn).Select
pt.Slides(nn).Shapes.PasteSpecial DataType:=0
n = pt.Slides(nn).Shapes.Count
pt.Slides(nn).Shapes(n).Top = v1
pt.Slides(nn).Shapes(n).Left = 1.5 * 72 / 2.56
With pt.Slides(nn).Shapes.AddTextbox(msoTextOrientationHorizontal, 0, v1, 1.5 * 72 / 2.56, 50)
.TextFrame.TextRange.text = Format(tt, "")
End With
mm = 0
v1 = v1 + pt.Slides(nn).Shapes(n).Height
Else
mm = 1
End If
End If
End If
Next
If flg = True Then
tt = tt + 1
End If
Next i
End Sub
Sub abc()
Dim sh As Shape
Dim obj As Object
Dim nn As Long, i As Long, k As Long, nnn As Long
Dim shp As Shape, sd As Slide, pt As Presentation
Set pt = ActivePresentation
nn = pt.Slides.Count
For i = 1 To nn
Set sd = pt.Slides(i)
If sd.Shapes.Count > 0 Then
For Each shp In sd.Shapes
If shp.Type = msoOLEControlObject Then shp.Delete
Next
End If
sd.Shapes.AddOLEObject Left:=(25 * 72 / 2.54), Top:=10, _
Width:=15, Height:=15, ClassName:="Forms.CheckBox.1"
nnn = sd.Shapes.Count
Set obj = sd.Shapes(nnn).OLEFormat.Object
obj.Caption = ""
' obj.Value = True
Next i
End Sub
Sub チェックボックスをつける()
Dim sh As Shape
Dim obj As Object
Dim nn As Long, i As Long, k As Long, nnn As Long
Dim shp As Shape, sd As Slide, pt As Presentation
Set pt = ActivePresentation
nn = pt.Slides.Count
For i = 1 To nn
Set sd = pt.Slides(i)
If sd.Shapes.Count > 0 Then
For Each shp In sd.Shapes
If shp.Type = msoOLEControlObject Then shp.Delete
Next
End If
sd.Shapes.AddOLEObject Left:=(25 * 72 / 2.54), Top:=10, _
Width:=15, Height:=15, ClassName:="Forms.CheckBox.1"
nnn = sd.Shapes.Count
Set obj = sd.Shapes(nnn).OLEFormat.Object
obj.Caption = ""
' obj.Value = True
Next i
End Sub
Sub チェックボックスに一定間隔で印を入れる()
Dim sh As Shape
Dim obj As Object
Dim nn As Long, i As Long, k As Long
Dim nnn As Long
Dim shp As Shape
Dim sd As Slide
Dim pt As Presentation
Set pt = ActivePresentation
nn = pt.Slides.Count
k = 16
nnn = 16
'For i = 1 To nn
For i = 58 To 180
Set sd = pt.Slides(i)
For Each shp In sd.Shapes
If shp.Type = msoOLEControlObject Then
Set obj = shp.OLEFormat.Object
If k = nnn Then
k = 1
obj.Value = True
Else
obj.Value = False
k = k + 1
End If
End If
Next
Next i
End Sub
Sub チェックボックスに印をすべてはずす()
Dim sh As Shape
Dim obj As Object
Dim nn As Long, i As Long, k As Long
Dim nnn As Long
Dim shp As Shape
Dim sd As Slide
Dim pt As Presentation
Set pt = ActivePresentation
nn = pt.Slides.Count
For i = 1 To nn
Set sd = pt.Slides(i)
For Each shp In sd.Shapes
If shp.Type = msoOLEControlObject Then
Set obj = shp.OLEFormat.Object
obj.Value = False
End If
Next
Next i
End Sub
Sub TestCh3()
Dim sh As Shape
Dim obj As Object
Set obj = ActivePresentation.Slides(1).Shapes(1).OLEFormat.Object
obj.Value = True
MsgBox ActivePresentation.Slides(1).Shapes(1).Type
MsgBox ActivePresentation.Slides(2).Shapes(1).Type
End Sub
Sub TestCh2()
Dim sh As Shape
ActivePresentation.Slides(1).Shapes.AddOLEObject Left:=100, Top:=100, _
Width:=150, Height:=50, ClassName:="Forms.CheckBox.1"
End Sub
Sub TestCh()
Dim sh As Shape
MsgBox ActivePresentation.Slides(1).Shapes.Count
MsgBox ActivePresentation.Slides(1).Shapes(1).Name
MsgBox TypeName(ActivePresentation.Slides(1).Shapes(1))
Set sh = ActivePresentation.Slides(1).Shapes(1)
MsgBox TypeName(sh)
ActivePresentation.Slides(1).Shapes.AddOLEObject Left:=100, Top:=100, _
Width:=150, Height:=50, ClassName:="Forms.CommandButton.1"
End Sub
Sub AAtest3a()
Dim pt As Presentation
Dim sd As Slide
Dim n As Long, i As Long, v1 As Double, nn As Double
Set pt = Presentations("プレゼンテーション3")
nn = 359
pt.Windows(1).Activate
v1 = 0
For i = 50 To 300
pt.Slides(i).Shapes(1).Copy
pt.Slides(nn).Select
pt.Slides(nn).Shapes.PasteSpecial DataType:=0
n = pt.Slides(nn).Shapes.Count
pt.Slides(nn).Shapes(n).Top = v1
pt.Slides(nn).Shapes(n).Left = 0
v1 = v1 + pt.Slides(nn).Shapes(n).Height
Next i
End Sub
Sub AAtest3()
Dim pt As Presentation
Dim sd As Slide
Dim n As Long, i As Long, v1 As Double, nn As Double
Set pt = Presentations("プレゼンテーション3")
nn = 359
v1 = 0
For i = 50 To 300
ActivePresentation.Slides(i).Shapes(1).Copy
ActivePresentation.Slides(nn).Select
ActivePresentation.Slides(nn).Shapes.PasteSpecial DataType:=0
n = ActivePresentation.Slides(nn).Shapes.Count
ActivePresentation.Slides(nn).Shapes(n).Top = v1
v1 = v1 + ActivePresentation.Slides(nn).Shapes(n).Height
Next i
End Sub
Sub AAtesta()
Dim sd As Slide
Dim n As Long, i As Long, nn As Long
n = ActiveWindow.Selection.SlideRange.SlideIndex
nn = 358
For i = 2 To 300
With ActivePresentation.Slides(i).Shapes(1)
'.PictureFormat.CropTop = 300
.PictureFormat.CropLeft = 370
' .PictureFormat.CropBottom = 320
' .PictureFormat.CropRight = 413
End With
Next i
'Top:245.405700683594
'Left:370.497589111328
'Bottom:320.792388916016
'Right:413.467193603516
End Sub
Sub AAtest()
Dim sd As Slide
Dim n As Long, i As Long, nn As Long
n = ActiveWindow.Selection.SlideRange.SlideIndex
nn = 358
For i = 69 To 300
With ActivePresentation.Slides(i).Shapes(1)
.PictureFormat.CropTop = 300
.PictureFormat.CropLeft = 370
.PictureFormat.CropBottom = 320
.PictureFormat.CropRight = 413
End With
Next i
'Top:245.405700683594
'Left:370.497589111328
'Bottom:320.792388916016
'Right:413.467193603516
End Sub
Sub AAtest2()
Dim sd As Slide
Dim n As Long
n = ActiveWindow.Selection.SlideRange.SlideIndex
'MsgBox n
With ActivePresentation.Slides(n).Shapes(1)
Call Informationを書く(.PictureFormat.CropRight, "Right")
Call Informationを書く(.PictureFormat.CropBottom, "Bottom")
Call Informationを書く(.PictureFormat.CropLeft, "Left")
Call Informationを書く(.PictureFormat.CropTop, "Top")
End With
End Sub
Sub Shapeの大きさ()
Dim sd As Slide
Dim n As Long
n = ActiveWindow.Selection.SlideRange.SlideIndex
'MsgBox n
With ActivePresentation.Slides(n).Shapes(1)
Call Informationを書く(.Height, "Height")
Call Informationを書く(.Width, "Width")
Call Informationを書く(.Top, "Top")
Call Informationを書く(.Left, "Left")
End With
End Sub
Sub Informationを書く(ByVal v1 As Double, s1 As String)
Dim sd As Slide
Dim n As Long
Dim s As String
Dim sname As String
n = ActiveWindow.Selection.SlideRange.SlideIndex
Set sd = ActivePresentation.Slides(n)
sname = ActivePresentation.Path + vbCrLf + ActivePresentation.Name + vbCrLf + "Slide Name=" + sd.Name
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 = "'" + s1 + ":" + Format(v1, "")
With ActivePresentation.Slides(n)
s = s + vbCrLf + .NotesPage.Shapes(2).TextFrame.TextRange.text
.NotesPage.Shapes(2).TextFrame.TextRange.text = s
End With
End Sub
Google Sites
Report abuse