PPT専用クラウドフォントを生成

Private Sub CommandButton1_Click()
    On Error GoTo ErrorHandler

    Dim sldCurrent As Slide
    Dim shpText As shape, shpFirstBackground As shape, shpSecondBackground As shape
    Set sldCurrent = ActivePresentation.Slides(1)
    
    Set shpText = sldCurrent.Shapes("Text")
    Set shpFirstBackground = sldCurrent.Shapes("FirstBackground")
    Set shpSecondBackground = sldCurrent.Shapes("SecondBackground")
    
    If Not ValidateInputs(sldCurrent, "FirstBackgroundColor_R_Box", "FirstBackgroundColor_G_Box", _
                          "FirstBackgroundColor_B_Box", "SecondBackgroundColor_R_Box", _
                          "SecondBackgroundColor_G_Box", "SecondBackgroundColor_B_Box", _
                          "TextColor_R_Box", "TextColor_G_Box", "TextColor_B_Box", "FontSizeBox") Then
        MsgBox "文字大小、背景颜色输入框请输入数字"
        Exit Sub
    End If
    
    Dim intFontSize As Integer, strText As String
    Dim lngTextColor As Long, lngFirstBgColor As Long, lngSecondBgColor As Long
    
    intFontSize = GetInputAsInteger(sldCurrent, "FontSizeBox")
    strText = GetInputAsString(sldCurrent, "TextBox")
    
    lngTextColor = GetColorFromInputs(sldCurrent, "TextColor")
    lngFirstBgColor = GetColorFromInputs(sldCurrent, "FirstBackgroundColor")
    lngSecondBgColor = GetColorFromInputs(sldCurrent, "SecondBackgroundColor")
    
    InitializeShape shpText, strText, intFontSize, lngTextColor
    InitializeShape shpFirstBackground, strText, intFontSize, lngFirstBgColor, 25
    InitializeShape shpSecondBackground, strText, intFontSize, lngSecondBgColor, 50
    
    With sldCurrent.Shapes.Range(Array(shpText.Name, shpFirstBackground.Name, shpSecondBackground.Name)).Group
        .Copy
        .Ungroup
    End With

    Exit Sub

ErrorHandler:
    HandleError
End Sub

Private Sub HandleError()
    MsgBox "发生错误: " & Err.Description
End Sub

Private Function ValidateInputs(sldCurrent As Slide, ParamArray arrShapeNames() As Variant) As Boolean
    Dim shp As shape
    For Each shp In sldCurrent.Shapes.Range(arrShapeNames)
        If Not IsNumeric(shp.OLEFormat.Object.text) Then
            ValidateInputs = False
            Exit Function
        End If
    Next shp
    ValidateInputs = True
End Function

Private Function GetColorFromInputs(sldCurrent As Slide, strColorPrefix As String) As Long
    GetColorFromInputs = RGB(GetInputAsInteger(sldCurrent, strColorPrefix & "_R_Box"), _
                             GetInputAsInteger(sldCurrent, strColorPrefix & "_G_Box"), _
                             GetInputAsInteger(sldCurrent, strColorPrefix & "_B_Box"))
End Function

Private Function GetInputAsInteger(sldCurrent As Slide, strShapeName As String) As Integer
    GetInputAsInteger = CInt(sldCurrent.Shapes(strShapeName).OLEFormat.Object.text)
End Function

Private Function GetInputAsString(sldCurrent As Slide, strShapeName As String) As String
    GetInputAsString = sldCurrent.Shapes(strShapeName).OLEFormat.Object.text
End Function

Private Sub InitializeShape(shp As shape, strText As String, intFontSize As Integer, lngColor As Long, Optional intLineWeight As Integer = 0)
    ApplyTextSettings shp, strText, intFontSize, lngColor, intLineWeight
End Sub

Private Sub ApplyTextSettings(shpTarget As shape, strText As String, intFontSize As Integer, lngTextColor As Long, Optional intLineWeight As Integer = 0)
    With shpTarget
        If .HasTextFrame Then
            With .TextFrame.TextRange
                .text = strText
                .Font.Size = intFontSize
                .Font.Color.RGB = lngTextColor
            End With
            
            .TextFrame.WordWrap = msoTrue
            .TextFrame.AutoSize = ppAutoSizeShapeToFitText
        End If
        
        If intLineWeight > 0 Then
            With .TextFrame2.TextRange.Font.Line
                .Visible = msoTrue
                .ForeColor.RGB = lngTextColor
                .Transparency = 0
                .Weight = intLineWeight
            End With
        End If
    End With
End Sub

Private Sub CommandButton2_Click()
    On Error GoTo ErrorHandler
    
    Dim sldCurrent As Slide
    Set sldCurrent = ActivePresentation.Slides(1)
    
    InitializeSlideShapes sldCurrent
    MsgBox "初始化完成"
    
    Exit Sub

ErrorHandler:
    HandleError
End Sub

Private Sub InitializeTextInputs(sldCurrent As Slide)
    With sldCurrent
        .Shapes("TextBox").OLEFormat.Object.text = "Hello, World!"
        .Shapes("FontSizeBox").OLEFormat.Object.text = 60
    End With
End Sub

Private Sub InitializeColorInputs(sldCurrent As Slide)
    With sldCurrent
        .Shapes("TextColor_R_Box").OLEFormat.Object.text = 0
        .Shapes("TextColor_G_Box").OLEFormat.Object.text = 0
        .Shapes("TextColor_B_Box").OLEFormat.Object.text = 0
        
        .Shapes("FirstBackgroundColor_R_Box").OLEFormat.Object.text = 255
        .Shapes("FirstBackgroundColor_G_Box").OLEFormat.Object.text = 255
        .Shapes("FirstBackgroundColor_B_Box").OLEFormat.Object.text = 255
        
        .Shapes("SecondBackgroundColor_R_Box").OLEFormat.Object.text = 39
        .Shapes("SecondBackgroundColor_G_Box").OLEFormat.Object.text = 154
        .Shapes("SecondBackgroundColor_B_Box").OLEFormat.Object.text = 225
    End With
End Sub

Private Sub InitializeSlideShapes(sldCurrent As Slide)
    InitializeTextInputs sldCurrent
    InitializeColorInputs sldCurrent
    
    InitializeShape sldCurrent.Shapes("Text"), "Hello, World!", 60, RGB(0, 0, 0)
    InitializeShape sldCurrent.Shapes("FirstBackground"), "Hello, World!", 60, RGB(255, 255, 255), 25
    InitializeShape sldCurrent.Shapes("SecondBackground"), "Hello, World!", 60, RGB(39, 154, 225), 50
End Sub