PowerPoint 2010 - Macro

[jlugo]

Hello,

Any know some VBA code to quickly press CTRL PB for example, to generate a yellow colored text box labeled "Pending Box" in power point?

Thanks

 

[pbornemeier]

You can set this to run from the Quick Action toolbar.

Option Explicit

Sub Add_PBBox()
    AddTextBoxToSlide True, 1, "txtPendingBox", 300, 150, 200, 200, "Pending Box", rgbYellow, rgbRed, 0, msoAnchorMiddle, msoAnchorNone, 4, , msoLineSolid, "Arial", 32, , True
End Sub
    
Sub AddTextBoxToSlide(bWarn As Boolean, lSlideIndex As Long, sBoxName As String, sngBoxLeft As Single, _
        sngBoxTop As Single, sngBoxWidth As Single, sngBoxHeight As Single, _
        sText As String, lBoxFillColor As Long, lBoxLineColor As Long, _
        sngBoxFillTransparancy As Single, Optional lTextVertPos As MsoVerticalAnchor, _
        Optional lTextHorizPos As MsoHorizontalAnchor, Optional sngBoxLineWeight As Single, _
        Optional lBoxLineStyle As MsoLineStyle, Optional lBoxLineDashStyle As MsoLineDashStyle, _
        Optional sFontName As String, Optional sngFontSize As Single, _
        Optional bFontItalic As Boolean, Optional bFontBold As Boolean, _
        Optional bFontUnderline As Boolean, Optional bFontShadow As Boolean, _
        Optional lFontColor As Long)
    
    Dim PPApp As Object ' As PowerPoint.Application
    Dim PPPres As Object ' As PowerPoint.Presentation
    Dim PPSlide As Object ' As PowerPoint.Slide
    Dim lSlideCount As Long
    Dim sOutput As String
    
    Dim sngScreenWidth As Single
    Dim sngScreenHeight As Single
    Dim sngRibbonHeight1 As Single
    Dim sngRibbonHeight2 As Single
    
    
    ' Reference instance of PowerPoint
    On Error Resume Next
    ' Check whether PowerPoint is running
    Set PPApp = GetObject(, "PowerPoint.Application")
    If PPApp Is Nothing Then
        Stop 'this should not happen
        GoTo End_Sub
        ' PowerPoint is not running, create new instance
        'Set PPApp = CreateObject("PowerPoint.Application")
        ' For automation to work, PowerPoint must be visible
        PPApp.Visible = True
    End If
    
    'Position PPT
'    Dim sngScreenWidth As Single
'    Dim sngScreenHeight As Single
'    Dim sngRibbonHeight1 As Single
'    Dim sngRibbonHeight2 As Single

    With PPApp
        .WindowState = 3 'ppWindowMaximized
        sngScreenWidth = .Width
        sngScreenHeight = .Height
        .WindowState = 1 'ppWindowNormal
        .Width = sngScreenWidth / 3
        .Height = sngScreenHeight / 2
        .Left = 2 * .Width
        .Top = .Height
        sngRibbonHeight1 = .CommandBars("Ribbon").Height
        SendKeys "^{F1}", False
        DoEvents
        sngRibbonHeight2 = .CommandBars("Ribbon").Height
        If sngRibbonHeight2 > sngRibbonHeight1 Then SendKeys "^{F1}", False
    End With
    

    lSlideCount = PPApp.ActivePresentation.Slides.Count
    If Err.Number <> 0 Then lSlideCount = 0
    
    On Error GoTo 0

    If lSlideCount < lSlideIndex Then
        sOutput = "Slide " & lSlideIndex & " does not exist.  TextBox: " & sBoxName & " not createad.  Exiting."
        Debug.Print sOutput
        If bWarn Then MsgBox sOutput, , "Invalid Slide Number"
        GoTo End_Sub
    End If
    
    If sngFontSize = 0 Then sngFontSize = 12
    If lBoxLineStyle = 0 Then lBoxLineStyle = 1
    If lBoxLineDashStyle = 0 Then lBoxLineDashStyle = 1
    If sngBoxLineWeight = 0 Then sngBoxLineWeight = 1
    If lTextVertPos = 0 Then lTextVertPos = msoAnchorMiddle
    If lTextHorizPos = 0 Then lTextHorizPos = msoAnchorCenter
    
    'Ensure Normal slide view
    PPApp.ActiveWindow.ViewType = ppViewSlide
    
    'Select slide to edit
    PPApp.ActiveWindow.View.GotoSlide (lSlideIndex)
    
    'Delete shape if it already exists
    On Error Resume Next
    PPApp.ActiveWindow.Selection.SlideRange.Shapes(sBoxName).Delete
    On Error GoTo 0
    
    PPApp.ActiveWindow.Selection.SlideRange.Shapes.AddShape _
        (msoShapeRectangle, sngBoxLeft, sngBoxTop, sngBoxWidth, sngBoxHeight).Name = sBoxName
        
    With PPApp.ActiveWindow.Selection.SlideRange.Shapes(sBoxName)
        With .TextFrame.TextRange.Font
            If sFontName <> vbNullString Then .Name = sFontName
            .Size = sngFontSize
            .Italic = bFontItalic
            .Bold = bFontBold
            .Shadow = bFontShadow
            .Color = lFontColor
            .Underline = bFontUnderline
        End With
        '.TextFrame.VerticalAnchor = msoAnchorMiddle
        '.TextFrame.HorizontalAnchor = msoAnchorCenter
        .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft

        .Fill.ForeColor.RGB = lBoxFillColor
        .Fill.Transparency = sngBoxFillTransparancy
        
        .Line.DashStyle = lBoxLineDashStyle 'msoLineDashDot
        .Line.Style = lBoxLineStyle
        .Line.ForeColor.RGB = lBoxLineColor
        .Line.Weight = sngBoxLineWeight
        .TextFrame.TextRange.Text = sText
        
    End With

End_Sub:
    
End Sub