AW: Zellbereich + Bilddatei nach Powerpoint
03.05.2013 12:22:46
fcs
Hallo Lemmi,
in deiner Datei mit den Testdaten trat dieses Phänomen nicht auf, erst nach Vergrößern von Spaltenbreiten.
Es gibt also scheinbar eine max. Breite eines Zellbereichs, die nach dem Kopieren in PP als Grafik eingefügt werden kann.
Ich hab das jetzt so gelöst, dass der relevante Zellbereich in Excel kopiert und als Grafik eingefügt wird. Ggf. wird die Breite auf 20 cm reduziert. Die Größe der Grafik wird dabei auf bis zu 40 % reduziert. Das funktioniert merkwürdigerweise. Anschließend wird die Grafik von Excel nach PP kopiert und in Excel wieder gelöscht.
Gruß
Franz
'Erstellt unter MS Office 2010 professional - Excel 2010, PowerPoint 2010
Option Explicit
Sub ZellbereichePlusBild_Nach_PowerPoint()
'Kopiert Zellbereiche gemäß Kriterien aus dem aktiven Tabellenblatt in _
eine PowerPoint-Präsentation Stand: 2013-05-03
Dim PP As Object 'PowerPoint.Application
Dim PP_Datei As Object 'PowerPoint.Presentation
Dim PP_Folie As Object 'PowerPoint.Slide
Dim PP_Shape As Object 'PowerPoint.Shape
Dim a As Double
Dim xl_Shape As Shape
Dim bool_Erste As Boolean
Dim wks As Worksheet, Spalte As Long, Zeile As Long, SpaBereich As Long
Dim strPathPicture As Variant, strSpalte As String
Dim strDatei_Soll As String, strDatei_Ist As String, intCount As Integer, strMsg As String
'PP-Datei in die die Zellbereich in jeweils eine Folie kopiert werden sollen
Const strPP_Datei As String = "C:\Users\Public\Test\Meine Testpräsentation.pptx" 'anpassen!
'Startverzeichnis für Auswahl Bilder-Verzeichnis
strPathPicture = Worksheets("Bildverzeichnis").Range("A1").Value
If Right(strPathPicture, 1) = "\" Then
strPathPicture = Left(strPathPicture, Len(strPathPicture) - 1)
End If
Set wks = ActiveSheet
With wks
For Spalte = .Range("Q4").Column To .Range("Z4").Column
If .Cells(4, Spalte).Value = 1 Then
'Verzeichnisauswahl
strSpalte = .Columns(Spalte).Address(rowabsolute:=False, columnabsolute:=False, _
ReferenceStyle:=xlA1)
strSpalte = Mid(strSpalte, InStr(1, strSpalte, ":") + 1)
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis für Bilder zu Verteiler in Spalte """ & strSpalte _
& """ auswählen"
.InitialFileName = strPathPicture & "\*.*"
If .Show = -1 Then
strPathPicture = .SelectedItems(1)
Else
GoTo Beenden
End If
End With
'Powerpoint-Vorlage öffnen
Set PP = CreateObject("Powerpoint.Application")
With PP
.Visible = True
Set PP_Datei = .Presentations.Open( _
Filename:=strPP_Datei, _
ReadOnly:=True)
End With
bool_Erste = True
For Zeile = 6 To .Cells(.Rows.Count, Spalte).End(xlUp).Row
If LCase(.Cells(Zeile, Spalte).Value) = "x" Then
'Letzte Folie setzen
Set PP_Folie = PP_Datei.slides(PP_Datei.slides.Count)
If bool_Erste = True Then
'bei erster grafik letzte Folie nicht duplizieren
bool_Erste = False
Else
PP_Folie.Duplicate
Set PP_Folie = PP_Datei.slides(PP_Datei.slides.Count)
'Letzte beiden Grafiken in letzter Folie löschen
With PP_Folie
.Shapes(.Shapes.Count).Delete
If intCount = 2 Then .Shapes(.Shapes.Count).Delete
End With
End If
'letzte gefüllte Zelle im zu kopierenden Bereich ermitteln
For SpaBereich = 16 To 1 Step -1
If .Cells(Zeile, SpaBereich) "" Then Exit For
Next SpaBereich
If SpaBereich Application.CentimetersToPoints(20) Then
.Width = Application.CentimetersToPoints(20)
End If
.Copy
End With
'kopierten Bereich in PP einfügen
PP_Folie.Shapes.PasteSpecial DataType:=3 'ppPasteMetafilePicture
Set PP_Shape = PP_Folie.Shapes(PP_Folie.Shapes.Count)
'Grafik positionieren
With PP_Shape
a = 72 / 2.54 'Umrechnungsfaktor cm in Points
.Left = 2.5 * a '2,5 cm vom linken Rand
.Top = (19.05 - 1) * a - .Height '1 cm vo unteren Rand _
19.05 cm = Höhe der Folie, ggf. anpassen
.Line.Visible = msoCTrue
End With
Application.CutCopyMode = False
xl_Shape.Delete
intCount = 1 '1 Grafikobjekt (Shape) eingefügt
'Name des Bildes einlesen
strDatei_Soll = .Cells(Zeile, 1).Text _
& "_" & .Cells(Zeile, 2).Text & " " & .Cells(Zeile, 3).Text & ".*"
' strDatei_Soll = .Cells(Zeile, 1).Text _
& "_" & .Cells(Zeile, 2).Text & " " & .Cells(Zeile, 3).Text & ".jpg")
'Prüfen, ob Datei existiert
strDatei_Ist = Dir(Pathname:=strPathPicture & "\" & strDatei_Soll)
If strDatei_Ist "" Then
'Bild einfügen
PP_Folie.Shapes.AddPicture Filename:=strPathPicture & "\" & strDatei_Ist, _
linktofile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=2.5 * a, Top:=2 * a
Set PP_Shape = PP_Folie.Shapes(PP_Folie.Shapes.Count)
'Bild Größe anpassen
With PP_Shape
.LockAspectRatio = msoTrue
.Height = 10 * a '10 cm hoch
End With
intCount = intCount + 1 'weiteres Grafikobjekt (Shape) eingefügt
Else
strMsg = strMsg & vbLf & "Zeile " & Zeile & ": " & strPathPicture & "\" _
& strDatei_Soll
End If
End If
Next Zeile
Exit For
End If
Next Spalte
If strMsg "" Then
PP.WindowState = 2 'ppWindowMinimized
Application.WindowState = xlMinimized
Application.WindowState = xlMaximized
MsgBox "Folgende Bilder wurden nicht gefunden!" & strMsg
Else
PP.WindowState = 3 'ppWindowMaximized
End If
End With 'wks
Beenden:
Set PP = Nothing: Set PP_Datei = Nothing: Set PP_Folie = Nothing
Set PP_Shape = Nothing: Set wks = Nothing: Set xl_Shape = Nothing
End Sub