Range - InputBox - PowerPoint...

Mit folgendem Code wird ein Bereich (Auswahl per InputBox) nach PowerPoint kopiert. Eingefügt als Link und als Bild. Automatisch im ermittelten TMP-Ordner gespeichert. Die beiden Bilder oben sind aus dem Objektexplorer (F2 in VBE) von PowerPoint und zeigen die Möglichkeiten des einfügens. Die Dateien am Ende des Beitrages sind in der Version für Excel 2003 und >=2007.

Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias _
    "GetTempPathA" (ByVal strBufferLength As Long, ByVal _
    lpBuffer As String) As Long
Const strPPSave As String = "Test.ppt"
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Test
' Author    : © Case (Ralf Stolzenburg)
' Date      : 25.12.2008
' Purpose   : Range - InputBox - nach PowerPoint...
'--------------------------------------------------------------------------
Public Sub Test()
    Dim strFileName As String
    Dim objPPRange As Object
    Dim objPPApp As Object
    Dim objSlide As Object
    Dim varTMP As Variant
    On Error GoTo Fin
    Set varTMP = Application.InputBox("Range select.", "Select", , , , , , 8)
    Set objPPApp = CreateObject("PowerPoint.Application")
    With objPPApp
        .Visible = True
        .Presentations.Add
        .ActivePresentation.Slides.Add 1, 12
        ThisWorkbook.Worksheets(varTMP.Parent.Name).Range(varTMP.Address).CopyPicture
        Set objSlide = .ActivePresentation.Slides(1)
        Set objPPRange = objSlide.Shapes.Paste
        With objPPRange
            .LockAspectRatio = False
            .Width = objSlide.Design.SlideMaster.Width
            .Height = objSlide.Design.SlideMaster.Height
            .Align 4, True
            .Align 1, True
        End With
        Sheet1.Range(varTMP.Address).Copy
        .ActivePresentation.Slides.Add 2, 12
        .ActiveWindow.View.GotoSlide (2)
        .ActiveWindow.View.PasteSpecial 10, , , , , -1
        .ActivePresentation.Slides.Add 3, 12
        .ActiveWindow.View.GotoSlide (3)
        .ActiveWindow.View.PasteSpecial 2
        strFileName = PP_Save
        .ActivePresentation.SaveAs strFileName & strPPSave
    End With
Fin:
    Application.CutCopyMode = False
    Set objPPRange = Nothing
    Set objPPApp = Nothing
    Set objSlide = Nothing
End Sub
Private Function PP_Save() As String
    Dim strBuffer As String
    Dim lngReturn As Long
    strBuffer = Space(255)
    lngReturn = GetTempPath(255, strBuffer)
    If lngReturn > 0 Then
        PP_Save = Left$(strBuffer, lngReturn)
    Else
        PP_Save = CurDir$
    End If
    If Right(PP_Save, 1) <> "\" Then PP_Save = PP_Save & "\"
End Function

Sample 2003

Sample 2007