

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
Keine Kommentare:
Kommentar veröffentlichen