Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema CommandButton
BildScreenshot zu CommandButton CommandButton-Seite mit Beispielarbeitsmappe aufrufen

VBA PasteSpecial - Titel verschiebt sich

Betrifft: VBA PasteSpecial - Titel verschiebt sich von: Marcus
Geschrieben am: 19.08.2014 14:02:28

Hallo Zusammen!

Ich möchte Diagramme einer Excel-Datei per Makro in eine vorgefertigte PPT-Präsentation als Metadatei einfügen. Funktioniert soweit auch alles ganz gut, nur ein Problem bekomm ich einfach nich in den Griff. Es verschiebt sich der Titel der Folie, bzw. das Textfeld vergrößert sich, es ist so, als hätte man das Bild in das Titelfeld eingefügt. Manchmal verschieben sich auch die Seitenzahlen.

Hoffe Ihr könnt mir weiterhelfen! Anbei der Code:

Private Sub CommandButton1_Click()


Dim pptApp As Object, pptPres As Object
Dim chtObj As Object, shp As Object, i


Set pptApp = CreateObject("PowerPoint.Application")
Set pptPres = pptApp.Presentations.Open("X:...........pptx")
    Sheets("Auswertung").Select

For Each chtObj In ActiveSheet.ChartObjects
    chtObj.CopyPicture xlScreen, xlBitmap

    Set pptslide = pptPres.Slides(i)
    pptslide.Shapes.PasteSpecial DataType:=wdPasteEnhancedMetafile


                 With pptslide.Shapes(1)
                     .Top = 100
                     .Left = 5
                     .Height = 383
                     .Width = 709.5
                End With
    
        If i = 20 Then
        Exit For
    End If
    
Next

pptApp.Visible = True


End Sub

Vielen Dank!
Marcus

  

Betrifft: AW: VBA PasteSpecial - Titel verschiebt sich von: fcs
Geschrieben am: 19.08.2014 15:17:21

Hallo Marcus,

Hauptproblem war der gewählte DataType für das einfügen. Der muss kompatibel zur kopierten Quelle sein.
Außerdem fehlter das Setzen und Hochzählen des Slidezählers.

Gruß
Franz

Sub CommandButton1_Click()

  Dim chtObj As Object, i
  
  Dim pptApp As Object  ' PowerPoint.Application
  Dim pptPres As Object ' PowerPoint.Presentation
  Dim ppShp As Object ' PowerPoint.Shap
  Dim pptSlide As Object ' PowerPoint.Slide
  
  Set pptApp = CreateObject("PowerPoint.Application")
  Set pptPres = pptApp.Presentations.Open("D:\Test\MeinePP.pptx", _
          ReadOnly:=msoTrue) ', untitled:=True)
      Sheets("Auswertung").Select
  
  i = 1 'Startzähler für Slides setzen
  For Each chtObj In ActiveSheet.ChartObjects
      chtObj.CopyPicture xlScreen, xlBitmap
  
      Set pptSlide = pptPres.Slides(i)
'      pptslide.Shapes.PasteSpecial DataType:=0 ' 0 = ppPasteDefault
      pptSlide.Shapes.PasteSpecial DataType:=1 ' 1 = ppPasteBitmap
  
      Set ppShp = pptSlide.Shapes(pptSlide.Shapes.Count)
      With ppShp
             .Top = 100
             .Left = 5
             .Height = 383
             .Width = 709.5
      End With
      
      i = i + 1
      If i = 20 Then
          Exit For
      End If
      
  Next
  
  pptApp.Visible = True
  

End Sub



  

Betrifft: AW: VBA PasteSpecial - Titel verschiebt sich von: Marcus
Geschrieben am: 19.08.2014 15:58:10

Hallo Franz,

zunächst einmal vielen herzlichen Dank! Das benannte Problem tritt nicht mehr auf, aber leider leidet die Qualität der Diagramme bzw. der Bilder massiv unter dem neuen Format. Gibt es Lösung die es dennoch erlaubt die Diagramme als Metadatei einzufügen?

VG Marcus


  

Betrifft: AW: VBA PasteSpecial - Titel verschiebt sich von: fcs
Geschrieben am: 19.08.2014 17:27:54

Hallo Marcus,

wenn man das Chartobject "einfach" nur kopiert, dann hat man mehr Einfügeoptionen für den DataType, von denen einige auch eine bessere Grafikqualität liefern..

Gruß
Franz

Sub CommandButton1_Click()

  Dim chtObj As Object, i
  
  Dim pptApp As Object  ' PowerPoint.Application
  Dim pptPres As Object ' PowerPoint.Presentation
  Dim ppShp As Object ' PowerPoint.Shap
  Dim pptSlide As Object ' PowerPoint.Slide
  
  Set pptApp = CreateObject("PowerPoint.Application")
  Set pptPres = pptApp.Presentations.Open("D:\Test\MeinePP.pptx", _
          ReadOnly:=msoTrue) ', untitled:=True)
      Sheets("Auswertung").Select
  
  i = 1 'Startzähler für Slides setzen
  For Each chtObj In ActiveSheet.ChartObjects
      chtObj.Copy
  
      Set pptSlide = pptPres.Slides(i)
      pptSlide.Shapes.PasteSpecial DataType:=2 ' 2 = ppPasteEnhancedMetafile
'      pptSlide.Shapes.PasteSpecial DataType:=3 ' 3 = ppPasteMetafilePicture
'      pptSlide.Shapes.PasteSpecial DataType:=0 ' 0 = ppPasteDefault - fügt Diagramm-Objekt ein
'      pptSlide.Shapes.PasteSpecial DataType:=1 ' 1 = ppPasteBitmap - miese Qualität
'      pptSlide.Shapes.PasteSpecial DataType:=5 ' 5 = ppPasteJPG - miese Qualität
  
      Set ppShp = pptSlide.Shapes(pptSlide.Shapes.Count)
      With ppShp
             .Top = 100
             .Left = 5
             .Height = 383
             .Width = 709.5
      End With
      
      i = i + 1
      If i = 20 Then
          Exit For
      End If
      
  Next
  
  pptApp.Visible = True
  

End Sub



  

Betrifft: AW: VBA PasteSpecial - Titel verschiebt sich von: Marcus
Geschrieben am: 19.08.2014 18:05:41

Hallo Franz,

wow Danke, Du bist großartig! Jetzt funktioniert alles einwandfrei. Sehe ich das richtig, dass es daran lag, das ich "CopyPicture" statt nur "Copy" zum füllen den Zwischenablage genommen hat und das für die Metadatei nich passte?


  

Betrifft: AW: VBA PasteSpecial - Titel verschiebt sich von: fcs
Geschrieben am: 20.08.2014 09:45:52

Hallo Marcus,

Sehe ich das richtig, dass es daran lag, das ich "CopyPicture" statt nur "Copy" zum füllen den Zwischenablage genommen hat und das für die Metadatei nich passte?

Ja!
Mit "Copy" wird in Excel die normale Kopieraktion für das vorgegebene Objekt durchgeführt. Damit stehen dann beim Einfügen in der Zielanwendung je nach deren Fähigkeiten verschiedenste Formate zur Verfügung. In PP dann von Text über verschiedene Grafikformate bis zu verknüpften Objekten.

Mit CopyPicture wird in Excel eine Grafik etwa mit Screenshot-Qualität in die Zwischenablage übernommen.

Gruß
Franz