BUG bei xls-to-ppt-Makro
17.06.2008 09:35:00
t4z
ich habe hier bei Euch viel gelernt, was auch der Grund ist, warum ich hier so lang nicht mehr aktiv war. Nun ist es aber soweit, ich komme einfach nicht mehr weiter.
Kollegen von mir müssen mehrmals pro Woche umständlich aus mehr als 10 xls-Sheets einen bestimmten, nicht immer gleichen Bereich aus dem aktuell definierten Druckbereich markieren, kopieren und dann in ppt per "Bearbeiten>Inhalte einfügen>Bild (erweiterte Metadatei)" einfügen, positionieren und skalieren. Das Ganze für jedes einzelne xls-Sheet. So ich habe eigentlich alles fertig, auch das dynamische Ermitteln des relevanten zu kopierenden Bereichs. Der Anwender muss anschließend nurnoch die Bilder skalieren und fertig. Leider passiert etwas sehr merkwürdiges am Ende des Markos. Genau dann, wenn ich die ppt-Datei automatisch (oder manuell) speichere, bekomme ich bei manchen - nicht allen - eingefügten Bildern an manchen Rändern einen blauen Streifen. Der Streifen erinnert ein wenig an den blauen Rand, wenn man sich im Excel in der Seitenumbruch-Vorschau befindet und einen Druckbereich definiert hat. Die zu exportierenden Bereiche haben sowohl Zellen mit Inhalt, Textfelder und Diagramme. Habe verschiedenes ausprobiert, wie Ihr am auskommentierten Quelltext erkennen könnt.
Bitte helft mir, vielen Dank, t4z
Quelltext:
' noch herausfinden, warum nach dem speichern die balken (blaue ränder) kommen
' manuell wird ja eigentlich das gleiche gemacht und dort kommen keine balken
' vllt über verschiedene einfüge-fkt'en ausprobieren
' oder nochmal mit ansichtswechsel
Sub pptExport()
' Deklarationen
Dim printerBefore$, title$
Dim c As Variant
Dim exportRange As Range
Dim i%
Dim answer
Dim xlViewBefore
Dim ppApp As Object
Dim ppFile As Object
Dim ppPres As String
Dim picObj As Object, picName As String
' auf farbdrucker umstellen, um den 'farb-bug' zu umgehen
printerBefore = Application.ActivePrinter
Application.ActivePrinter = "\\Printserver\BLABLA auf BLUBB:"
' bei jedem
For Each c In ActiveWorkbook.Sheets
c.Select
answer = MsgBox("Soll dieses Sheet in die Präsi ?" & vbCrLf & vbCrLf & "Ja - exportiert _
_
Sheet in die ppt" & _
vbCrLf & "Nein - überspringt dieses Sheet" & vbCrLf & _
"Abbrechen - Beendet den Exportvorgang", vbYesNoCancel, "SheetExport")
If answer = vbYes And InStr(1, ActiveSheet.Name, "") = 0 Then
' ' Ansicht speichern und dann auf Normalansicht umstellen
' xlViewBefore = ActiveWindow.View
' ActiveWindow.View = xlNormalView
' Titel auslesen
If ActiveSheet.Name = "Titel" Then ' Deckblatt
title = ""
Else
title = Range(Left(Range(ActiveSheet.PageSetup.PrintArea).Address(False, False), _
_
_
InStr(1, Range(ActiveSheet.PageSetup.PrintArea).Address(False, False), ":") - 1) _
_
)
End If
' ' Druckbereich 'minus' der ersten Zeile kopieren
' Application.Intersect(Range(ActiveSheet.PageSetup.PrintArea), _
' Range(ActiveSheet.PageSetup.PrintArea).Offset(1, 0)).Copy
' Hier wird der Bereich(Druckbereich 'minus' erste Zeile) nach
' nichtleeren zellen durchsucht u anschl entspr für den export markiert
notEmptyRange(Application.Intersect(Range(ActiveSheet.PageSetup.PrintArea), _
Range(ActiveSheet.PageSetup.PrintArea).Offset(1, 0))).Select
Selection.Copy
If i = 0 Then
' Object referenzieren
Set ppApp = CreateObject("Powerpoint.Application")
' Object initialisieren
ppApp.Visible = msoTrue
ppApp.WindowState = ppWindowMinimized
' PPT öffnen
' ppApp.Presentations.Add WithWindow:=msoTrue
ppPres = "C:\universal-tmpl.ppt"
Set ppFile = ppApp.Presentations.Open(ppPres)
i = 1
End If
' Folie hinzufügen und Layout festlegen
If i = 1 Then
ppApp.ActivePresentation.Slides(1).Select
Else
ppApp.ActivePresentation.Slides.Add(Index:=i, Layout:=ppLayoutBlank).Select
End If
' Überschrift in Textfeld einfügen
' Call neuesTextfeld(title)
ppApp.ActiveWindow.Selection.SlideRange.Shapes.AddLabel( _
msoTextOrientationHorizontal, 18.12, 15.5, 510.12, 50.12).Select
With ppApp.ActiveWindow.Selection.ShapeRange
.TextFrame.AutoSize = ppAutoSizeNone
.TextFrame.WordWrap = msoTrue
.TextFrame.TextRange.Paragraphs(Start:=1, Length:=1).ParagraphFormat.Alignment = _
_
ppAlignLeft
.Fill.Transparency = 0#
.TextFrame.MarginLeft = 0#
.TextFrame.MarginRight = 28.35
.TextFrame.MarginTop = 0#
.TextFrame.MarginBottom = 2.83
.TextFrame.VerticalAnchor = msoAnchorBottom
End With
With ppApp.ActiveWindow.Selection.TextRange
.text = title
.ParagraphFormat.LineRuleWithin = msoTrue
.ParagraphFormat.SpaceWithin = 1
.ParagraphFormat.LineRuleBefore = msoTrue
.ParagraphFormat.SpaceBefore = 0.5
.ParagraphFormat.LineRuleAfter = msoTrue
.ParagraphFormat.SpaceAfter = 0
.Font.Name = "Arial"
.Font.Size = 18
.Font.Bold = msoTrue
.Font.Italic = msoFalse
.Font.Underline = msoFalse
.Font.Shadow = msoFalse
.Font.Emboss = msoFalse
.Font.BaselineOffset = 0
.Font.AutoRotateNumbers = msoFalse
.Font.Color.SchemeColor = ppAccent1
End With
ppApp.ActiveWindow.Selection.Unselect
' Bereich einfügen und OLE Verknüpfung herstellen = Link
With ppApp.ActiveWindow
.ViewType = ppViewSlide
' .View.PasteSpecial DataType:=ppPasteDefault, link:=msoTrue
' .View.PasteSpecial DataType:=ppPasteMetafilePicture, link:=msoTrue
.View.PasteSpecial DataType:=ppPasteEnhancedMetafile, link:=msoTrue
End With
'Eingefügte Tabelle skalieren
With ppApp.ActiveWindow.Selection.ShapeRange
' Oberer Rand 1 cm unter Standardtitel
.Top = 84.25
' Linker Rand 1.5 cm von linkem Folienrand
.Left = 18.12
' Eingefügte Tabelle auf Links und rechts 1,5 cm Rand skalieren
' .Width = 650
' Bei Bedarf Höhe noch einstellen
' Hier ist jedoch zu beachten, dass das Object skaliert wird !!!
' Die Breite verändert sich dann
' .Height = 450
End With
' ' Ansicht wieder auf vorigen Wert zurückstellen
' ActiveWindow.View = xlViewBefore
' Zähler hochsetzen, damit die Folien ihre fortlaufende Nr erhalten
i = i + 1
ElseIf answer = vbNo Then
' Next
ElseIf answer = vbCancel Then
Exit For
' Else
' MsgBox "ERROR"
' Exit For
End If
Next
' zurücksetzen des druckers
Application.ActivePrinter = printerBefore
' speichern der ppt-datei unter gleichem namen wie das xls, genau wie dem pfad
ppApp.ActivePresentation.SaveAs Filename:=ActiveWorkbook.Path & "\" & Left(ActiveWorkbook. _
_
Name, _
InStr(1, ActiveWorkbook.Name, ".xls") - 1) & ".ppt"
' ppt sichtbar machen
' ppApp.Visible = msoTrue
ppApp.ActivePresentation.Slides(1).Select
ppApp.WindowState = ppWindowMaximized
End Sub