PowerPoint (一般・VBA)

PowerPoint 一般・VBAに関する話題を扱うフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 7 Professional : PowerPoint 2016)
□や△を3Dに変更するマクロ命令
投稿日時: 19/03/16 14:02:05
投稿者: gorby

円を球(3D)に変更するマクロ命令を下記のとおり作成しました。
同様に、□や△を3Dに変更したいが、マクロ命令をどのように修正すれば可能でしょうか?
具体的には□や△の右下に影が出るような3Dを想定しています。
 
 
---円を3Dに変更はじめ---
Sub 球づくり()
    Dim Shprng As ShapeRange
    Set Shprng = ActiveWindow.Selection.ShapeRange
     
    Dim s As Shape
    For Each s In Shprng
        s.Height = s.Width
        s.ThreeD.BevelTopDepth = s.Width / 2
        s.ThreeD.BevelTopInset = s.Width / 2
    Next
End Sub
---円を3Dに変更おわり---

回答
投稿日時: 19/03/17 13:53:12
投稿者: hatena
投稿者のウェブサイトに移動

ここで回答を待つより、マクロの記録ですぐにわかると思いますが。
 
       s.Shadow.Type = msoShadow21

回答
投稿日時: 19/03/18 10:56:33
投稿者: sk

引用:
□や△を3Dに変更したい

引用:
具体的には□や△の右下に影が出るような3D

(標準モジュール)
--------------------------------------------------------------
Sub SetThreeD()
 
    If ActiveWindow.Selection.Type <> ppSelectionShapes Then
        Exit Sub
    End If
     
    Dim Shprng As ShapeRange
    Set Shprng = ActiveWindow.Selection.ShapeRange
    Dim s As Shape
     
    For Each s In Shprng
        With s
            Select Case .AutoShapeType
                Case msoShapeOval
                    .Height = .Width
                    .ThreeD.BevelTopDepth = .Width / 2
                    .ThreeD.BevelTopInset = .Width / 2
                Case msoShapeRectangle, msoShapeIsoscelesTriangle
                    With .ThreeD
                        .Depth = s.Width
                        .ExtrusionColor.RGB = &H333333
                        .ContourWidth = 1
                        .ContourColor.RGB = &H333333
                        .RotationX = -15
                        .RotationY = -15
                        .RotationZ = 0
                        .PresetLighting = msoLightRigHarsh
                        .LightAngle = 45
                        .Perspective = True
                        .FieldOfView = 0
                    End With
                Case Else
                    '何もしない
            End Select
        End With
    Next
 
    Set Shprng = Nothing
 
End Sub
--------------------------------------------------------------
 
以上のような感じでしょうか。

投稿日時: 19/04/16 06:26:51
投稿者: gorby

gorby さんの引用:
円を球(3D)に変更するマクロ命令を下記のとおり作成しました。
同様に、□や△を3Dに変更したいが、マクロ命令をどのように修正すれば可能でしょうか?
具体的には□や△の右下に影が出るような3Dを想定しています。
 
 
---円を3Dに変更はじめ---
Sub 球づくり()
    Dim Shprng As ShapeRange
    Set Shprng = ActiveWindow.Selection.ShapeRange
     
    Dim s As Shape
    For Each s In Shprng
        s.Height = s.Width
        s.ThreeD.BevelTopDepth = s.Width / 2
        s.ThreeD.BevelTopInset = s.Width / 2
    Next
End Sub
---円を3Dに変更おわり---

ありがとう。