PowerPoint - New Presentation - Slide add - TextFrame...

Frage: Ich möchte In Powerpoint Rechtecke erzeugen und Text reinschreiben. Wie geht das?

I want to create in PowerPoint rectangles and write in text. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint - New Presentation - Slide add - TextFrame...[XLS 40 KB]

Option Explicit
' Leeres Slide in PowerPoint 
Const ppLayoutBlank As Long = 12
' Objektvariable für Applikation 
Dim objPP As Object
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : PowerPoint - New Presentation - Slide add - TextFrame... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    Dim intHeight As Integer
    Dim intWidth As Integer
    Dim intCount As Integer
    Dim objPPDoc As Object
    Dim intLeft As Integer
    Dim intTop As Integer
    Dim intTMP As Integer
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Abmasse bzw. der Abstand 
    intHeight = 60
    intWidth = 100
    intCount = 10
    intLeft = 10
    intTop = 10
    ' PowerPoint starten 
    ' Wenn PowerPoint ausgeblendet werden soll, dann so: 
    ' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html 
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        With objPP
            ' Neue Präsentation 
            .Presentations.Add
            ' Neues LEERES Slide 
            .ActivePresentation.Slides.Add 1, ppLayoutBlank
            Set objPPDoc = .ActivePresentation.Slides(1)
        End With
        For intTMP = 1 To 5
            ' Shape Rechteck hinzufügen 
            With objPPDoc.Shapes.AddShape _
                (msoShapeRectangle, 0, 0, intWidth, intHeight)
                ' Text reinschreiben 
                .TextFrame.TextRange.Text = "Test " & intTMP
                ' Schriftgrösse 
                .TextFrame.TextRange.Font.Size = 14
                ' Abstand oben 
                .Top = intCount
                ' Abstand links 
                .Left = intLeft
                ' Für die nächste Plazierung hochzählen 
                intCount = intCount + .Height + intTop
            End With
        Next intTMP
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    ' Objektvariablen zurücksetzen 
    Set objPPDoc = Nothing
    Set objPP = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...