PowerPoint VBA创建幻灯片设置颜色触发运行时错误-2147024809

错误原因 #

触发的-2147024809错误，是因为直接将RGB值赋值给ThemeColorScheme的颜色项导致的。ThemeColorScheme(msoThemeColorBackground1)返回的是ThemeColor对象，不能直接接收RGB数值，必须通过该对象的.RGB属性来设置颜色值。

修正方案 #

将设置主题颜色的代码修改为访问.RGB属性的形式，同时优化路径参数避免解析错误：

核心修正代码 #

With ActivePresentation
    .SlideMaster.Theme.ThemeColorScheme(msoThemeColorAccent1).RGB = RGB(188, 190, 192)
    .SlideMaster.Theme.ThemeColorScheme(msoThemeColorBackground1).RGB = RGB(255, 255, 255)
    .SlideMaster.Theme.ThemeColorScheme(msoThemeColorBackground2).RGB = RGB(206, 52, 51)
End With

额外优化 #

为避免因无活动演示文稿导致的潜在问题，可在代码开头添加自动创建演示文稿的判断：

If ActivePresentation Is Nothing Then
    Set ActivePresentation = Presentations.Add
End If

完整修正后的代码 #

Sub CreateNALS_Presentation()
    ' 确保存在活动演示文稿
    If ActivePresentation Is Nothing Then
        Set ActivePresentation = Presentations.Add
    End If

    ' 设置演示文稿主题配色
    With ActivePresentation
        .SlideMaster.Theme.ThemeColorScheme(msoThemeColorAccent1).RGB = RGB(188, 190, 192)
        .SlideMaster.Theme.ThemeColorScheme(msoThemeColorBackground1).RGB = RGB(255, 255, 255)
        .SlideMaster.Theme.ThemeColorScheme(msoThemeColorBackground2).RGB = RGB(206, 52, 51)
    End With

    ' 添加标题幻灯片
    Dim TitleSlide As Slide
    Set TitleSlide = ActivePresentation.Slides.Add(1, ppLayoutTitle)
    TitleSlide.Shapes.Title.TextFrame.TextRange.Text = "NALS Membership Meeting"

    ' 添加剩余幻灯片
    Dim i As Integer
    For i = 2 To 42
        Dim NewSlide As Slide
        Set NewSlide = ActivePresentation.Slides.Add(i, ppLayoutTitleOnly)
        Select Case i
            Case 2: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Agenda"
            Case 3: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "NALS Board of Directors"
            Case 4: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "NALS Headquarters"
            Case 5: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "NALS Committee Chairs 2022-2023"
            Case 6: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "NALS Committee Chairs 2023-2024"
            Case 7: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "NALS Committees"
            Case 8: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "2022 - 2023 Year in Review"
            Case 9: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "NALS 2023-2024 Strategic Plan"
            Case 10 To 19: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Membership Growth Priority"
            Case 20: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Brand Growth Priority"
            Case 21: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "NALS Chapter Event Promotion"
            Case 22: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Brand Identity Priority"
            Case 23 To 28: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Education Priority"
            Case 29, 30: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Financial Report"
            Case 31: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Revenue Sources"
            Case 32: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Financial Priorities"
            Case 37 To 39: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "2023 Elections"
            Case 40: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Thank you!!"
            Case 41: NewSlide.Shapes.Title.TextFrame.TextRange.Text = "Q&A"
        End Select
        
        ' 添加Logo图片（移除路径多余的方括号）
        Dim LogoPlaceholder As Shape
        Set LogoPlaceholder = NewSlide.Shapes.AddPicture(FileName:="W:\SDrive\NALS\Marketing and Promotion\Branding\Logo Files - 2021 UPDATE\Main Logo\PNG\NALS-Logo-Circular-white.png", _
          LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=100, Top:=400, Width:=100, Height:=100)
    Next i

End Sub

注：已将原代码中的多分支If-Else改为更简洁的Select Case结构，同时移除了AddPicture路径中的多余方括号，避免路径解析错误。

内容的提问来源于stack exchange，提问作者Noah Hutton