Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
984to988
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
984to988
984to988
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

BUG bei xls-to-ppt-Makro

BUG bei xls-to-ppt-Makro
17.06.2008 09:35:00
t4z
Hallo Leute,
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


2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: BUG bei xls-to-ppt-Makro
17.06.2008 11:46:27
t4z
Problem ist behoben, ich kann es mir zwar irgendwie erklären, aber die genaue Erklärung interessiert mich dennoch.
Lösung: Einfach aus link:=msoTrue ein msoFalse machen und fertig :) *schulterzuck*
With ppApp.ActiveWindow
.ViewType = ppViewSlide
.View.PasteSpecial DataType:=ppPasteEnhancedMetafile, link:=msoTrue
End With

AW: BUG bei xls-to-ppt-Makro
17.06.2008 12:31:00
fcs
Hallo t4z,
es ist einfach so, dass die grafische Darstellung des Excel-Tabellen-Range-Objekts nur ohne Verknüpfung (Link) in andere Anwendungen eingefügt werden kann. Hier werden spätere Änderungen der Daten in der Exceldatei dann nicht automatisch in der PP-Datei aktualisiert.
Mit Link zur Ursprungsdatei können in PP nur Excel-Tabellen- oder -Diagramm-Objekte eingefügt werden. Diese werden dann in PP auch genau so dargestellt wie sie aktuell in Excel aussehen, ggf. allso auch mit den blauen Linien der Seitenumbruch-Vorschau.
Unter VBA ist in PP bei der Methode PasteSpecial scheinbar die Einstellung
link:=msoTrue dominant über den Datatype
so dass es nicht zu einem Fehler kommt, sondern bei msoTrue einfach das Excel-Tabellenobjekt mit Link in PP eingefügt wird.
Gruß
Franz
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige