お皿 クラスモジュールにしてみる。

chemiphys.hateblo.jp

時間が全くかけれていないのがばれますが，多忙中，頭のオアシスとして遊んでいるこのシリーズ

前回の記事でthomさんから，こんなコメントをいただいていました。

コメントの引用の仕方がよくわからないので，SnippingToolで。

ふむふむなるほど。こういう機能を実装するならどうしようか，と考えてみました。

いろんなところがまだまだですが，気持ちは伝わるかもしれないというほんっとてきとーなコードです。

でもParamArrayに挑戦してみたり，時間がないくせに欲張ってはみています。Typeステートメントも初めて挑戦。

３つの図形をてきとーに作って，試してみるとたぶん動きます。

一度動かしてしまうと，グループ化を解除したりしないと動かない駄作ですが，
皿を作って回転中心も設定して，動かすという機構はなんとかなったという感じです。
ParamArrayはVariantしか使えないというのにしばらく困りましたが，Shapeで宣言した変数に放り込めたので，なんとか動きました。

キョウモ，タノシカッタ。
追記　見直したらShapeIDという配列変数の名前最悪だ・・でももうネマス。😞

標準モジュール

Option Explicit
Type Position
    x As Currency
    y As Currency
End Type
Const x = 100, y = 200
Dim StopFlag As Boolean

Sub test()
Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(1)
Dim Plate1 As PlateObject: Set Plate1 = New PlateObject
Plate1.Assemble TargetSlide.Shapes(1), TargetSlide.Shapes(2), TargetSlide.Shapes(3)
Plate1.SetCenter x, y
StopFlag = False
ActivePresentation.SlideShowSettings.Run
Do
    Plate1.RotateRight Degree:=1
    If StopFlag = True Then Exit Do
Loop
SlideShowWindows(1).View.Exit
End Sub

Sub STopMacro()
    StopFlag = True
End Sub

PlateObject.cls

Option Explicit
Private CenterPosition As Position
Private PlateRotation As Long
Private PlateShape As Shape
Private ShapeID() As Long
Private TargetSlide As Slide

Public Sub Assemble(ParamArray ArgShapes())
    Dim s As Shape
    Dim ShapePos() As Position: ReDim ShapePos(UBound(ArgShapes))
    ReDim ShapeID(UBound(ArgShapes) + 1)
    Dim i As Long: i = 0
    For i = 0 To UBound(ArgShapes)
        Set s = ArgShapes(i)
        If i = 0 Then
            Set TargetSlide = ActivePresentation.Slides(s.Parent.SlideIndex)
        End If
        ShapePos(i).x = Pos(s).x
        ShapePos(i).y = Pos(s).y
        ShapeID(i) = SIndex(s)

    Next
End Sub
Public Sub SetCenter(CenterX As Currency, CenterY As Currency)
    CenterPosition.x = CenterX
    CenterPosition.y = CenterY
    Dim tmpRadius As Currency
    Dim PlateRadius As Currency
    
    Dim i As Long: i = 0
    Dim s As Shape
    
    PlateRadius = 0
    For i = 0 To UBound(ShapeID) - 1
        Set s = TargetSlide.Shapes(ShapeID(i))
        tmpRadius = Sqr((Pos(s).x - CenterPosition.x) ^ 2 + (Pos(s).y - CenterPosition.y) ^ 2) + Sqr(s.Width ^ 2 + s.Height ^ 2)
        If tmpRadius > PlateRadius Then PlateRadius = tmpRadius
    Next
    
    Dim tmpPlate As Shape
    Set tmpPlate = TargetSlide.Shapes.AddShape(msoShapeOval, CenterPosition.x - PlateRadius, CenterPosition.y - PlateRadius, PlateRadius * 2, PlateRadius * 2)
        tmpPlate.Fill.Visible = msoFalse
        tmpPlate.Line.Visible = msoFalse
    ShapeID(UBound(ShapeID)) = SIndex(tmpPlate)
    
    Set PlateShape = TargetSlide.Shapes.Range(ShapeID).Group
End Sub
Private Function Pos(TargetShape As Shape) As Position
    Pos.x = TargetShape.Left + TargetShape.Width / 2
    Pos.y = TargetShape.Top + TargetShape.Height / 2
End Function
Function SIndex(ByVal TargetShape As PowerPoint.Shape) As Long
    Dim TargetSlide As Slide: Set TargetSlide = ActivePresentation.Slides(TargetShape.Parent.SlideIndex)
    
    If TargetShape.Child = msoTrue Then '完全に真似させてもらった。グループ内図形の場合は親を返す
        Let SIndex = SIndex(TargetShape.ParentGroup)
        Exit Function
    End If
    
    Dim db As Object: Set db = CreateObject("Scripting.Dictionary")
    Dim s As Shape
    Dim i As Long: i = 1
    
    For Each s In TargetSlide.Shapes
        db(s.Id) = i
        i = i + 1
    Next
    
    Let SIndex = db.Item(TargetShape.Id)
    
End Function
Public Sub RotateRight(Degree As Long)
    PlateShape.Rotation = PlateShape.Rotation + Degree
    If PlateShape.Rotation = 360 Then PlateShape.Rotation = 0
    TargetSlide.Shapes(1).TextFrame.TextRange = " "
    DoEvents
End Sub
Public Sub RotateLeft(Degree As Long)
    PlateShape.Rotation = PlateShape.Rotation - Degree
    If PlateShape.Rotation = -360 Then PlateShape.Rotation = 0
    TargetSlide.Shapes(1).TextFrame.TextRange = " "
    DoEvents
End Sub

パワーポイントのVBAをする人探しのためにブログ村に参加しています。

にほんブログ村